Index: branches/publications/ORCHIDEE_CAN_NHA/AA_make
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/AA_make	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/AA_make	(revision 7236)
@@ -0,0 +1,50 @@
+#- $Id$
+all_lib : libioipsl libparallel libparameters liborglob libstomate libsechiba
+
+libioipsl:
+	(cd ../IOIPSL/src; $(M_K) -f Makefile)
+
+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)
+
+driver : all_lib
+	(cd src_driver ; $(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)
+	(cd src_driver; $(M_K) -f Makefile clean)
+
+doc:
+	doxygen Doxyfile_ORCHIDEE
+	export TEXINPUTS="${TEXINPUTS}:${PWD}/DOC//"; export BIBINPUTS="${BIBINPUTS}:${PWD}/DOC/BIB//"; cd docs/latex ; latex refman.tex 
+
+bib:
+	export TEXINPUTS="${TEXINPUTS}:${PWD}/DOC//"; export BIBINPUTS="${BIBINPUTS}:${PWD}/DOC/BIB//"; cd docs/latex ; bibtex refman 
+
+index:
+	export TEXINPUTS="${TEXINPUTS}:${PWD}/DOC//"; export BIBINPUTS="${BIBINPUTS}:${PWD}/DOC/BIB//"; cd docs/latex ; makeindex refman 
+
+toc:
+	export TEXINPUTS="${TEXINPUTS}:${PWD}/DOC//"; export BIBINPUTS="${BIBINPUTS}:${PWD}/DOC/BIB//"; cd docs/latex ; latex refman.tex 
+
Index: branches/publications/ORCHIDEE_CAN_NHA/AA_make.ldef
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/AA_make.ldef	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/AA_make.ldef	(revision 7236)
@@ -0,0 +1,3 @@
+#- $Id$
+#---------------------------------------------------------------------
+#-
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/BIB/orchidee.bib
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/BIB/orchidee.bib	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/BIB/orchidee.bib	(revision 7236)
@@ -0,0 +1,37 @@
+@Article{Chalita_94,
+  author = 	 {{Chalita, S.} and {Le Treut, H.}},
+  title = 	 {``{The albedo of temperate and boreal forest and the Northern Hemisphere climate: a sensitivity experiment using the LMD GCM}''},
+  journal = 	 {Climate Dynamics},
+  year = 	 {1994},
+  volume = 	 {10},
+  pages = 	 {231-240},
+}
+
+
+@Article{Chuine_00,
+  author = 	 {{Chuine, I.}},
+  title = 	 {``{A unified model for budburst of trees}''},
+  journal = 	 {Journal of Theoretical Biology},
+  volume = 	 {207},
+  year = 	 {2000},
+  pages = 	 {337-347}
+}
+
+
+@Article{Bott-Viov-Ciais-Frie-Monf_00,
+  author = 	 {{Botta, A.} and {Viovy, N.} and {Ciais, P.} and {Friedlingstein, P.} and {Monfray, P.}},
+  title = 	 {``{A global prognostic scheme of leaf onset using satellite data.}''},
+  journal = 	 {Global Change Biology},
+  year = 	 {2000},
+  volume = 	 {6},
+  pages = 	 {709-725},
+}
+
+@Article{Orla-Garc-Ezqu-Roma-Domi-Gala-Forn_04,
+  author = 	 {{Orlandi, F.} and {Garcia-Mozo, H.} and {Ezquerra, L.V.} and {Romano, B.} and {Dominguez, E.} and {Galan, C.} and {Fornaciari, M.}},
+  title = 	 {``{Phenological olive chilling requirements in Umbria (Italy) and Andalusia (Spain)}''},
+  journal = 	 {Plant Biosystems},
+  year = 	 {2004},
+  volume = 	 {138},
+  pages = 	 {111-116},
+}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_dev_qsat.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_dev_qsat.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_dev_qsat.tex	(revision 7236)
@@ -0,0 +1,12 @@
+We calculate the deviation of the saturated humidity with the temperature and the pressure.
+\begin{equation}
+\delta q_{sat}(T) = \frac{(q_s(\lfloor T+\frac{1}{2}\rfloor + 1) - 2.q_s(\lfloor T +\frac{1}{2} \rfloor) + q_s(\lfloor T+\frac{1}{2} \rfloor -1))(\lbrace T + \frac{1}{2}\rbrace -1 ) + q_s(\lfloor T+\frac{1}{2} \rfloor +1) - q_s(\lfloor T+\frac{1}{2} \rfloor)}{P}
+\end{equation}
+
+where : \\
+\begin{itemize}
+ \item  $ \lfloor T + \frac{1}{2} \rfloor $ represents the largest integer not greater than $T + \frac{1}{2} $. 
+ \item  $ \lbrace T + \frac{1}{2} \rbrace = T + \frac{1}{2} -\lfloor T + \frac{1}{2} \rfloor $ is the fractional part of $T + \frac{1}{2} $.
+ \item  $q_s$ is the array caclulated in the subroutine qsfrict\_init. 
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_dev_qsatcalc.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_dev_qsatcalc.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_dev_qsatcalc.tex	(revision 7236)
@@ -0,0 +1,14 @@
+We calculate the deviation of the saturated humidity with the temperature and the pressure for a given pixel $x$.
+\begin{multline}
+\delta q_{sat}(x,T) = \\
+\frac{(q_s(x,\lfloor T+\frac{1}{2}\rfloor + 1) - 2.q_s(x,\lfloor T +\frac{1}{2} \rfloor) + q_s(x,\lfloor T+\frac{1}{2} \rfloor -1))(\lbrace T + \frac{1}{2}\rbrace -1 )} {P}+ 
+\\ \frac{q_s(x,\lfloor T+\frac{1}{2} \rfloor +1) - q_s(x, \lfloor T+\frac{1}{2} \rfloor)}{P}
+\end{multline}
+
+where : \\
+\begin{itemize}
+ \item  $ \lfloor T + \frac{1}{2} \rfloor $ represents the largest integer not greater than $T + \frac{1}{2} $. 
+ \item  $ \lbrace T + \frac{1}{2} \rbrace = T + \frac{1}{2} -\lfloor T + \frac{1}{2} \rfloor $ is the fractional part of $T + \frac{1}{2} $.
+ \item  $q_s$ is the array caclulated in the subroutine qsfrict\_init. 
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_goff_gratch.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_goff_gratch.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_goff_gratch.tex	(revision 7236)
@@ -0,0 +1,30 @@
+The subroutine qsfrict\_init uses modified Goff-Gratch equations (1946). The original formulations are : \\
+\begin{multline}
+\log e_w = \\ -7.90298 \left( \frac{T_s}{T} - 1 \right) + 5.02808 \log \left( \frac{T_s}{T} \right) 
+- 1.3816 \times 10^{-7}(10^{11.344 \left( 1-\frac{T_s}{T} \right)}-1) 
++ 8.1328 \times 10^{-3}(10^{-3.49149 \left( \frac{T_s}{T}-1 \right)}
+-1) \\ + \log e_{ws}
+\end{multline}
+where : \\
+\begin{itemize}
+ \item  $ \log(x) = \frac{\ln x}{\ln 10} $. 
+ \item  $e_w$ is the saturation water vapor pressure over a plane surface of pure ordinary liquid water (hPa).
+ \item  $T$ is the absolute air temperature in Kelvin.
+ \item  $T_s$ is the steam point temperature (373.16 K).
+ \item  $e_{ws}$ is the saturation pressure of pure ordinary liquid water at steam-point temperature (at 1 atm = 1013.25 hPa).
+\end{itemize}
+
+\begin{multline}
+\log e_i = \\ -9.09718 \times \left( \frac{T_0}{T} - 1 \right) - 3.56654 \times \log \left( \frac{T_0}{T} \right) 
++ 0.876793 \times \left( 1-\frac{T_0}{T} \right) 
++ \log e_{i0}
+\end{multline}
+where : \\
+\begin{itemize}
+ \item  $ \log(x) = \frac{\ln x}{\ln 10} $. 
+ \item  $e_i$ is the saturation water vapor pressure over a plane surface of pure ordinary water ice (hPa).
+ \item  $T$ is the absolute air temperature in Kelvin (K).
+ \item  $T_0$ is the boiling point at 1 atmosphere temperature (273.16 K).
+ \item  $e^{*}_{i0}$  is the saturation pressure of pure ordinary water ice at ice-point temperature (6.1173 hPa).
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_qsat.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_qsat.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_qsat.tex	(revision 7236)
@@ -0,0 +1,12 @@
+The interpolation the saturated humidity depends on the temperature $T$ (in Kelvin). 
+It is set by the following equation :
+\begin{equation}
+q_{sat}(T)= \dfrac{q_s(\lfloor T \rfloor +1) - q_s(\lfloor T \rfloor).\lbrace T \rbrace + q_s(\lfloor T \rfloor)}{P}
+\end{equation}
+where : \\
+\begin{itemize}
+ \item  $ \lfloor T \rfloor $ represents the largest integer not greater than $T$. 
+ \item  $ \lbrace T \rbrace = T -\lfloor T \rfloor $ is the fractional part of $T$.
+ \item  $q_s$ is the array caclulated in the subroutine qsfrict\_init. 
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_qsatcalc.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_qsatcalc.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_qsatcalc.tex	(revision 7236)
@@ -0,0 +1,12 @@
+The interpolation the saturated humidity on one pixel $x$  depends on the temperature $T$ (in Kelvin). 
+It is set by the following equation :
+\begin{equation}
+q_{sat}(x,T)= \dfrac{q_s(x,\lfloor T \rfloor +1) - q_s(x,\lfloor T \rfloor).\lbrace T \rbrace + q_s(x,\lfloor T \rfloor)}{P}
+\end{equation}
+where : \\
+\begin{itemize}
+ \item  $ \lfloor T \rfloor $ represents the largest integer not greater than $T$. 
+ \item  $ \lbrace T \rbrace = T -\lfloor T \rfloor $ is the fractional part of $T$.
+ \item  $q_s$ is the array caclulated in the subroutine qsfrict\_init. 
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_qsfrict_init.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_qsfrict_init.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_qsfrict_init.tex	(revision 7236)
@@ -0,0 +1,17 @@
+The specific humidity  $q_s$ is a function of temperature $T$. Its values are : 
+\begin{equation}
+q_s(T) = 
+\begin{cases}
+0 & \text{if} \quad T < 100K \\
+\dfrac{M_{air}}{M_{vapor}} \cdot 10^{2.07203 - 0.0032099T - \frac{2484.896}{T} + 3.56654\log{T}} & \text{if} \quad 100K \leq T < 273K \\
+\dfrac{M_{air}}{M_{vapor}} \cdot 10^{23.819 - \frac{2948.964}{T} -
+  5.028\log{T} - 29910.16\exp(-0.0699832\times T) + 25.21935\exp(-\frac{2999.924}{T}) } & \text{if} \quad 273K \leq T \leq 370K \\
+\end{cases} %\]
+\end{equation}
+where : \\
+\begin{itemize}
+ \item  $\dfrac{M_{air}}{M_{vapor}} = \dfrac{18.02 \times 10^{-3}}{28.964 \times 10^{-3}} \simeq 0.622 $ is the ratio between the molecular weight of dry air and \\ 
+the molecular weight of water vapor.
+ \item  $\log(T) = \dfrac{\ln T}{\ln 10}$
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_tempfunc.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_tempfunc.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_parameters/constantes_veg/constantes_veg_tempfunc.tex	(revision 7236)
@@ -0,0 +1,18 @@
+%\documentclass{article}
+%\usepackage[english]{babel}
+%\usepackage{amsmath}
+%\begin{document}
+\begin{equation}
+f(T) = 
+\begin{cases}
+0 & \text{if} \quad T < 273K \\
+1 - \dfrac{(T_{max} - T)^2}{(T_{max} - T_{min})^2} & \text{if} \quad 273K \leq T \leq 293K \\
+1 & \text{if} \quad T > 293K
+\end{cases} %\]
+\end{equation}
+where : \\
+\begin{itemize}
+ \item  $ T_{min} = 273K$ 
+ \item  $ T_{max} = 293K$
+\end{itemize}
+%\end{document}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/condveg/SnowAlbedo.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/condveg/SnowAlbedo.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/condveg/SnowAlbedo.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+snowAlb=snowaIni+snowaDec \times \exp{\frac{-snowAge}{tsctSnowa}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/condveg/SnowFraction.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/condveg/SnowFraction.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/condveg/SnowFraction.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+fracSnow=\frac{snow}{snow+10}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/condveg/z0cdrag1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/condveg/z0cdrag1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/condveg/z0cdrag1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+C = [\frac{1}{\kappa} ln(\frac{z}{z0})]^2 
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_intro.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_intro.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_intro.tex	(revision 7236)
@@ -0,0 +1,100 @@
+%
+% \documentclass[11pt]{amsart}
+% \usepackage{helvet}
+% \usepackage{geometry}    
+% \geometry{a4paper} 
+% \usepackage[parfill]{parskip}  \usepackage{graphicx}
+% \usepackage{amssymb}
+% \usepackage{epstopdf}
+% 
+% 
+% 
+% \begin{document}
+
+As is outlined in Guimberteau (2010), evaporation in ORCHIDEE is calculated as a function of evaporation potential $E_{pot}$, limited by the resistances. Evaporation potential is defined as below:
+
+ \hspace{0.5cm}    \lefteqn{E_{pot} = \frac{\rho}{r_a}(q_{sat}(T_s)-q_{air})}
+
+{\it where $q_{sat}(T_s)$ is the saturation humidity corresponding to a particular surface temperature and $q_{air}$ is the specific humidity in the atmosphere immediately above the surface.}
+
+A conventional way to describe evaporation in surface layer modelling is via the means of the resistance analogy. Below we demonstrate how the $\beta$ coefficients within ORCHIDEE may be re-written in terms of this analogy.
+
+{\bf Evaporation of water intercepted by canopy}
+
+In ORCHIDEE, $\beta_2$, the water interception resistance, is defined as:
+
+\hspace{0.5cm} \lefteqn{E=\beta_{2} E_{pot}}
+
+\hspace{0.5cm} \lefteqn{\beta_{2} = \frac{1}{1+\frac{r_{s_v}}{r_a}}}
+
+{\it where E represents the evapotranspiration, $r_{s_v}$ is the structural resistance of the canopy and $r_a$ is the aerodynamic resistance. }
+
+This can be reformulated in terms of the 'traditional' circuitry analogy, where evapotranspiration represents (in the analogy) the current and the voltage (or potential difference) is represented by the difference in humidity between the saturated surface and the atmosphere just above the ground.
+
+ \hspace{0.5cm} \lefteqn{E\left( 1+\frac{r_{s_v}}{r_a}  \right) = \frac{\rho}{r_a}(q_{sat}(T_s) - q_{air})}
+
+ \hspace{0.5cm} \lefteqn{     \overbrace{   E}^I  \overbrace{ (r_a+r_{s_v})}^R = \overbrace { \rho (q_{sat}(T_s) - q_{air})  }^V }
+
+
+\includegraphics[scale=0.45]{diffuco_schematic2.png}
+
+{\bf Figure 1:} resistance chain for the evaporation of intercepted water
+
+
+\vspace{1cm}
+
+{\bf Transpiration of the canopy}
+
+
+$\beta_3$, the canopy transpiration resistance, is defined as:
+
+
+\hspace{0.5cm} \lefteqn{E=\beta_{3} E_{pot}}
+
+\hspace{0.5cm} \lefteqn{\beta_{3} = \left(  \frac{1}{1+\frac{r_{s_v} + r_{sto_v}}{r_a}}  \right) U_{s_v} }
+
+{\it where E represents the evapotranspiration, $U_{S_v}$ is the potential for extraction from the plant roots, $r_{s_v}$ is the structural resistance of the canopy, $r_{sto_v}$ is the stomatal resistance of the surface cover and $r_a$ is the aerodynamic resistance. }
+
+so:
+
+ \hspace{0.5cm}  \lefteqn{ \frac{E}{\beta_{3}} = \frac{\rho}{r_a}(q_{sat}(T_s)-q_{air})}
+
+\hspace{0.5cm}   \lefteqn{E\left( 1+   \frac{r_{s_v}+r_{sto_v}}{r_a}   \right) U_{sv} = \frac{\rho}{r_a}(q_{sat}(T_s) - q_{air})}
+
+\hspace{0.5cm}   \lefteqn{   \overbrace {  E  }^I   \overbrace{ (r_a + (r_{s_v}+ r_{sto_v}))U_{s_v} }  ^R =   \overbrace { \rho (q_{sat}(T_s) - q_{air}   )   } ^V  }
+
+\includegraphics[scale=0.5]{diffuco_schematic1.png}
+
+{\bf Figure 2:} resistance chain for canopy transpiration
+
+
+\vspace{1cm}
+
+{\bf Evaporation of the bare soil}
+
+$\beta_4$, the bare soil evaporation resistance, is defined as:
+
+
+\hspace{0.5cm} \lefteqn{E=\beta_{4} E_{pot}}
+
+\hspace{0.5cm} \lefteqn{\beta_{4} = \left(  \frac{1}{1+\frac{r_1}{r_a}}  \right) U_{s_1} }
+
+{\it where E represents the evapotranspiration, $U_{S_1}$ is the relative humidity in equilibrium with the bare soil, $r_{1}$ is the resistance of bare soil to evaporation and $r_a$ is the aerodynamic resistance. }
+
+so we can again convert the expression to the resistance analogy:
+
+ \hspace{0.5cm}  \lefteqn{\frac{E}{\beta_{4}} = \frac{\rho}{r_a}(q_{sat}(T_s)-q_{air})}
+
+ \hspace{0.5cm} \lefteqn{E\left( 1+   \frac{r_1}{r_a}   \right) U_{s_1} = \frac{\rho}{r_a}(q_{sat}(T_s) - q_{air})}
+
+ \hspace{0.5cm} \lefteqn{   \overbrace {E}^I    \overbrace  {(r_a + r_1)U_{s_1}}^R = \overbrace {\rho (q_{sat}(T_s) - q_{air}   )} ^V }
+
+
+\includegraphics[scale=0.45]{diffuco_schematic3.png}
+
+{\bf Figure 3:} resistance chain for bare soil evaporation
+
+% 
+% 
+% 
+% \end{document}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_symbols.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_symbols.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_symbols.tex	(revision 7236)
@@ -0,0 +1,122 @@
+
+\documentclass[11pt]{amsart}
+\usepackage{helvet}
+\usepackage{geometry}    
+\geometry{a4paper} 
+\usepackage[parfill]{parskip}  \usepackage{graphicx}
+\usepackage{amssymb}
+\usepackage{epstopdf}
+
+
+
+\begin{document}
+
+\renewcommand{\arraystretch}{1.5}
+
+\begin{tabular}{|c|l|r|}
+\hline
+  \bf {symbol} & \bf {variable name} & \bf {description} \\
+\hline
+ $ps^{old}$ & psold & surface static energy at old timestep (J/kg) \\
+ $ps^{new}$ & psnew & surface static energy at new timestep (J/kg)\\
+ $q_s$ & qsurf & surface specific humidity (kg/kg) \\
+ $q_{s, sat}$ & qsol\_sat & saturated surface humidity (kg/kg) \\
+ $q_{air}$ & qair & lowest level specific humidity at 'old' timestep (kg/kg) \\
+ $q_{air}^{new}$ & qair\_new & lowest level specific humidity at 'new' timestep (kg/kg) \\
+ $\frac{\delta q_s^{old}}{\delta t}$ & pdqsold & derivative of saturated specific humidity at old temperature (kg/(kg s)) \\ 
+ $p_l$ & pb & lowest level air pressure (Pa) \\
+ \hline
+ $C_p^{air}$ & cp\_air & lowest level atmospheric heat capacity (J/(K kg)) \\   
+ \hline
+ $\chi_{CO_2}^{canopy}$ & ccanopy & $CO_2$ concentration in the canopy (?? ppm)  \\
+ $\bar{Ci}$ & cimean & mean intercellular ci (from STOMATE) $(\mu mole/m^2/s)$\\  
+ \hline
+ $R^{LW}_{\uparrow}$ & lwup & long-wave upwelling radiation $(W/m^2)$ \\  
+ $ R^{LW}_{\downarrow}$ & lwdown & downwelling long-wave radiation flux $(W/m^2)$ \\
+ $R^{LW}_{abs}$ & lwabs  & LW radiation absorbed by the surface $(W/m^2)$ \\ 
+ $R^{SW}_{net}$ & swnet & net shortwave radiation flux $(W/m^2)$ \\
+ $R^{net}_{sns}$ & netrad\_sns & sensitivity of net radiation $(W/m^2)$ \\
+ $R_{net}$ & netrad & net radiation at surface layer $(W/m^2)$ \\
+ \hline
+ $\Delta \theta$ & dtradia & Time step (s) \\
+ $\epsilon$ & emis & emissivity (fraction) \\
+ $\sigma$ & c\_stefan & Stefan-Boltzmann constant $(W / (m^2 K^4))$\\
+ $q_{c}$ & q\_cdrag & surface drag coefficient (m/s) \\
+ $\rho_{air}$ & rau & density of air $(kg/m^3)$ \\
+\hline
+\end{tabular}
+
+
+\begin{tabular}{|c|l|r|}
+
+\hline
+  \bf {symbol} & \bf {variable name} & \bf {description} \\
+
+
+ \hline
+ 
+ $z_0$     &  z0 & Surface roughness Length (m) \\
+ roughheight  & roughheight   & Effective roughness height (m) \\
+ zlev  &  zlev & Height of first atmospheric layer (m) \\
+ veget\_max  & veget\_max & Fraction of vegetation type (-) \\
+ temp\_sol & temp\_sol &  Ground temperature (K) \\
+ temp\_air & temp\_air  &     !! Lowest level temperature (K) \\
+ qsurf  & qsurf & near surface specific air humidity (kg/kg) \\
+ qair  & qair & Lowest level specific air humidity (kg/kg) \\
+ 
+ \hline
+ 
+ veget    & veget & vegetation fraction for each type (fraction) \\
+ qsintveg & qsintveg & Water on vegetation due to interception $(kg/m^2)$ \\
+ qsintmax & qsintmax & Maximum water on vegetation $(kg/m^2)$ \\
+ rstruct  & rstruct & architectural resistance (s/m) \\
+ humrel & humrel & Soil moisture stress (within range 0 to 1 \\
+ veget  & veget & Type of vegetation (-) \\
+ veget\_max  & veget\_max &  Max. vegetation fraction (LAI to infinity) (fraction) \\
+ lai  & lai & Leaf\ area\ index $(m^2/m^2)$ \\
+ qsintveg & qsintveg & Water on vegetation due to interception $(kg/m^2)$ \\
+ 
+ \hline
+ 
+ $r_a$    & raero & aerodynamic resistance (s/m) \\
+ $r_{soil}$    & rsol & bare soil evaporation resistance (s/m) \\
+ $\delta _c$ & zdefconc & water vapour concentration deficit $(kg/m^3)$\\
+ \hline
+  
+\end{tabular}
+
+
+
+\begin{tabular}{|c|l|r|}
+\hline
+  \bf {symbol} & \bf {variable name} & \bf {description} \\
+
+
+ \hline
+ $T_{air}$ & tair & air temperature (K) \\
+ $T_{dgnc}^{2m}$ & t2mdiag & diagnostic temperature at 2m above ground (K) \\  
+ $T^{2m}$ & t2m & 2m air temperature (K) \\  
+ $q^{2m}$ & q2m & 2m specific humidity (kg/kg) \\  
+ $T_S$ & temp\_sol & surface temperature (K) \\  
+ \hline
+
+ $\alpha_v $ & valpha & total $\alpha$ resistance coefficient (fraction) \\
+ $\beta_v$ & vbeta & total resistance coefficient (fraction) \\
+ $\beta_{v1}$ & vbeta1 & snow resistance (fraction) \\  
+ $\beta_{v2}$ & vbeta2 & interception resistance (fraction)\\  
+ $\beta_{v3}$ & vbeta3 & vegetation resistance (fraction)\\  
+ $\beta_{v4}$ & vbeta4 & bare soil resistance (fraction)\\
+ $\beta_{v23}$ & vbeta23 & portion of wetted foliage that will transpire (fraction)\\ 
+ $\beta_{v,CO_2}$ & vbetaco2 & vegetation resistance to $CO_2$ \\ 
+ \hline
+ $U$ & speed & lowest level wind speed (m/s) \\
+ $u$ & u & lowest level wind velocity,  Eastward component  (m/s) \\
+ $v$ & v & lowest level wind volocity, Northward component  (m/s) \\
+ \hline
+ $z_{ikt}$ & zikt & aerodynamic resistance / density of air (kg s $m^{-4}$) \\
+ $z_{ikq}$ & zikq & aerodynamic resistance / density of air (kg s $m^{-4}$)  \\
+\hline
+\end{tabular}
+
+
+\end{document}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_1.1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_1.1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_1.1.tex	(revision 7236)
@@ -0,0 +1,15 @@
+% \documentclass{article}
+% \usepackage[english]{babel}
+% \usepackage{amsmath}
+% \newcommand[1]{{\mathversion{normal}$#1$}}
+% \begin{document}
+The integration at the canopy level is done over nlai=20 fixed levels $l$.
+
+nlai is a local constant of the diffuco module.
+
+laimax is a local constant of the diffuco\_trans\_co2 subroutine independent of the PFT equal to 12. 
+
+\begin{equation}
+{{{LAI}}(l)={{lai}}{max}\frac{e^{{0{.}{15}\cdot (l-1)}}-1}{e^{{0{.}{15}\cdot {{nlai}}}}-1}}\nonumber
+\end{equation}
+% \end{document}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_1.2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_1.2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_1.2.tex	(revision 7236)
@@ -0,0 +1,9 @@
+% \documentclass[onecolumn,a4paper]{article}
+% \usepackage[english]{babel}
+% \usepackage{amsmath}
+% \newcommand[1]{{\mathversion{normal}$#1$}}
+% \begin{document}
+\begin{equation}
+{{{light}}=e^{{-k\cdot {{LAI}}(l)}}}\nonumber
+\end{equation}
+% \end{document}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_1.3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_1.3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_1.3.tex	(revision 7236)
@@ -0,0 +1,17 @@
+% \documentclass{article}
+% \usepackage[english]{babel}
+% \usepackage{amsmath}
+% \newcommand[1]{{\mathversion{normal}$#1$}}
+% \begin{document}
+$Q$ surface specific humidity
+
+$Q_{sat}$ saturated surface humidity (calculated in constant\_veg:qsatcalc)
+
+$P$ surface pressure
+
+$h_r$ relative humidity of air
+
+\begin{equation}
+{h_{{r}}=\frac{Q\cdot P/{(0{.}{622}+0{.}{378}\cdot Q)}}{Q_{{{{sat}}}}\cdot P/{(0{.}{622}+0{.}{378}\cdot Q_{{{{sat}}}})}}}
+\end{equation}
+% \end{document}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.1.tex	(revision 7236)
@@ -0,0 +1,12 @@
+% \documentclass{article}
+% \usepackage[english]{babel}
+% \usepackage{amsmath}
+% \newcommand[1]{{\mathversion{normal}$#1$}}
+% \begin{document}
+$f_w$ soil relative humidity calculated in hydrolc:hydrolc\_soil
+
+$W_{lim}$ soil water limitation factor
+\begin{equation}
+{W_{{{lim}}}={{MIN}}(2f_{{w}},1)}\nonumber
+\end{equation}
+% \end{document}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.2.tex	(revision 7236)
@@ -0,0 +1,24 @@
+% \documentclass[onecolumn,a4paper]{article}
+% \usepackage[english]{babel}
+% \usepackage{amsmath}
+% \newcommand[1]{{\mathversion{normal}$#1$}}
+% \begin{document}
+$T_0$ (tp\_00) = 273.15 0 degree Celsius expressed in degree Kelvin defined in constantes.f90
+
+$k_T$ temperature-dependent pseudo-first-order rate constant of assimilation response to CO2
+
+\begin{equation}
+{k_{{T}}=0{.}7\cdot 0{.}{177}\cdot e^{{0{.}{069}\cdot (T_{{{{air}}}}-T_{{0}})}}\cdot {10}^{6}}\nonumber
+\end{equation}
+
+$R_T$ temperature-dependent non-photosynthetic respiration
+
+\begin{equation}
+{R_{{T}}=0{.}8\cdot {\frac{0{.}{177}\cdot e^{{0{.}{069}\cdot (T_{{{{air}}}}-T_{{0}})}}}{(1+e^{1{.}3(T_{{{{air}}}}-T_{{{max}}})}{)}}}}\nonumber
+\end{equation}
+
+\begin{equation}
+{V_{{c}}=V_{{c{max}}}\cdot 0{.}{39}\frac{0{.}{177}\cdot e^{{0{.}{069}\cdot (T_{{{{air}}}}-T_{{0}})}}}{(1+e^{0{.}3\cdot (T_{{{min}}}-T_{{{{air}}}})}{)(1+e^{0{.}3\cdot (T_{{{{air}}}}-T_{{{{opt}}}})}}{)}}W_{{lim}}}\nonumber
+\end{equation}
+
+% \end{document}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.3.tex	(revision 7236)
@@ -0,0 +1,26 @@
+Tlim temperature limitation factor
+
+\begin{equation}
+{T_{{{lim}}}=\frac{(T_{{{{air}}}}-T_{{{min}}})\cdot (T_{{{{air}}}}-T_{{{max}}})}{(T_{{{{air}}}}-T_{{{min}}})\cdot (T_{{{{air}}}}-T_{{{max}}})-(T_{{{{air}}}}-T_{{{{opt}}}})^{{2}}}}
+\end{equation}
+Tmin, Tmax and Topt are local variables that are initialized through the assim\_param array.
+
+Kc Michaelis-Menten constant for the rubisco enzyme catalytic activity for CO2 (ppm)
+
+\begin{equation}
+{K_{{c}}={39}{.}{09}\cdot e^{{0{.}{085}\cdot (T_{{{{air}}}}-T_{{0}})}}}
+\end{equation}
+Ko Michaelis-Menten constant for the rubisco enzyme catalytic activity for O2 (ppm)
+
+\begin{equation}
+{K_{{o}}=\frac{2{.}{412}\cdot {210000}\cdot e^{{0{.}{085}\cdot (T_{{{{air}}}}-T_{{{min}}})}}}{(T_{{{air}}}{-T_{{min}}}{)}}}
+\end{equation}
+\begin{equation}
+{\Gamma ^{{?}}={42}\cdot e^{{9{.}{46}\frac{T_{{{{air}}}}-T_{{0}}-{25}}{T_{{{{air}}}}}}}}
+\end{equation}
+\begin{equation}
+{V_{{c}}=V_{{c{max}}}\cdot T_{{{lim}}}\cdot W_{{{lim}}}}
+\end{equation}
+\begin{equation}
+{V_{{j}}=V_{{j{max}}}\cdot T_{{{lim}}}\cdot W_{{{lim}}}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.4.1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.4.1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.4.1.tex	(revision 7236)
@@ -0,0 +1,6 @@
+\begin{equation}
+{V_{{c}}(l)=V_{{c}}\cdot (1-0.7\cdot (1-e^{{-k\cdot LAI(l)}}))}
+\end{equation}
+\begin{equation}
+{V_{{j}}(l)=V_{{j}}\cdot (1-0.7\cdot (1-e^{{-k\cdot LAI(l)}}))}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.4.2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.4.2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.4.2.tex	(revision 7236)
@@ -0,0 +1,36 @@
+The photosynthesis is defined by a pair of nested quadratic equations:
+
+M flux determined by the Rubisco and light limited capacities
+
+${\Phi}$ fixed equal to 0.83
+
+${\beta}$ fixed equal to 0.93
+
+M smaller root of
+
+\begin{equation}
+{\Phi \cdot M^{{2}}-M\cdot (V_{{c}}(l)+\alpha \cdot Q)+V_{{c}}(l)\cdot \alpha \cdot Q=0}
+\end{equation}
+Ci(l) (leaf\_ci) global variable declared in diffuco module
+
+W smaller root of
+
+\begin{equation}
+{\beta \cdot W^{{2}}-W\cdot (M+k_{{T}}\cdot C_{{i}}(l)\cdot {10}^{{-6}})+M\cdot k_{{T}}\cdot C_{{i}}(l)\cdot {10}^{{-6}}=0}
+\end{equation}
+${\alpha}$ quantum efficiency
+
+\begin{equation}
+{\alpha \cdot Q=0{.}{092}\cdot 2{.}3\cdot {{SWdown}}\cdot k\cdot e^{{-k\cdot {{LAI}}(l)}}}
+\end{equation}
+
+\begin{equation}
+{M=\frac{V_{{c}}(l)+\alpha \cdot Q-\sqrt{(V_{{c}}(l)+\alpha \cdot Q)^{{2}}-4\cdot \Phi \cdot V_{{c}}(l)\cdot \alpha \cdot Q}}{2\cdot \Phi }}
+\end{equation}
+
+\begin{equation}
+{W=\frac{M+k_{{T}}\cdot C_{{i}}(l){.}{10}^{{-6}}-\sqrt{(M+k_{{T}}\cdot C_{{i}}(l){.}{10}^{{-6}})^{{2}}-4\cdot \beta \cdot M\cdot k_{{T}}\cdot C_{{i}}(l){.}{10}^{{-6}}}}{2\cdot \beta }}
+\end{equation}
+\begin{equation}
+{A=W-R_{{T}}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.4.3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.4.3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.4.3.tex	(revision 7236)
@@ -0,0 +1,43 @@
+Wc rubisco-limited carboxylation rate
+
+Oi partial pressure of O2 (fixed to 210000 ppm)
+
+\begin{equation}
+{W_{{c}}=\frac{V_{{c}}(l)\cdot C_{{i}}(l)}{C_{{i}}(l)+K_{{c}}\cdot (1+O_{{i}}/{K_{{o}}})}}
+\end{equation}
+Vj potential rate of RuBP regeneration
+
+I incident photon flux
+
+${\alpha}$j quantum yield of RuBP regeneration 
+
+\begin{equation}
+{\alpha_{{j}}\cdot I=0{.}{8855}\cdot {{SW}}_{{{{down}}}}\cdot k\cdot e^{{-k\cdot {{LAI}}(l)}}}
+\end{equation}
+${\Theta}$ curvature of the quantum response (fixed equal to 0.7)
+
+\begin{equation}
+{V_{{j}}=\frac{\alpha_{{j}}\cdot I+V_{{j}}(l)-\sqrt{(\alpha_{{j}}\cdot I+V_{{j}}(l))^{{2}}-4\cdot \Theta \cdot \alpha_{{j}}\cdot I\cdot V_{{j}}(l)}}{2\cdot \Theta }}
+\end{equation}
+Wj RuBP regeneration-limited rate
+
+${\Gamma}$* CO2 compensation point (ppm)
+
+\begin{equation}
+{W_{{j}}=\frac{V_{{j}}\cdot C_{{i}}(l)}{4{.}5\cdot C_{{i}}(l)+{10}{.}5\cdot \Gamma ^{{?}}}}
+\end{equation}
+
+\begin{equation}
+{W={{MIN}}(W_{{c}},W_{{j}})}
+\end{equation}
+
+Rd dark respiration
+
+fdr fraction of dark respiration (fixed equal to 0.011)
+
+\begin{equation}
+{R_{{d}}=f_{{{{dr}}}}\cdot V_{{c}}(l)}
+\end{equation}
+\begin{equation}
+{A=W\cdot \left(1-\frac{\Gamma ^{{?}}}{C_{{i}}(l)}\right)-R_{{d}}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.4.4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.4.4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.4.4.tex	(revision 7236)
@@ -0,0 +1,4 @@
+\begin{equation}
+{g_{{s}}(l)={{mA}}(l)\frac{h_{{r}}}{C_{{a}}}+b}
+\end{equation}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.4.5.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.4.5.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffuco_trans_co2_2.4.5.tex	(revision 7236)
@@ -0,0 +1,7 @@
+\begin{equation}
+{A=A+A(l)\cdot({{LAI}}(l+1)-{{LAI}}(l))}
+\end{equation}
+\begin{equation}
+{g_{{s}}=g_{{s}}+g_{{s}}(l)\cdot({{LAI}}(l+1)-{{LAI}}(l))}
+\end{equation}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    U = U_{wind}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero10.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero10.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero10.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    zscf = \sqrt{(1 + cd |Ri_{z}|)}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero11.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero11.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero11.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+     cd_{tmp}=\frac {cd_{neut}}{1+3 c_b Ri_z zscf}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero12.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero12.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero12.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+     zscf = \frac {1}  {1+ 3 cc * cc * cd_{neut}  *\sqrt{|Ri_z| \frac{ (z_{lev}   +  roughheight) }  {z_0} }}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero13.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero13.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero13.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+     cd_{tmp} = cd_{neut} (1-3 cb* Ri_{z} * zscf)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero14.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero14.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero14.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+      q_{cdrag} = max   \left\{  cd_{tmp}, \frac{1 \times 10^{-4}}{max \left\{ U, (U_{wind})_{min} \right\} }  \right\}    
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    Z_g = Z_{lev} g_0
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero3.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    Z_d^\phi = \left( \frac{Z_g} {C_{p,air}} \right)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero4.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    T_{V, a, surf} = T_a + \frac {Z_d^\phi} {(1 + rv_{tmp2} q_{air})(1+retv q_{air}) }
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero5.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero5.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero5.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    T_{V, surf} = T_g (1 + retv q_{surf})
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero6.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero6.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero6.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \left( {\frac{\delta u}{\delta z}} \right) ^2 = max \{ (0.1)^2, U^2  \}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero7.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero7.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero7.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    Ri_{z} = z_g \frac {T_{V, a, surf}-T_{V, surf}}{\left( {\frac{\delta u}{\delta z}} \right) ^2  * T_{V, a, surf}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero8.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero8.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero8.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    Ri_{z} = max \{   min   \{Ri_z, 5    \}, -5  \}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero9.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero9.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaero9.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    cd_{neut} = \left(  \frac{  \kappa }  {\frac{LOG(zlev + roughheight)}{z_0} }               \right)^2
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaerod1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaerod1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaerod1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    U = max\{ (U_{wind})_{min}, U_{wind} \}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaerod2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaerod2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucoaerod2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    r_{a} = \frac{1}{q_{c,drag}U}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucobare1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucobare1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucobare1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    U = max\{ (U_{wind})_{min}, U_{wind} \}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucobare2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucobare2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucobare2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \beta_{v,4} \equiv  \left(  \frac{1}{1+\frac{r_1}{r_a}}  \right) U_{s_1} = \left( \frac{1}{1+ \frac {r_{soil}}{r_a}} \right) VEG
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucobare3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucobare3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucobare3.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \beta_{v,4} = evap_{bare, lim}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \sum_1^{nvm} (\beta_{v,2}); \  \sum_1^{nvm} (\beta_{v,3})   
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \beta_v = 1; \ \alpha_v = 1    
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb3.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \beta_v = \beta_{v,4} +  \sum_1^{nvm} (\beta_{v,2}) + \sum_1^{nvm} (\beta_{v,3})   
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb4.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \sum_1^{nvm} (veget); \  \sum_2^{nvm} (veget)   
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb5.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb5.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb5.tex	(revision 7236)
@@ -0,0 +1,4 @@
+\begin{eqnarray}
+    IF \ (q_{sat} < q_{air}) \ THEN \ (IF \ (T_a > 0) \ THEN \ toveg=TRUE, \ tosnow = FALSE ) \\
+    IF \ (q_{sat} < q_{air}) \ THEN \ (IF \ (T_a < 0) \ THEN \ toveg= FALSE, \ tosnow=TRUE )  
+\end{eqnarray}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb6.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb6.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb6.tex	(revision 7236)
@@ -0,0 +1,4 @@
+\begin{eqnarray}
+    IF \ (toveg) \ THEN: \ \beta_{v,1}=0, \ \beta_{v,4} = (veget), \ \beta_v = \beta_{v,4}, \ \alpha_v = 1 \\
+    IF \ (tosnow) \ THEN: \ \beta_{v,1}=1, \ \beta_{v,4} = 0, \ \beta_v =1, \ \alpha_v = 1       
+\end{eqnarray}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb7.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb7.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb7.tex	(revision 7236)
@@ -0,0 +1,4 @@
+\begin{eqnarray}
+    \chi^{dew, veg}= \chi^{d,v}_6(LAI)^5 - \chi^{d,v}_5(LAI)^4 + \chi^{d,v}_4(LAI)^3 
+    - \chi^{d,v}_3(LAI)^2 + \chi^{d,v}_2(LAI) + \chi^{d,v}_1
+\end{eqnarray}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb8.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb8.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb8.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{eqnarray}
+    \beta_{v,3} = 0; \ RH = 0     
+\end{eqnarray}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb9.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb9.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucocomb9.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{eqnarray}
+    \beta_{v,2} = 0       
+\end{eqnarray}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    zqs_{veg}^{rap} = max \left\{ 0, \left( \frac {qs_{int}^{veg} } { qs_{int}^{max} } \right) \right\}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    U = max\{ (U_{wind})_{min}, U_{wind} \}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer3.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \beta_{v,2} = VEG zqs_{veg}^{rap} \left( \frac{1}{1 + U q_{c,drag} r_{sv} }   \right) \equiv VEG zqs_{veg}^{rap} \left( \frac{1}{1 + \frac{r_{sv}}{r_a} }   \right)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer4.tex	(revision 7236)
@@ -0,0 +1,4 @@
+\begin{equation}
+    ziltest = \Delta t \beta_{v,2} U q_{c,drag} \rho (q_{sat}-q_{air}) \equiv \Delta t \beta_{v,2} E_{pot} 
+\end{equation}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer5.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer5.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer5.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    z_{rapp} = \frac{qs_{int}^{veg}}{ziltest}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer6.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer6.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer6.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \beta_{v,23} = max \left\{  \beta_{v,2} - \beta_{v,2}z_{rapp} , 0 \right\}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer7.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer7.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucointer7.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \beta_{v,2} = \beta_{v,2} z_{rapp}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \delta _c = \rho . max\{ (q_{sat} - q_{a}), 0 \}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    U = max\{ (U_{wind})_{min}, U_{wind} \}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans3.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    zqs_{veg}^{rap} = max \left\{ 0 , \frac{q_{s,int}^{veg}}{q_{s,int}^{max}}  \right\}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans4.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    r_{veg} = \left( \frac{1}{LAI} \right) \left( \frac{R_{SW}^{net} + {R}_{0}}{R_{SW}^{net}} \right) \left( \frac{a+ \lambda \delta_c}{k_0} \right) 
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans5.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans5.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans5.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \beta_{v3} = VEG (1 - zqs^{rap}_{veg} RH) \frac {1} {1 + \frac {r_{veg}^{pft} (r_{veg}^{et} + r_{sv})}{r_a} }
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans6.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans6.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/diffuco/diffucotrans6.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \beta_{v,3} = \beta_{v,3} + min \left\{ \beta_{v,23}, VEG zqs_{veg}^{rap} RH \frac {1} {1 + \frac{ r_{veg}^{pft} (r_{veg}^{et} + r_{sv}) }{r_a}} \right\}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbil_intro2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbil_intro2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbil_intro2.tex	(revision 7236)
@@ -0,0 +1,72 @@
+% 
+% \documentclass[11pt]{amsart}
+% \usepackage{helvet}
+% \usepackage{geometry}    
+% \geometry{a4paper} 
+% \usepackage[parfill]{parskip}  \usepackage{graphicx}
+% \usepackage{amssymb}
+% \usepackage{epstopdf}
+%
+%
+%
+% \begin{document}
+% 
+{\bf Introduction to the coupled energy budget scheme}
+ 
+The coupled energy balance scheme in ORCHIDEE is described most extensively in Dufresne \& Ghattas (2009) with further context in Best et al. (2004). The key principles are summarised here. 
+
+Figure 1 depicts how the surface layer model interacts with the atmospheric model. The model is depicted as running from left to right. The coefficients A, B, C and D are derived for each variable as a means to solve the diffusivity equation for the four state variables of windspeeds 'u' and 'v', temperature and specific humidity (we here concentrate on the latter two variables, denoted together in Figure 1 as 'X'). This diffusivity equation (with a counter-gradient term for the temperature and specific humidity versions) is differenced in such a way that it can be solved implicitly - i.e. the system is solved using information both from the system at the current time and in the next timestep (in an explicit scheme only information from the current time step is used).
+
+\includegraphics[scale=0.5]{iterative_diagram3.png}
+
+{\bf {Figure 1}: Simple schematic of coupling scheme}
+
+The end result is that the diffusivity equation in LMDZ is solved using an 'offset' varient of the Tri-Diagonal Matrix Algorithm. This differencing scheme is as described by Richtmyer et al. (1967). The scheme allows for terms of the equation to be solved in sequence, as depicted, starting from the top of the model. It takes place by deriving coefficients A, B, C, D for each layer in terms of the preceding, higher, layer on a 'downwards' sweep. ORCHIDEE assumes the place of the lower surface layer boundary condition, and provides the state variables for the lowest level of the atmospheric model. On the 'upwards' sweep, the state variables for each layer are calculated in terms of the respective coefficients and of the state variable from the preceding, lower layer.
+
+
+The key information is passed down from the atmospheric model to the surface model are the sensitivity coefficients $A_S, B_S, A_q$ and $B_q$ where, according to the lower boundary conditions of the atmospheric model, where the surface interaction takes place (Best et al., 2004):
+
+\begin{eqnarray}
+  S_1^{new} = A_S(H) + B_S \\
+  q_1^{new} = A_q(\lambda E) + B_q
+\end{eqnarray}
+
+$S^{new}_1$ is the lowest atmospheric model dry static energy and $q^{new}_1$ is the lowest atmospheric model specific humidity, both for the 'new' time step. The A, B, C and D coefficients (which are recalculated for every time step) are a function of the state variables from the old last time step (specific humidity and surface static energy), as well as an intermediate variable (S) that includes the diffusivity coefficient (k), the atmospheric pressure at the height (P) and a 'counter-gradient term' ($\gamma$). The B coefficient is also a function of P, S and g. As part of the differencing scheme, each coefficient A,B,C and D is also a function of the coefficient above, so they are calculated by 'working down' the column, as depicted.
+
+Now, although the coefficients A and B in equations (1) and (2) are known quantities, $S^{new}$, $q^{new}$, H and $\lambda E$ are not.
+
+In order to determine these quantities, we need to make use of a further set of assumptions:
+
+a) We assume that surface fluxes for a given timestep are written as below (shown here for the 'new' timestep):
+\begin{eqnarray}
+   H = k_1^h (S_1^{new}-S_s^{new}) \\
+   \lambda E =\beta k_1^q (q_1^{new} - q_s ^{new}) =\beta k_1^q (q_1^{new} - q_0 ^{new} (T_s^{new}))
+\end{eqnarray}
+
+These equations are implicit because they have been formulated for the 'new' timestep. $q_0^{new}$ is the saturated humidity that corresponds to the surface temperature $T_s^{new}$. We make the saturated humidity assumption: i.e. the air within cavities in the surface vegetation is completely saturated. This means that the vapour pressure of the vegetation may be calculated as the saturated vapour pressure at the vegetation temperature.
+
+b) We assume, by first-order Taylor series expansion, that:
+
+\begin{eqnarray}
+    q_0(T_s^{new}) = q_{sat}(T_s^{old}) + \frac {\delta q_{sat}} {\delta T}|_{T_t} (T^{new}_s - T^{old}_s)
+\end{eqnarray}
+
+c) We assume that the energy budget is obeyed over the timestep $\Delta t$ such that a change in the balance of fluxes for the surface layer corresponds exactly to the change in surface temperature:
+
+\begin{eqnarray}
+   T_s^{new}=T^{old}_s + \frac{\delta t}{C_0} \sum F
+\end{eqnarray}
+
+where:
+
+\begin{eqnarray}
+    \sum F = H + \lambda E + R_{LW} + R_{SW} + F_G
+\end{eqnarray}
+
+Combining this set of equations, as is conducted by Dufresne \& Ghattas (2009) results in the sequence of operations that is carried out in the 'enerbil' module, and is outlined below.
+
+%
+%
+%
+%
+% \end{document}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbil_symbols.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbil_symbols.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbil_symbols.tex	(revision 7236)
@@ -0,0 +1,135 @@
+%
+% \documentclass[11pt]{amsart}
+% \usepackage{helvet}
+% \usepackage{geometry}    
+% \geometry{a4paper} 
+% \usepackage[parfill]{parskip}  \usepackage{graphicx}
+% \usepackage{amssymb}
+% \usepackage{epstopdf}
+%
+%
+%
+% \begin{document}
+
+\renewcommand{\arraystretch}{1.5}
+
+\begin{tabular}{|c|l|r|}
+\hline
+  \bf {symbol} & \bf {variable name} & \bf {description} \\
+\hline
+ $ps^{old}$ & psold & surface static energy at old timestep (J/kg) \\
+ $ps^{new}$ & psnew & surface static energy at new timestep (J/kg)\\
+ $q_s$ & qsurf & surface specific humidity (kg/kg) \\
+ $q_{s, sat}$ & qsol\_sat & saturated surface humidity (kg/kg) \\
+ $q_{air}$ & qair & lowest level specific humidity at 'old' timestep (kg/kg) \\
+ $q_{air}^{new}$ & qair\_new & lowest level specific humidity at 'new' timestep (kg/kg) \\
+ $\frac{\delta q_s^{old}}{\delta t}$ & pdqsold & derivative of saturated specific humidity at old temperature (kg/(kg s)) \\ 
+ $p_l$ & pb & lowest level air pressure (Pa) \\
+ \hline
+ $C_p^{air}$ & cp\_air & lowest level atmospheric heat capacity (J/(K kg)) \\   
+ \hline
+ $\chi_{CO_2}^{canopy}$ & ccanopy & $CO_2$ concentration in the canopy (?? ppm)  \\
+ $\bar{Ci}$ & cimean & mean intercellular ci (from STOMATE) $(\mu mole/m^2/s)$\\  
+ \hline
+ $R^{LW}_{\uparrow}$ & lwup & long-wave upwelling radiation $(W/m^2)$ \\  
+ $ R^{LW}_{\downarrow}$ & lwdown & downwelling long-wave radiation flux $(W/m^2)$ \\
+ $R^{LW}_{abs}$ & lwabs  & LW radiation absorbed by the surface $(W/m^2)$ \\ 
+ $R^{SW}_{net}$ & swnet & net shortwave radiation flux $(W/m^2)$ \\
+ $R^{net}_{sns}$ & netrad\_sns & sensitivity of net radiation $(W/m^2)$ \\
+ $R_{net}$ & netrad & net radiation at surface layer $(W/m^2)$ \\
+ \hline
+ $\Delta \theta$ & dtradia & Time step (s) \\
+ $\epsilon$ & emis & emissivity (fraction) \\
+ $\sigma$ & c\_stefan & Stefan-Boltzmann constant $(W / (m^2 K^4))$\\
+ $q_{c}$ & q\_cdrag & surface drag coefficient (m/s) \\
+ $\rho_{air}$ & rau & density of air $(kg/m^3)$ \\
+\hline
+\end{tabular}
+
+
+\begin{tabular}{|c|l|r|}
+
+\hline
+  \bf {symbol} & \bf {variable name} & \bf {description} \\
+
+\hline
+
+ $\lambda E_{evap}^0$ & chalev0 & latent heat of evaporation (J/kg) \\
+ $\lambda E_{sub}^0$ & chalsu0 & latent heat of sublimination (J/kg) \\ 
+ $\lambda E_{fsn}^0$ & chalfu0 & latent heat of fusion (J/kg) \\
+
+ $H^{old}$ & sensfl\_old & sensible heat flux at 'old' timestep $(W/m^2)$ \\ 
+ $H^{sns}$ & sensfl\_sns & sensitivity of sensible heat flux $(W/m^2)$\\
+ $H^{new}$ & fluxsens & sensible heat flux at 'new' timestep $(W/m^2)$\\
+
+ ${\lambda E}_{evap}^{old}$ & lareva\_old  & evaporation latent heat flux at old timestep $(W/m^2)$ \\
+ ${\lambda E}_{evap}^{sns}$ & lareva\_sns  & sensitivity of latent heat flux $(W/m^2)$ \\
+  ${\lambda E}_{evap}^{new}$ & fluxsens  & sensitivity of latent heat flux at 'new' time step $(W/m^2)$ \\
+
+ $\lambda E_{sub}^{old}$ & larsub\_old & sublimation latent heat flux at 'old' time step $(W/m^2)$ \\
+ $\lambda E^{sns}_{sub}$ & larsub\_sns & sensitivity of sublimination latent heat flux $(W/m^2)$ \\
+ $\lambda E_{new}^{sub}$ & fluxsubli & sens. of subn. latent heat flux at 'new' time step $(W/m^2)$ \\
+
+ $\Sigma (\lambda E^{old})$ & sum\_old & total latent heat flux at 'old' time step $(W/m^2)$\\
+
+ $\Sigma (\lambda E^{sns})$ & sum\_sns & total latent heat flux sensitivity at 'old' time step $(W/m^2)$\\
+ $E_{pot}^{air,new}$ & epot\_air & air potential energy (?? J) \\
+
+ $G$ & soilflx & sensible heat flux from soil $(W/m^2)$ \\
+
+ \hline
+
+ $E^{snow}$ & vevapsno & snow evaporation (mm/day)\\  
+ $E^{soil}$ & vevapnu & bare soil evaporation  (mm/day)\\ 
+ 
+  $(melt)_{tot}$ & tot\_melt & total melt \\  
+ $vev_{app}$ & vevapp & total of evaporation (mm/d) \\  
+ 
+
+ 
+\hline
+\end{tabular}
+
+
+
+\begin{tabular}{|c|l|r|}
+\hline
+  \bf {symbol} & \bf {variable name} & \bf {description} \\
+
+ \hline
+
+ $A_q^{orc}$ & peqAcoef & ORCHIDEE humidity coefficient 'A' \\
+ $B_q^{orc}$ & peqBcoef & ORCHIDEE humidity coefficient 'B'\\
+ $A_T^{orc}$  &  petAcoef & ORCHIDEE temperature coefficient 'A' \\
+ $B_T^{orc} $ & petBcoef & ORCHIDEE temperature coefficient 'B' \\    
+ $A_q^{lmdz}$ & ... & LMDZ humidity coefficient 'A' \\  
+ $B_T^{lmdz}$ & ... & LMDZ temperature coefficient 'A' \\  
+ $B_q^{lmdz}$ & ... & LMDZ humidity coefficient 'B' \\  
+ $B_T^{lmdz}$ & ... & LMDZ temperature coefficient 'B' \\  
+ \hline
+ $T_{air}$ & tair & air temperature (K) \\
+ $T_{dgnc}^{2m}$ & t2mdiag & diagnostic temperature at 2m above ground (K) \\  
+ $T_S$ & temp\_sol & surface temperature (K) \\  
+ \hline
+
+ $\alpha_v $ & valpha & total $\alpha$ resistance coefficient (fraction) \\
+ $\beta_v$ & vbeta & total resistance coefficient (fraction) \\
+ $\beta_{v1}$ & vbeta1 & snow resistance (fraction) \\  
+ $\beta_{v2}$ & vbeta2 & interception resistance (fraction)\\  
+ $\beta_{v3}$ & vbeta3 & vegetation resistance (fraction)\\  
+ $\beta_{v4}$ & vbeta4 & bare soil resistance (fraction)\\
+ $\beta_{v,CO_2}$ & vbetaco2 & vegetation resistance to $CO_2$ \\ 
+ \hline
+ $U$ & speed & lowest level wind speed (m/s) \\
+ $u$ & u & lowest level wind velocity,  Eastward component  (m/s) \\
+ $v$ & v & lowest level wind volocity, Northward component  (m/s) \\
+ \hline
+ $z_{ikt}$ & zikt & aerodynamic resistance / density of air (kg s $m^{-4}$) \\
+ $z_{ikq}$ & zikq & aerodynamic resistance / density of air (kg s $m^{-4}$)  \\
+\hline
+\end{tabular}
+
+%
+%
+%
+%\end{document}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilbegin1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilbegin1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilbegin1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    ps^{old} = T_S C_p
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilbegin2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilbegin2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilbegin2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \frac{\delta q_s^{old}}{\delta t} = \delta q_s \frac{(p_l)^\kappa}{C_p^{air}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilbegin3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilbegin3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilbegin3.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    R^{LW}_{abs} = \epsilon R^{LW}_{\downarrow}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilbegin4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilbegin4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilbegin4.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    R_{net} = R^{LW}_{\downarrow} + S^{SW}_{net} - \epsilon \sigma T^4 (1-\epsilon) R^{LW}_{\downarrow}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    U = max\{U_{min}, \sqrt{u^2 + v^2} \}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   E^{snow} = \beta_{v1} \Delta t \rho U q_c^{drag} (q_{sol,s}^{new}- q_{air})
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg3.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   E^{soil} = (1-\beta_{v1})\beta_{v4} \Delta t \rho U q_c^{drag} (q_{sol,s}^{new} - q_{air})
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg4.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    U = max\{U_{min}, \sqrt{u^2 + v^2} \}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg5.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg5.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg5.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   xx = \Delta t (1-\beta_{v1}) (q_{s,sat}^{new} - q_{a}) \rho S q_c^{drag}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg6.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg6.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg6.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   (Interception) = xx \beta_{v2}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg7.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg7.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg7.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   (Transpiration) = xx \beta_{v3}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg8.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg8.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg8.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   U = max \{U_{min}, \sqrt{u^2 + v^2} \}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg9.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg9.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilevapveg9.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   (Assimilation) = \beta_{v,CO_2} \Delta t \rho S q_c^{drag} (\chi_{CO_2}^{canopy} - \bar{Ci})
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    U=max\{U_{min}, \sqrt{u^2+v^2} \}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux10.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux10.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux10.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   H=\lambda E_0^{sub}(\rho)q_c(\beta_{v,1})(q_{s,sat}^{new}-q_{air}+\lambda E_0^{evap}(\rho)q_c(1-\beta_{v,1})\beta_v(\alpha_v)q_{s,sat}^{new}-q_{air})
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux11.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux11.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux11.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   \lambda E^{sub}=\lambda E_0^{sub} (\rho)q_c\beta_{v,1}(q_{s,sat}^{new}-q_{air})
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux12.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux12.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux12.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    H = \rho q_c (ps^{new}- E^{pot}_{air})
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux13.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux13.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux13.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   R^{LW}_{net} = R^{LW}_{\downarrow}-R^{LW}_{\uparrow}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux14.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux14.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux14.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   E^{pot}_{air} = max \{0, \Delta t \rho q_c (q_{s,sat}^{new} -q_{air}) \}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux15.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux15.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux15.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   T_{air}= \frac{E^{pot}_{air}}{c_{p, air}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    q_c=|v|q_{c, drag}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux3.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    R^{LW}_{\uparrow}=\epsilon \sigma T_{sol}^4+\epsilon 4 \sigma T_{sol}^3(T_{s}^{new}-T_{s})
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux4.tex	(revision 7236)
@@ -0,0 +1,4 @@
+\begin{equation}
+    R^{LW}_{\uparrow}=R^{LW}_{\uparrow}+(1-\epsilon)R^{LW}_{\downarrow}
+\end{equation}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux5.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux5.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux5.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    T_{s}^{rad}=\epsilon \sigma T_{s}^4 + R^{LW}_{\uparrow}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux6.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux6.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux6.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    q_{surf}=\beta_{v,1} (q_{s,sat}^{new})+(1-\beta_{v,1})\beta_v\alpha_v(q_{s,sat}^{new})
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux7.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux7.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux7.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    q_s = max \{q_s, q_{air} \}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux8.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux8.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux8.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    R_{net}=R^{LW}_{\downarrow}+R^{SW}_{net}-R^{LW}_{\uparrow}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux9.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux9.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilflux9.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    vev_{app} = \Delta t (\rho)q_c \beta_{v,1}(q_{s,sat}^{new}-q_{air})+\Delta t(\rho)q_c(1-\beta_{1,v}\beta_v(\alpha_v)q_{s,sat}^{new}-q_{air})
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilfusion1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilfusion1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilfusion1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    (fusion) = (melt)_{tot} \frac {\lambda E_{sub}^0}{\Delta t}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilfusion2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilfusion2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilfusion2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    T_{s}^{new} = T_{s}^{new} - \frac {(melt)_{tot} \lambda E_{sub}^0}{(soilcap)}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    U = max \{ U_{min}, \sqrt{u^2 + v^2} \}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp10.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp10.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp10.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \Sigma E^{old} = R_{net} + H^{old} + {\lambda E}_{sub}^{old} + {\lambda E}_{evap}^{old} + G
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp11.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp11.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp11.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \Sigma E^{sns} = R^{sns} + H^{sns} + {\lambda E}_{sub}^{sns} + {\lambda E}_{evap}^{sns} + G
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp12.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp12.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp12.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \Delta \theta = \frac {\Delta t (\Sigma E^{old})} {\left( \frac {1}{C_p^{air}} (C_p^{soil} + \Delta T) (\Sigma E^{sns}) \right)}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp13.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp13.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp13.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    ps^{new} = ps^{old} + \Delta \theta
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp14.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp14.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp14.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    q_{s,sat}^{new} = q_{s,sat} + \left( \left( \frac{1}{C_p^{air}} \right) \left( \frac{\delta q_s^{old}}{\delta t} \right) \delta\theta \right)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp15.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp15.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp15.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    T_{s}^{new} = \frac {ps^{new}}{C_p^{air}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp16.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp16.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp16.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    E_{pot}^{air,new} = z_{ikt} (H^{old} - H^{sns} \Delta \theta) + ps^{new}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp17.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp17.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp17.tex	(revision 7236)
@@ -0,0 +1,4 @@
+\begin{equation}
+    {\lambda E} ^{evap} = ({\lambda E}_{evap}^{old} - {\lambda E} _{evap} ^{sns} \Delta \theta) + ({\lambda E}_{sub}^{old} - {\lambda E}_{sub}^{sns} \Delta \theta)
+\end{equation}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp18.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp18.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp18.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    q_{air}^{new}(ji) = q_{air}(ji)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp19.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp19.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp19.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   q_{air}^{new} = z_{ikq} \frac {1} {(\lambda E^{evap}_0  (1 - \beta_{v1}) \beta_1 \alpha_v + \lambda E^{sub}_0 \beta_{v1})} {\lambda E} ^{evap} + q_{s,sat}^{new} 
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    z_{ikt}=\frac{1}{\rho_{air} U q_{c}}; \quad z_{ikq}=\frac{1}{\rho_{air} U q_{c}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp3.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    H^{old} = \frac{B_T^{orc} - ps^{old}}{z_{ikt} - A_T^{orc}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp4.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \lambda E _{sub}^{old} = \lambda E_{sub}^0 \frac{B_q^{orc} - q_{s, sat}}{z_{ikq}-A_q^{orc}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp5.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp5.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp5.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \lambda E _{evap}^{old} = \lambda E_{evap}^0  \left( 1-\beta_{v1} \beta_v \left( \frac {  B_q^{orc} - \alpha_v q_{s, sat}  }{  z_{ikq} - A_q^{orc}  }  \right) \right)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp6.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp6.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp6.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    R^{net}_{sns} = \left( \frac{1}{C_p} \right) 4 \epsilon \sigma \left( \left( \frac{1}{C_p} \right) ps_{t} ^3 \right)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp7.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp7.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp7.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    H_{sns} = \frac{1} { \left( \frac{1}{\rho_{air} S q_{c}} - A_T^{orc} \right)}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp8.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp8.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp8.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \lambda E_{sns}^{sub} = \lambda E_{sub}^0 \beta_{v1} \frac{1}{C_p} \left( \frac{ ({\delta q_s^{t}}/{\delta t}) } {z_{ikq} - A_q^{orc} } \right)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp9.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp9.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilsurftemp9.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    \lambda E_{sns}^{evap} = \lambda E_{evap}^0 (1-\beta_{v1}) \beta_v \alpha_v \frac{1}{C_p} \left( \frac{ ({\delta q_s^{t}}/{\delta t}) } {z_{ikq} - A_q^{orc} } \right)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilt2mdiag1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilt2mdiag1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/enerbilt2mdiag1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    T_{dgnc}^{2m} = T_{air} 
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/equations_collated.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/equations_collated.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/equations_collated.tex	(revision 7236)
@@ -0,0 +1,392 @@
+\documentclass{article}
+\begin{document}
+
+
+{ \bf enerbil.f90 equations }
+
+\vspace {10mm}
+{ \bf enerbil\_begin }
+
+\vspace {10mm}
+enerbilbegin1.tex
+
+\begin{equation}
+    ps^{t} = T_S C_p
+\end{equation}
+
+\vspace {10mm}
+enerbilbegin2.tex
+
+\begin{equation}
+    \frac{\delta q_s^{t}}{\delta t} = \delta q_s \frac{(p_l)^\kappa}{C_p^{air}}
+\end{equation}
+
+\vspace {10mm}
+enerbilbegin3.tex
+
+\begin{equation}
+    R^{LW}_{abs} = \epsilon R^{LW}_{\downarrow}
+\end{equation}
+
+\vspace {10mm}
+enerbilbegin4.tex
+
+\begin{equation}
+    R_{net} = R^{LW}_{\downarrow} + S^{SW}_{net} - \epsilon \sigma T^4 (1-\epsilon) R^{LW}_{\downarrow}
+\end{equation}
+
+\vspace {10mm}
+{ \bf enerbil\_surftemp }
+
+\vspace {10mm}
+enerbilsurftemp1.tex
+
+\begin{equation}
+    U = max \{ U_{min}, \sqrt{u^2 + v^2} \}
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp2.tex
+
+\begin{equation}
+    z_{ikt}=\frac{1}{\rho_{air} U q_{c}}; \quad z_{ikq}=\frac{1}{\rho_{air} U q_{c}}
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp3.tex
+
+\begin{equation}
+    H^{t} = \frac{B_T^{orc} - ps^{t}}{z_{ikt} - A_T^{orc}}
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp4.tex
+
+\begin{equation}
+    \lambda E _{sub}^{t} = \lambda E_{sub}^0 \frac{B_q^{orc} - q_{s, sat}}{z_{ikq}-A_q^{orc}}
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp5.tex
+
+\begin{equation}
+    \lambda E _{evap}^{t} = \lambda E_{evap}^0  \left( 1-\beta_{v1} \beta_v \left( \frac {  B_q^{orc} - \alpha_v q_{s, sat}  }{  z_{ikq} - A_q^{orc}  }  \right) \right)
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp6.tex
+
+\begin{equation}
+    R^{net}_{sns} = \left( \frac{1}{C_p} \right) 4 \epsilon \sigma \left( \left( \frac{1}{C_p} \right) ps_{t} ^3 \right)
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp7.tex
+
+\begin{equation}
+    H_{sns} = \frac{1} { \left( \frac{1}{\rho_{air} S q_{c}} - A_T^{orc} \right)}
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp8.tex
+
+\begin{equation}
+    \lambda E_{sns}^{sub} = \lambda E_{sub}^0 \beta_{v1} \frac{1}{C_p} \left( \frac{ ({\delta q_s^{t}}/{\delta t}) } {z_{ikq} - A_q^{orc} } \right)
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp9.tex
+
+\begin{equation}
+    \lambda E_{sns}^{evap} = \lambda E_{evap}^0 (1-\beta_{v1}) \beta_v \alpha_v \frac{1}{C_p} \left( \frac{ ({\delta q_s^{t}}/{\delta t}) } {z_{ikq} - A_q^{orc} } \right)
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp10.tex
+
+\begin{equation}
+    \Sigma E^{t} = R_{net} + H^{t} + {\lambda E}_{sub}^{t} + {\lambda E}_{evap}^{t} + G
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp11.tex
+
+\begin{equation}
+    \Sigma E^{sns} = R^{sns} + H^{sns} + {\lambda E}_{sub}^{sns} + {\lambda E}_{evap}^{sns} + G
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp12.tex
+
+\begin{equation}
+    \Delta \theta = \frac {\Delta t (\Sigma E^{t})} {\left( \frac {1}{C_p^{air}} (C_p^{soil} + \Delta T) (\Sigma E^{sns}) \right)}
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp13.tex
+
+\begin{equation}
+    ps_{t+\Delta t} = ps_{t} + \Delta \theta
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp14.tex
+
+\begin{equation}
+    q_{s,sat}^{t+\Delta t} = q_{s,sat} + \left( \left( \frac{1}{C_p^{air}} \right) \left( \frac{\delta q_s^{t}}{\delta t} \right) \delta\theta \right)
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp15.tex
+
+\begin{equation}
+    T_{s}^{t+\Delta t} = \frac {ps^{t+\Delta t}}{C_p^{air}}
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp16.tex
+
+\begin{equation}
+    E_{pot}^{air,t+\Delta t} = z_{ikt} (H^{t} - H^{sns} \Delta \theta) + ps^{t+\Delta t}
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp17.tex
+
+\begin{equation}
+    {\lambda E} ^{evap} = ({\lambda E}_{evap}^{t} - {\lambda E} _{evap} ^{sns} \Delta \theta) + ({\lambda E}_{sub}^{t} - {\lambda E}_{sub}^{sns} \Delta \theta)
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp18.tex
+
+\begin{equation}
+    q_{air}^{t+\Delta t}(ji) = q_{air}(ji)
+\end{equation}
+
+\vspace {10mm}
+enerbilsurftemp19.tex
+
+\begin{equation}
+   q_{air}^{t+\Delta t} = z_{ikq} \frac {1} {(\lambda E^{evap}_0  (1 - \beta_{v1}) \beta_1 \alpha_v + \lambda E^{sub}_0 \beta_{v1})} {\lambda E} ^{evap} + q_{s,sat}^{t+\Delta t} 
+\end{equation}
+
+\vspace {10mm}
+{ \bf surf\_land\_orchidee (links from LMDZ to ORCHIDEE)} 
+
+\vspace {10mm}
+surflandLMDZ1.tex
+
+\begin{equation}
+    A_T^{orc} = B_T^{lmdz} \Delta t
+\end{equation}
+
+\vspace {10mm}
+surflandLMDZ2.tex
+
+\begin{equation}
+    B_T^{orc} = A_T^{lmdz}
+\end{equation}
+
+\vspace {10mm}
+surflandLMDZ3.tex
+
+\begin{equation}
+    A_q^{orc} = B_q^{lmdz} \Delta t
+\end{equation}
+
+\vspace {10mm}
+surflandLMDZ4.tex
+
+\begin{equation}
+    B_q^{orc} = A_q^{lmdz}
+\end{equation}
+
+\vspace {10mm}
+{ \bf enerbil\_flux} 
+
+\vspace {10mm}
+enerbilflux1.tex
+
+\begin{equation}
+    U=max\{U_{min}, \sqrt{u^2+v^2} \}
+\end{equation}
+
+\vspace {10mm}
+enerbilflux2.tex
+
+\begin{equation}
+    q_c=|v|q_{c, drag}
+\end{equation}
+
+\vspace {10mm}
+enerbilflux3.tex
+
+\begin{equation}
+    R^{LW}_{\uparrow}=\epsilon \sigma T_{sol}^4+\epsilon 4 \sigma T_{sol}^3(T_{s}^{t+\Delta t}-T_{s})
+\end{equation}
+
+\vspace {10mm}
+enerbilflux4.tex
+
+\begin{equation}
+    R^{LW}_{\uparrow}=R^{LW}_{\uparrow}+(1-\epsilon)R^{LW}_{\downarrow}
+\end{equation}
+
+\vspace {10mm}
+enerbilflux5.tex
+
+\begin{equation}
+    T_{s}^{rad}=\epsilon \sigma T_{s}^4 + R^{LW}_{\uparrow}
+\end{equation}
+
+\vspace {10mm}
+enerbilflux6.tex
+
+\begin{equation}
+    q_{surf}=\beta_{v,1} (q_{s,sat}^{t+\Delta t})+(1-\beta_{v,1})\beta_v\alpha_v(q_{s,sat}^{t+\Delta t})
+\end{equation}
+
+\vspace {10mm}
+enerbilflux7.tex
+
+\begin{equation}
+    q_s = max \{q_s, q_{air} \}
+\end{equation}
+
+\vspace {10mm}
+enerbilflux8.tex
+
+\begin{equation}
+    R_{net}=R^{LW}_{\downarrow}+R^{SW}_{net}-R^{LW}_{\uparrow}
+\end{equation}
+
+\vspace {10mm}
+enerbilflux9.tex
+
+\begin{equation}
+    vev_{app} = dt(\rho)q_c \beta_{v,1}(q_{s,sat}^{t+\Delta t}-q_{air})+\Delta t(\rho)q_c(1-\beta_{1,v}\beta_v(\alpha_v)q_{s,sat}^{t+\Delta t}-q_{air})
+\end{equation}
+
+\vspace {10mm}
+enerbilflux10.tex
+
+\begin{equation}
+   H=\lambda E_0^{sub}(\rho)q_c(\beta_{v,1})(q_{s,sat}^{t+\Delta t}-q_{air}+\lambda E_0^{evap}(\rho)q_c(1-\beta_{v,1})\beta_v(\alpha_v)q_{s,sat}^{t+\Delta t}-q_{air})
+\end{equation}
+
+\vspace {10mm}
+enerbilflux11.tex
+
+\begin{equation}
+   \lambda E^{sub}=\lambda E_0^{sub} (\rho)q_c\beta_{v,1}(q_{s,sat}^{t+\Delta t}-q_{air})
+\end{equation}
+
+\vspace {10mm}
+enerbilflux12.tex
+
+\begin{equation}
+    H = \rho q_c (ps^{t+\Delta t}- E^{pot}_{air})
+\end{equation}
+
+\vspace {10mm}
+enerbilflux13.tex
+
+\begin{equation}
+   R^{LW}_{net} = R^{LW}_{\downarrow}-R^{LW}_{\uparrow}
+\end{equation}
+
+\vspace {10mm}
+enerbilflux14.tex
+
+\begin{equation}
+   E^{pot}_{air} = max \{0, \Delta t \rho q_c (q_{s,sat}^{t+\Delta t} -q_{air}) \}
+\end{equation}
+
+\vspace {10mm}
+enerbilflux15.tex
+
+\begin{equation}
+   T_{air}= \frac{E^{pot}_{air}}{c_{p, air}}
+\end{equation}
+
+
+
+
+
+
+
+
+
+{\bf enerbil\_evapveg.f90}
+
+\vspace {10mm}
+enerbilevapveg1.tex
+
+\begin{equation}
+    U = max\{U_{min}, \sqrt{u^2 + v^2} \}
+\end{equation}
+
+\vspace {10mm}
+enerbilevapveg2.tex
+
+\begin{equation}
+   E^{snow} = \beta_{v1} \Delta t \rho U q_c^{drag} (q_{sol,s}^{t+\Delta t}- q_{air})
+\end{equation}
+
+\vspace {10mm}
+enerbilevapveg3.tex
+
+\begin{equation}
+   E^{soil} = (1-\beta_{v1})\beta_{v4} \Delta t \rho U q_c^{drag} (q_{sol,s}^{t+\Delta t} - q_{air})
+\end{equation}
+
+\vspace {10mm}
+enerbilevapveg4.tex
+
+\begin{equation}
+    U = max\{U_{min}, \sqrt{u^2 + v^2} \}
+\end{equation}
+
+\vspace {10mm}
+enerbilevapveg5.tex
+
+\begin{equation}
+   xx = \Delta t (1-\beta_{v1}) (q_{s,sat}^{t+\Delta t} - q_{a}) \rho S q_c^{drag}
+\end{equation}
+
+\vspace {10mm}
+enerbilevapveg6.tex
+
+\begin{equation}
+   (Interception) = xx \beta_{v2}
+\end{equation}
+
+\vspace {10mm}
+enerbilevapveg7.tex
+
+\begin{equation}
+   (Transpiration) = xx \beta_{v3}
+\end{equation}
+
+
+\vspace {10mm}
+enerbilevapveg8.tex
+
+\begin{equation}
+   U = max \{U_{min}, \sqrt{u^2 + v^2} \}
+\end{equation}
+
+
+\vspace {10mm}
+enerbilevapveg9.tex
+
+\begin{equation}
+   (Assimilation) = \beta_{v,CO_2} \Delta t \rho S q_c^{drag} (\chi_{CO_2}^{canopy} - \bar{Ci})
+\end{equation}
+
+
+
+
+
+\end{document}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/surflandLMDZ1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/surflandLMDZ1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/surflandLMDZ1.tex	(revision 7236)
@@ -0,0 +1,4 @@
+\begin{equation}
+    A_T^{orc} = B_T^{lmdz} \Delta t
+\end{equation}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/surflandLMDZ2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/surflandLMDZ2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/surflandLMDZ2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    B_T^{orc} = A_T^{lmdz}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/surflandLMDZ3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/surflandLMDZ3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/surflandLMDZ3.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    A_q^{orc} = B_q^{lmdz} \Delta t
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/surflandLMDZ4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/surflandLMDZ4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/enerbil/surflandLMDZ4.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    B_q^{orc} = A_q^{lmdz}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/bdiff.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/bdiff.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/bdiff.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}\label{eq:bdiff}
+W_{b_j} = \frac{\sum_j a_j W_{b_j}}{\sum_j a_j}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/drs.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/drs.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/drs.tex	(revision 7236)
@@ -0,0 +1,4 @@
+\begin{eqnarray}\label(eq:drs}
+R_s & = & 0.05 R \\
+D & = & 0.95 R
+\end{eqnarray}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/gdrainage.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/gdrainage.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/gdrainage.tex	(revision 7236)
@@ -0,0 +1,10 @@
+It is slower when the top soil moisture $W_t$ is low, and accelerates above a threshold moisture $W_t^\mathrm{lim}$: 
+\begin{equation}\label{eq:dr1}
+D_t = D_t^\mathrm{min}\frac{W_t}{W_t^\mathrm{max}}, \,\, \mathrm{if} \,\, W_t < W_t^\mathrm{lim},
+\end{equation}
+\begin{equation}\label{eq:dr2}
+D_t = D_t^\mathrm{min}\frac{W_t}{W_t^\mathrm{max}} + (D_t^\mathrm{max} - D_t^\mathrm{min})\left(
+\frac{W_t \,-\, W_t^\mathrm{lim}}{W_t^\mathrm{max}\, - \,W_t^\mathrm{lim}} \right)^{\alpha_t},
+\,\, \mathrm{if}\,\,W_i \geq W_i^{lim}
+\end{equation}
+where $D_t^\mathrm{min}$, $D_t^\mathrm{max}$, and $\alpha_t$ are specific parameters.
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/hdiff.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/hdiff.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/hdiff.tex	(revision 7236)
@@ -0,0 +1,4 @@
+For three variables (top and bottom soil moisture, $W_t$ and $W_b$; dry soil height at the top, $h_t^d$), we describe a linear relaxation of the values $X_j$ within each soil column towards their grid-cell average $X_j$, with a timescale $\tau_h$ of one day:
+\begin{equation}\label{eq:hdiff}
+\Delta X_j = - \frac{\Delta t}{\tau_h}(X_j-\overline{X}).
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/humrel.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/humrel.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/humrel.tex	(revision 7236)
@@ -0,0 +1,15 @@
+If only one soil layer is present, then  $h_t^d = h_b^d$, and we define: 
+\begin{equation}\label{eq:us1}
+U_s=  \exp (-c_j \, h_t^d )
+\end{equation}
+If there are two soil layers, we compute $U_s$ as the average of the values defined by the two dry soil depths $h_t^d$ and  $h_b^d$. The weights depend on $a_j^\mathrm{sat}$, which defines the "transpiring" fraction of the top soil layer:
+\begin{equation}\label{eq:us2}
+U_s= a_j^\mathrm{sat} \exp (-c_j \, h_t^d ) + (\mathrm{1}-a_j^\mathrm{sat})  \exp (-c_j \, h_b^d )
+\end{equation}
+
+The "transpiring" fraction is defined by redistributing the top layer's moisture $W_t$ in a virtual layer of depth $h_t^\mathrm{sub}$ (set to 1 mm in hydrolc), what defines a totally dry and a totally saturated fraction ($a_j^\mathrm{sat}$):
+\begin{itemize}
+\item if  $W_t > h_t^\mathrm{sub} \, \theta^\mathrm{max}$, then $a_j^\mathrm{sat}$=1, and $U_s$ depends on $h_t^d$ only (Eq. \ref{eq:us1}), % $U_s=\exp (-c_j \, h_t^d )$,
+\item if $W_t$ is very small, $a_j^\mathrm{sat}$ decreases from 1 to 0 as the top layer's moisture vanishes, and it serves to describe a smooth transition to the case where the top soil layer has vanished and $U_s$ depends on  $h_t^d = h_b^d$.
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/humrel1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/humrel1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/humrel1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}\label{eq:us1}
+U_s=  \exp (-c_j \, h_t^d )
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/humrel2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/humrel2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/humrel2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}\label{eq:us2}
+U_s= a_j^\mathrm{sat} \exp (-c_j \, h_t^d ) + (\mathrm{1}-a_j^\mathrm{sat})  \exp (-c_j \, h_b^d )
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/hydrolcsnow1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/hydrolcsnow1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/hydrolcsnow1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+snowmelt=\frac{(temp\_sol\_new - tp\_00)*soilcap}{chalfu0}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/hydrolcsnow2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/hydrolcsnow2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/hydrolcsnow2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+d\_age=(age-(1- \frac{age}{max\_snow\_age})*\frac{dt\_radia}{one\_day})*\exp(-\frac{precip\_snow}{snow\_trans}))-age
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/hydrolcsnow3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/hydrolcsnow3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/hydrolcsnow3.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+d\_age\_nobio=\frac{d\_age}{1+(\frac{tp\_00-T}{7.})^4}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/interception.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/interception.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/interception.tex	(revision 7236)
@@ -0,0 +1,14 @@
+These calculations are only performed in the non bare soil PFTs ($j>1$), over the vegetated fraction $a_j$. 
+The maximum amount of water that can be added to the interception reservoir is:
+\begin{equation}\label{eq:interc1}
+I^\mathrm{add} = I^\mathrm{max} - [I]_\mathrm{old} - E_i \Delta t.
+\end{equation}
+The intercepted water amount $I$ is therefore updated with:
+\begin{equation}\label{eq:interc2}
+[I]_\mathrm{new} = [I]_\mathrm{old} - E_i \Delta t + \min (a_j P_L (1-f_j) \Delta t, I^\mathrm{add}),
+\end{equation}
+where $f_j$ is the fraction of rainfall that cannot be intercepted and necessarily falls to the ground.
+The throughfall $P_T$ is then calculated with:
+\begin{equation}\label{eq:interc3}
+P_T \Delta t = P_L (1-f_j) \Delta t - ([I]_\mathrm{new} - [I]_\mathrm{old}).
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/rsol.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/rsol.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/hydrolc/rsol.tex	(revision 7236)
@@ -0,0 +1,10 @@
+It non linearly increases with the height of top dry soil $h_\mathrm{dry}$, and becomes very large when $h_\mathrm{dry}$ gets close to the total soil depth, $h_\mathrm{tot}$:
+\begin{equation}\label{eq:rsol}
+r_\mathrm{soil} = r_\mathrm{soil}^\mathrm{m} \left( h_\mathrm{dry} + \frac{\mathrm{1}}{\mathrm{100}(h_\mathrm{tot}-h_\mathrm{dry})^2}  \right).
+%r_\mathrm{soil} = r_\mathrm{soil}^r_\mathrm{m}  
+\end{equation}
+The top dry soil height  $h_\mathrm{dry}$ depends on both $h_t^d$ and $h_t^d$ in the bare soil fraction. As for the soil moisture stress factor on transpiration and bare soil evaporation ($U_s$), we use $a_j^\mathrm{sat}$ to describe a smooth transition between cases when the top layer's moisture  $W_t > h_t^\mathrm{sub} \theta^\mathrm{max}$ (then $h_\mathrm{dry}=h_t^d$),  and cases when the top layer's has vanished (then  $h_\mathrm{dry}=h_t^d=h_b^d$):
+\begin{equation}\label{eq:hdry}
+h_\mathrm{dry} = a_1^\mathrm{sat} h_{t_1}^d + (\mathrm{1} - a_1^\mathrm{sat})  h_{b_1}^d.
+\end{equation}
+% hdry(:) = a_subgrd(:,1)*dss(:,1) + (un-a_subgrd(:,1))*dsp(:,1) 
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/dev_qsat.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/dev_qsat.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/dev_qsat.tex	(revision 7236)
@@ -0,0 +1,12 @@
+We calculate the deviation of the saturated humidity with the temperature and the pressure.
+\begin{equation}
+\delta q_{sat}(T) = \frac{(q_s(\lfloor T+\frac{1}{2}\rfloor + 1) - 2.q_s(\lfloor T +\frac{1}{2} \rfloor) + q_s(\lfloor T+\frac{1}{2} \rfloor -1))(\lbrace T + \frac{1}{2}\rbrace -1 ) + q_s(\lfloor T+\frac{1}{2} \rfloor +1) - q_s(\lfloor T+\frac{1}{2} \rfloor)}{P}
+\end{equation}
+
+where : \\
+\begin{itemize}
+ \item  $ \lfloor T + \frac{1}{2} \rfloor $ represents the largest integer not greater than $T + \frac{1}{2} $. 
+ \item  $ \lbrace T + \frac{1}{2} \rbrace = T + \frac{1}{2} -\lfloor T + \frac{1}{2} \rfloor $ is the fractional part of $T + \frac{1}{2} $.
+ \item  $q_s$ is the array caclulated in the subroutine qsfrict\_init. 
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/dev_qsatcalc.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/dev_qsatcalc.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/dev_qsatcalc.tex	(revision 7236)
@@ -0,0 +1,14 @@
+We calculate the deviation of the saturated humidity with the temperature and the pressure for a given pixel $x$.
+\begin{multline}
+\delta q_{sat}(x,T) = \\
+\frac{(q_s(x,\lfloor T+\frac{1}{2}\rfloor + 1) - 2.q_s(x,\lfloor T +\frac{1}{2} \rfloor) + q_s(x,\lfloor T+\frac{1}{2} \rfloor -1))(\lbrace T + \frac{1}{2}\rbrace -1 )} {P}+ 
+\\ \frac{q_s(x,\lfloor T+\frac{1}{2} \rfloor +1) - q_s(x, \lfloor T+\frac{1}{2} \rfloor)}{P}
+\end{multline}
+
+where : \\
+\begin{itemize}
+ \item  $ \lfloor T + \frac{1}{2} \rfloor $ represents the largest integer not greater than $T + \frac{1}{2} $. 
+ \item  $ \lbrace T + \frac{1}{2} \rbrace = T + \frac{1}{2} -\lfloor T + \frac{1}{2} \rfloor $ is the fractional part of $T + \frac{1}{2} $.
+ \item  $q_s$ is the array caclulated in the subroutine qsfrict\_init. 
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/goff_gratch.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/goff_gratch.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/goff_gratch.tex	(revision 7236)
@@ -0,0 +1,30 @@
+The subroutine qsfrict\_init uses modified Goff-Gratch equations (1946). The original formulations are : \\
+\begin{multline}
+\log e_w = \\ -7.90298 \left( \frac{T_s}{T} - 1 \right) + 5.02808 \log \left( \frac{T_s}{T} \right) 
+- 1.3816 \times 10^{-7}(10^{11.344 \left( 1-\frac{T_s}{T} \right)}-1) 
++ 8.1328 \times 10^{-3}(10^{-3.49149 \left( \frac{T_s}{T}-1 \right)}
+-1) \\ + \log e_{ws}
+\end{multline}
+where : \\
+\begin{itemize}
+ \item  $ \log(x) = \frac{\ln x}{\ln 10} $. 
+ \item  $e_w$ is the saturation water vapor pressure over a plane surface of pure ordinary liquid water (hPa).
+ \item  $T$ is the absolute air temperature in Kelvin.
+ \item  $T_s$ is the steam point temperature (373.16 K).
+ \item  $e_{ws}$ is the saturation pressure of pure ordinary liquid water at steam-point temperature (at 1 atm = 1013.25 hPa).
+\end{itemize}
+
+\begin{multline}
+\log e_i = \\ -9.09718 \times \left( \frac{T_0}{T} - 1 \right) - 3.56654 \times \log \left( \frac{T_0}{T} \right) 
++ 0.876793 \times \left( 1-\frac{T_0}{T} \right) 
++ \log e_{i0}
+\end{multline}
+where : \\
+\begin{itemize}
+ \item  $ \log(x) = \frac{\ln x}{\ln 10} $. 
+ \item  $e_i$ is the saturation water vapor pressure over a plane surface of pure ordinary water ice (hPa).
+ \item  $T$ is the absolute air temperature in Kelvin (K).
+ \item  $T_0$ is the boiling point at 1 atmosphere temperature (273.16 K).
+ \item  $e^{*}_{i0}$  is the saturation pressure of pure ordinary water ice at ice-point temperature (6.1173 hPa).
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/qsat.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/qsat.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/qsat.tex	(revision 7236)
@@ -0,0 +1,12 @@
+The interpolation the saturated humidity depends on the temperature $T$ (in Kelvin). 
+It is set by the following equation :
+\begin{equation}
+q_{sat}(T)= \dfrac{q_s(\lfloor T \rfloor +1) - q_s(\lfloor T \rfloor).\lbrace T \rbrace + q_s(\lfloor T \rfloor)}{P}
+\end{equation}
+where : \\
+\begin{itemize}
+ \item  $ \lfloor T \rfloor $ represents the largest integer not greater than $T$. 
+ \item  $ \lbrace T \rbrace = T -\lfloor T \rfloor $ is the fractional part of $T$.
+ \item  $q_s$ is the array caclulated in the subroutine qsfrict\_init. 
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/qsatcalc.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/qsatcalc.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/qsatcalc.tex	(revision 7236)
@@ -0,0 +1,12 @@
+The interpolation the saturated humidity on one pixel $x$  depends on the temperature $T$ (in Kelvin). 
+It is set by the following equation :
+\begin{equation}
+q_{sat}(x,T)= \dfrac{q_s(x,\lfloor T \rfloor +1) - q_s(x,\lfloor T \rfloor).\lbrace T \rbrace + q_s(x,\lfloor T \rfloor)}{P}
+\end{equation}
+where : \\
+\begin{itemize}
+ \item  $ \lfloor T \rfloor $ represents the largest integer not greater than $T$. 
+ \item  $ \lbrace T \rbrace = T -\lfloor T \rfloor $ is the fractional part of $T$.
+ \item  $q_s$ is the array caclulated in the subroutine qsfrict\_init. 
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/qsfrict_init.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/qsfrict_init.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/qsfrict_init.tex	(revision 7236)
@@ -0,0 +1,17 @@
+The specific humidity  $q_s$ is a function of temperature $T$. Its values are : 
+\begin{equation}
+q_s(T) = 
+\begin{cases}
+0 & \text{if} \quad T < 100K \\
+\dfrac{M_{air}}{M_{vapor}} \cdot 10^{2.07203 - 0.0032099T - \frac{2484.896}{T} + 3.56654\log{T}} & \text{if} \quad 100K \leq T < 273K \\
+\dfrac{M_{air}}{M_{vapor}} \cdot 10^{23.819 - \frac{2948.964}{T} -
+  5.028\log{T} - 29910.16\exp(-0.0699832\times T) + 25.21935\exp(-\frac{2999.924}{T}) } & \text{if} \quad 273K \leq T \leq 370K \\
+\end{cases} %\]
+\end{equation}
+where : \\
+\begin{itemize}
+ \item  $\dfrac{M_{air}}{M_{vapor}} = \dfrac{18.02 \times 10^{-3}}{28.964 \times 10^{-3}} \simeq 0.622 $ is the ratio between the molecular weight of dry air and \\ 
+the molecular weight of water vapor.
+ \item  $\log(T) = \dfrac{\ln T}{\ln 10}$
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/tempfunc.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/tempfunc.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/qsat_moisture/tempfunc.tex	(revision 7236)
@@ -0,0 +1,18 @@
+%\documentclass{article}
+%\usepackage[english]{babel}
+%\usepackage{amsmath}
+%\begin{document}
+\begin{equation}
+f(T) = 
+\begin{cases}
+0 & \text{if} \quad T < 273K \\
+1 - \dfrac{(T_{max} - T)^2}{(T_{max} - T_{min})^2} & \text{if} \quad 273K \leq T \leq 293K \\
+1 & \text{if} \quad T > 293K
+\end{cases} %\]
+\end{equation}
+where : \\
+\begin{itemize}
+ \item  $ T_{min} = 273K$ 
+ \item  $ T_{max} = 293K$
+\end{itemize}
+%\end{document}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/thermosoil/thermosoil_var_init0.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/thermosoil/thermosoil_var_init0.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/thermosoil/thermosoil_var_init0.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+\frac{\partial T}{\partial t}=\frac{\partial ^2 T}{\partial z^2}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/thermosoil/thermosoil_var_init00.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/thermosoil/thermosoil_var_init00.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_sechiba/thermosoil/thermosoil_var_init00.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+C_p\frac{\partial T}{\partial t}=K\frac{\partial ^2 T}{\partial z^2}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_crown/lpj_crown.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_crown/lpj_crown.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_crown/lpj_crown.tex	(revision 7236)
@@ -0,0 +1,5 @@
+\begin{equation}
+D = \Bigl[\frac{4 \times (C_{sapwood} + C_{heartwood})}{WD.\pi.k_{allom2}}\Bigr]^{\frac{1}{(2+k_{allom3})}} 
+H = k_{allom2} \times D^{k_{allom3}} 
+CA =\min(k_{allom1} \times D^{k_{rp}},CA_{max})
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_crown/lpj_crown1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_crown/lpj_crown1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_crown/lpj_crown1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    D = \Bigl[\frac{4 \times (C_{sapwood} + C_{heartwood})}{WD.\pi.k_{allom2}}\Bigr]^{\frac{1}{(2+k_{allom3})}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_crown/lpj_crown2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_crown/lpj_crown2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_crown/lpj_crown2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    H = k_{allom2} \times D^{k_{allom3}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_crown/lpj_crown3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_crown/lpj_crown3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_crown/lpj_crown3.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+    CA =\min(k_{allom1} \times D^{k_{rp}},CA_{max})
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_establish/equation_lpj_establish.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_establish/equation_lpj_establish.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_establish/equation_lpj_establish.tex	(revision 7236)
@@ -0,0 +1,37 @@
+\begin{equation}
+FPC = \frac{CN \cdot IND}{FRAC} \cdot \left[ 1 - \exp \left( -1 \cdot 
+    LM_{\rm max} \cdot SLA \cdot coff \right) \right]
+\end{equation}
+where $FPC$ is foliage projective cover (``fpc\_nat'' in source code),
+$CN$ crown area (cn\_ind; m$^{2}$), $IND$ number of individuals (ind;
+m$^{-2}$), $FRAC$ total fraction occupied by natual vegetation
+(fracnat), $LM_{\rm max}$ maximum leaf mass in last year
+(lm\_lastyearmax; g C m$^{-2}$), $SLA$ specific leaf area (sla;
+m$^{2}$ (g C)$^{-1}$), and $coff$ coefficient (ext\_coeff).
+
+\begin{equation}
+  EST_{\rm tree} = EST_{clm} \left[1 - \exp \left( -5 \cdot (1 - FPC_{\rm woody}) 
+    \right) \right] \cdot (1 - FPC_{\rm woody})
+\end{equation}
+where $EST_{\rm tree}$ is maximum tree establishment rate
+(estab\_rate\_max\_tree), $EST_{clm}$ maximum tree establishment rate
+controled by climate (estab\_rate\_\\max\_climate\_tree), $FPC_{\rm
+  woody}$ total woody FPC (sumfpc\_wood).
+
+\begin{equation}
+  EST_{\rm grass} = \max \left[  \min \left[ EST_{clm}, 0.98 - FPC_{\rm sum} \right], 
+    0 \right]
+\end{equation}
+where $EST_{\rm grass}$ is maximum grass establishment rate
+(estab\_rate\_max\_grass) and $FPC_{\rm sum}$ total natural fpc
+(sumfpc).
+
+\begin{equation}
+FPC = \min \left[ 1, CN \right] \cdot IND \cdot \max \left[ 1 - \exp 
+  \left( -coff \cdot LAI \right), MIN_{\rm cover} \right]
+\end{equation}
+where $MIN_{\rm cover}$ is fraction of crown area invaded by other
+trees (min\_cover = 0.05)
+
+
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_fire/lpj_fire_1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_fire/lpj_fire_1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_fire/lpj_fire_1.tex	(revision 7236)
@@ -0,0 +1,6 @@
+\begin{equation}
+p(m)=e^{-\pi*\left(\frac{m}{m_e}\right)^{2}}
+\end{equation}
+
+
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_fire/lpj_fire_2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_fire/lpj_fire_2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_fire/lpj_fire_2.tex	(revision 7236)
@@ -0,0 +1,6 @@
+\begin{equation}
+A(s)=s*e^{(\frac{s-1}{0.45*(s-1)^{3}+2.83*(s-1)^{2}+2.96*(s-1)+1.04})}
+\end{equation}
+
+
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_gap/gap1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_gap/gap1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_gap/gap1.tex	(revision 7236)
@@ -0,0 +1,4 @@
+\begin{equation}
+greff=\frac{\Delta}{C_{leaf}*SLA}
+\end{equation}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_gap/gap2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_gap/gap2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_gap/gap2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+mort_{greff}=\frac{k_{mort1}}{1+k_{mort2}*greff}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_pftinout/equation_lpj_pftinout.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_pftinout/equation_lpj_pftinout.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/lpj_pftinout/equation_lpj_pftinout.tex	(revision 7236)
@@ -0,0 +1,4 @@
+\begin{equation}
+FPC = \frac{CN \cdot IND}{FRAC} \cdot \left[ 1 - \exp \left( -1 \cdot 
+    LM_{\rm max} \cdot SLA \cdot coff \right) \right]
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+A\propto \frac{\sum X_{i}}{\sum X_{i}+\sum Y_{j}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+\mathit{rpc}=\frac{1}{1-e^{-{\frac{\mathit{z_soil}\left(nbdl\right)}{\mathit{z_nitrogen}}}}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc3.tex	(revision 7236)
@@ -0,0 +1,4 @@
+\begin{equation}
+\mathit{t_{nitrogen}}=\sum_{l=1}^\mathit{nbdl} \mathit{tsoil_{month}} \cdot \mathit{rpc} \cdot \left( e^{  -\frac{\mathit{z_{soil}(l-1)}}{\mathit{z_{nitrogen}}}  } 
+- e^{  -\frac{\mathit{z_{soil}(l)}}{\mathit{z_{nitrogen}}}  } \right)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc4.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+\mathit{h_{nitrogen}}=\sum_{l=1}^\mathit{nbdl} \left(\mathit{soil\_hum\_month} \cdot \mathit{rpc} \cdot \left(e^{-{\frac{\mathit{z_{soil}}\left(l-1\right)}{\mathit{z_{nitrogen}}}}}-e^{-{\frac{\mathit{z_{soil}}(l)}{\mathit{z_{nitrogen}}}}}\right)\right)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc5.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc5.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc5.tex	(revision 7236)
@@ -0,0 +1,4 @@
+\begin{equation}
+\mathit{use\_reserve}=\mathit{min}\left(\mathit{biomass}\left(\mathit{carbres}\right),2 \cdot \frac{\mathit{dt}}{\mathit{tau_{leafinit}}}\cdot\frac{\mathit{lai_{happy}}}{\mathit{sla}}\right)
+
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc6.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc6.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc6.tex	(revision 7236)
@@ -0,0 +1,6 @@
+\begin{equation}
+
+
+\mathit{transloc\_leaf}=\frac{\mathit{L0}}{\mathit{L0}+\mathit{R0}}\cdot \mathit{use\_reserve}
+
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc7.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc7.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc7.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+\mathit{alloc\_sap_{above}}=\mathit(alloc\_min)+\left(\mathit{alloc\_max}-{\mathit{alloc\_min}}\right)\left(1-e^{-{\frac{\mathit{age}}{\mathit{demi\_alloc}}}}  \right)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc8.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc8.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_alloc/alloc8.tex	(revision 7236)
@@ -0,0 +1,8 @@
+\begin{equation}
+\mathit{falloc_{leaf}}=\mathit{LtoLSR} \cdot \left( 1-\mathit{falloc_{fruit}} \right) \cdot \mathit{carb\_rescale}
+\mathit{falloc_{sapabove}}=\mathit{StoLSR}\cdot \mathit{alloc\_sap_{above}} \cdot \left( 1-\mathit{falloc_{fruit}} \right)\cdot \mathit{carb\_rescale}
+\mathit{falloc_{sapbelow}}=\mathit{StoLSR}\cdot \left( 1- \mathit{alloc\_sap_{above}} \right) \cdot \left( 1-\mathit{falloc_{fruit}} \right)\cdot \mathit{carb\_rescale}
+\mathit{falloc_{root}}=\mathit{RtoLSR}\cdot\left( 1-\mathit{falloc_{fruit}} \right)\cdot \mathit{carb\_rescale}
+\mathit{falloc_{carbres}}=\left( 1-\mathit{carb\_rescale}\right)\left( 1-\mathit{falloc_{fruit}} \right)
+
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_data/stomate_data_SLA.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_data/stomate_data_SLA.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_data/stomate_data_SLA.tex	(revision 7236)
@@ -0,0 +1,13 @@
+The SLA is calculated for each different PFT by the following equation :
+\begin{equation}
+SLA =
+\begin{cases}
+ 2.10^{-4}\times 10^{2.29 - 0.4\log(\frac{12}{a_{leaf}})} & \text{if PFT needle-leaf} \\
+ 2.10^{-4}\times 10^{2.41 - 0.38\log(\frac{12}{a_{leaf}})}
+\end{cases} %\]
+\end{equation}
+where : \\
+\begin{itemize}
+ \item  $a_{leaf}$ is a PFT-specific value for leaf longevity in days.
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_data/stomate_data_SLA_Reich_97.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_data/stomate_data_SLA_Reich_97.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_data/stomate_data_SLA_Reich_97.tex	(revision 7236)
@@ -0,0 +1,9 @@
+The SLA is calculated in Reich et al. 97 by :
+\begin{equation} 
+SLA = \exp (5.615 - 0.46 \cdot \ln (a_{leaf}))
+\end{equation}
+where : \\
+\begin{itemize}
+ \item  $a_{leaf}$ is a PFT-specific value for leaf longevity in months.
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_data/stomate_data_sapl_grass.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_data/stomate_data_sapl_grass.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_data/stomate_data_sapl_grass.tex	(revision 7236)
@@ -0,0 +1,43 @@
+Sapling biomass for grasses : \\
+
+\begin{equation}
+\alpha_{grass} = 0.5
+\end{equation}
+
+\begin{equation}
+SAPL_{leaf}
+\begin{cases}
+\dfrac{0.1}{SLA} & \\
+\dfrac{1}{SLA} & \text{if PFT crop}
+\end{cases} %\]
+\end{equation}
+
+\begin{equation}
+SAPL_{sapabove} = 0
+\end{equation}
+
+\begin{equation}
+SAPL_{sapbelow} = 0
+\end{equation}
+
+
+\begin{equation}
+SAPL_{heartabove} = 0
+\end{equation}
+
+\begin{equation}
+SAPL_{heartbelow} = 0
+\end{equation}
+
+\begin{equation}
+SAPL_{root} = 0.1 \cdot \frac{1}{\alpha_{grass}} \cdot SAPL_{leaf} 
+\end{equation}
+
+\begin{equation}
+SAPL_{fruit} = 0.3 \cdot SAPL_{leaf} 
+\end{equation}
+
+\begin{equation}
+SAPL_{reserve} = 5 \cdot SAPL_{leaf}  
+\end{equation}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_data/stomate_data_sapl_tree.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_data/stomate_data_sapl_tree.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_data/stomate_data_sapl_tree.tex	(revision 7236)
@@ -0,0 +1,55 @@
+Sapling biomass for trees : \\
+
+\begin{equation}
+\alpha_{tree} = 1
+\end{equation}
+
+\begin{equation}
+SAPL_{leaf} =  \left( \frac {4 \cdot k_{allom1} \cdot \left( \dfrac{4 \cdot r_{hs:s} \cdot SLA }{\pi .k_{la:sa}}\right)^{0.8} }{SLA} \right)^5
+\end{equation}
+
+\begin{equation}
+SAPL_{sapabove} = 0.5 \cdot P \cdot \frac{SAPL_{leaf}}{\left( \dfrac
+  {k_{la:sa}}{SLA} \right) } \cdot k_{allom2} \cdot \left(
+  \sqrt{4.\frac{r_{hs:s}}{\pi} \frac{SAPL_{leaf}}{ \left( \dfrac {k_{la:sa}}{SLA} \right) }} \right) ^{k_{allom3}} 
+\end{equation}
+
+\begin{equation}
+SAPL_{sapbelow} = SAPL_{sapabove}
+\end{equation}
+
+
+\begin{equation}
+SAPL_{heartabove} = 2.SAPL_{sapabove}
+\end{equation}
+
+\begin{equation}
+SAPL_{heartbelow} = 2.SAPL_{sapbelow}
+\end{equation}
+
+\begin{equation}
+SAPL_{root} = 0.1 \cdot \frac{1}{\alpha_{tree}} \cdot SAPL_{leaf} 
+\end{equation}
+
+\begin{equation}
+SAPL_{fruit} = 0.3 \cdot SAPL_{leaf} 
+\end{equation}
+
+\begin{equation}
+SAPL_{reserve} = 
+\begin{cases}
+5 \cdot SAPL_{leaf} & \text{if PFT not evergreen} \\
+0 & \text{if PFT evergreen}
+\end{cases} %\]
+\end{equation}
+
+where : \\
+\begin{itemize}
+ \item  $k_{allom1}= 100$; \quad $ k_{allom2} = 40$; \quad  $k_{allom3}= 0.5$.
+ \item  $r_{hs:s}$ is the ratio between the sum of the mass of sapwood and heartwood over sapwood.
+ \item  $k_{la:sa} = 8000 $
+ \item  $P = 200000$ is the pipe density. 
+\end{itemize}
+
+
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_data/stomate_data_stem_diameter.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_data/stomate_data_stem_diameter.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_data/stomate_data_stem_diameter.tex	(revision 7236)
@@ -0,0 +1,10 @@
+Critical stem diameter for trees : beyond this diameter, the crown area no longer increases.
+\begin{equation}
+D_{max} = 0.01 .\left( \frac{k_{allom4}}{\dfrac{k_{allom2}.k_{allom3}}{100^{k_{allom3}}}} \right)^{\dfrac{1}{k_{allom3} - 1}}
+\end{equation}
+where : \\
+\begin{itemize}
+ \item  $D_{max}$ is the maximum stem diameter.
+ \item  $ k_{allom2} = 40$; \quad  $k_{allom3}= 0.5$; \quad  $k_{allom4}= 0.3$
+\end{itemize}
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/control_moist_func1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/control_moist_func1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/control_moist_func1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   M=MAX(0.25,MIN(1,M)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/control_moist_func2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/control_moist_func2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/control_moist_func2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   T=e^{0.69*(\frac{temp-303}{10})}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/control_temp_func1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/control_temp_func1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/control_temp_func1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   T=MIN(1,T)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/control_temp_func2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/control_temp_func2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/control_temp_func2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   T=MIN(1,T)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/deadleaf1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/deadleaf1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/deadleaf1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   DLC=1-e^{(-0.5*LAI)}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/deadleaf2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/deadleaf2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/deadleaf2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   M=-1.1*soilmoisture^2+2.4*soilmoisture-0.29
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/littercal1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/littercal1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/littercal1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   F=0.85-0.018*L*CN
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/littercal2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/littercal2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/littercal2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   k=\frac{1}{litter tau}*T*M
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/littercal3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/littercal3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/littercal3.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   \frac{dDL}{dt}=DL*(1-k)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/littercal4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/littercal4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/littercal4.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   \frac{dInput}{dt}=f*C*(1-L)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/littercal5.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/littercal5.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_litter/littercal5.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+   \frac{dLAI}{dt}=DL*sla*vegetmax
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_phenology/phenology_hummoigdd_gddcrit_eqn4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_phenology/phenology_hummoigdd_gddcrit_eqn4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_phenology/phenology_hummoigdd_gddcrit_eqn4.tex	(revision 7236)
@@ -0,0 +1,5 @@
+\begin{equation}
+gdd_{crit}(i) =  GDD_{crit1,j} + GDD_{crit2,j} \times T_{l} + GDD_{crit3,j} \times T_{l}^{2}
+\end{equation}
+where GDD$_{crit1,2,3}$ are the PFT-dependent threshold parameters defined by the ::$pheno_crit$\%$gdd$, and $T_{l}$ is the long-term
+reference temperature (::$tlong_ref$ - calculated in ::$stomate_constants$) in degrees C. i and j are the grid cell and PFT respectively.
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_phenology/phenology_lm_min_eqn2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_phenology/phenology_lm_min_eqn2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_phenology/phenology_lm_min_eqn2.tex	(revision 7236)
@@ -0,0 +1,7 @@
+\begin{equation}
+LM_{min}(i) = \frac{LAI_{init,min}(j)}{SLA(j)} 
+\end{equation}
+where $LM_{min}$ is the minimum leaf biomass, $LAI_{init\_min}$ is the minimum initial LAI, which is
+PFT-dependent and specified by the parameter ::pheno_crit\%lai\_initmin, which is defined in 
+::stomate\_constants. SLA, the specific leaf area, is also PFT-dependent and defined in
+::stomate\_constants. i and j are the grid cell number and PFT respectively.
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_phenology/phenology_moi_availcrit_eqn3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_phenology/phenology_moi_availcrit_eqn3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_phenology/phenology_moi_availcrit_eqn3.tex	(revision 7236)
@@ -0,0 +1,5 @@
+\begin{equation}
+avail_{crit}(i) = min_{moi,ly}(i,j) + hum_{frac}(j) * ( max_{moi,ly}(i,j) - min_{moi,ly}(i,j))
+\end{equation}
+where $min_{moi,ly}$ and $max_{moi,ly}$ are last year's minimum and maximum moisture availability, and $hum_{frac}$ is the 
+parameter ::$pheno_crit\%hum\_frac$.
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_phenology/phenology_moiavail_eqn1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_phenology/phenology_moiavail_eqn1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_phenology/phenology_moiavail_eqn1.tex	(revision 7236)
@@ -0,0 +1,5 @@
+\begin{equation}
+A_{moi} = max(\, 0.1, \frac{\sum_{i=1}^{n} H_{i}e^{-z_{i}/\zeta}\Delta_{i}}{ \sum_{i=1}^{n} e^{-z_{i}/\zeta}\Delta_{i}} \,)
+\end{equation}
+where $A_{moi}$ is the plant available moisture, $H_{i}$ is the soil humidity (relative soil moisture) of the $i$-th layer, $z_{i}$ is the depth of the layer, and $\Delta$ is its thickness. $\zeta$ is the root density profile, which is 1.5m for trees and 0.3m for grasses (Krinner et al., 2005).
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_phenology/phenology_ncdgdd_gddmin_eqn5.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_phenology/phenology_ncdgdd_gddmin_eqn5.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_phenology/phenology_ncdgdd_gddmin_eqn5.tex	(revision 7236)
@@ -0,0 +1,4 @@
+\begin{equation}
+gdd_{min} = \frac{603}{\exp(0.0091*NCD(i,j))} - 64. 
+\end{equation}
+where i and j are the grid cell and PFT, respectively. 
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_prescribe/prescribe1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_prescribe/prescribe1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_prescribe/prescribe1.tex	(revision 7236)
@@ -0,0 +1,5 @@
+The equation to calculate tree crown area from its diameter:
+\begin{equation}
+CA=k_{allom1}*Diameter^{k_{rp}}
+\end{equation}
+Where $CA$ is tree crown area, $Diameter$ is tree diameter, $k_{allom1}$ and $k_{rp}$ are parameters.
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_prescribe/prescribe2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_prescribe/prescribe2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_prescribe/prescribe2.tex	(revision 7236)
@@ -0,0 +1,5 @@
+The equation to calculate tree height from its diameter:
+\begin{equation}
+Height=k_{allom2}*Diameter^{k_{allom3}}
+\end{equation}
+Where $Height$ is tree height, $Diameter$ is tree diameter, $k_{allom2}$ and $k_{allom3}$ are parameters.
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_resp/resp1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_resp/resp1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_resp/resp1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+\mathit{rpc}=\frac{1}{1-e^{-{\frac{\mathit{z\_soil}\left(nbdl\right)}{\mathit{rprof}}}}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_resp/resp2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_resp/resp2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_resp/resp2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+\mathit{t\_root}=\sum_{l=1}^\mathit{nbdl} (\mathit{stempdiag} \cdot \mathit{rpc} \cdot \left(e^{-{\frac{\mathit{z\_soil}\left(l-1\right)}{\mathit{rprof}}}}-e^{-{\frac{\mathit{z\_soil}(l)}{\mathit{rprof}}}}\right))
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_resp/resp3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_resp/resp3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_resp/resp3.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+\mathit{slope}=\mathit{maint\_resp\_slope1}+\mathit{maint\_resp\_slope2}\cdot \mathit{tl}+\mathit{maint\_resp\_slope3}\cdot \mathit{tl}\cdot \mathit{tl}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_resp/resp4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_resp/resp4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_resp/resp4.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+\mathit{coeff\_maint}=\mathit{coeff\_maint\_zero}\cdot \left(\frac{\mathit{dt}}{\mathit{one\_day}}\right)\cdot \left(1+\mathit{slope}\cdot \mathit{t\_maint\_radia}\right)
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_resp/resp5.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_resp/resp5.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_resp/resp5.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+\mathit{resp\_maint\_leaf}=\mathit{coeff\_maint(leaf)}\cdot \mathit{leaf\_biomass}\cdot\frac{ (0.3\cdot \mathit{LAI}+1.4\cdot (1.0-e^{-0.5\cdot \mathit{LAI}}))}{\mathit{LAI}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_consumption_eqn4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_consumption_eqn4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_consumption_eqn4.tex	(revision 7236)
@@ -0,0 +1,6 @@
+\begin{equation}
+consumption = hvc1 \times NPPleaf_{long}^{hvc2}
+\end{equation}
+
+\noindent where hvc1 and hvc2 are herbivore activity constants which are set at the beginning of this module to
+0.019 and 1.38 respectively. NPPleaf_{long} is the mean, long-term leaf NPP.
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_herbivore_eqn5.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_herbivore_eqn5.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_herbivore_eqn5.tex	(revision 7236)
@@ -0,0 +1,5 @@
+\begin{equation}
+herbivore = \frac{Tres_{green} \times NPPleaf_{long}}{consumption} 
+\end{equation}
+
+\noindent where Tres_{green} is the mean residence time of the green tissue.
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_lin_relax_eqn1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_lin_relax_eqn1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_lin_relax_eqn1.tex	(revision 7236)
@@ -0,0 +1,5 @@
+\begin{equation}
+X_{l} = \frac{X_{l} \, (\tau - {\Delta}t) + X_{s} \, {\Delta}t}{\tau}
+\end{equation}
+
+\noindent where X$_{l}$ is the long-term variable (e.g. monthly temperature/moisture availability), X$_{s}$ is the short-term variable (e.g. daily temperature/moisture availability), $\Delta$t is the time step, and $\tau$ is the time constant (in days) which varies according to the length of time represented by the long-term variable (equation (3) in Krinner et al., 2005). Values for tau set are based on calibration against observations CHECK.
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_moiavail_eqn.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_moiavail_eqn.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_moiavail_eqn.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+moist_{avail} = \frac{moist_{avail} \times (tau_{hum} - \Delta t) + moist_{avail,daily} \times \Delta t}{tau_{hum}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_ncdmax_eqn2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_ncdmax_eqn2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_ncdmax_eqn2.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+ncd_{max} = 3. * one\_year 
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_soilhum_month_eqn.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_soilhum_month_eqn.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_soilhum_month_eqn.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+soilhum_{month} = \frac{soilhum_{month} \times (tau_{soilhum} - \Delta t) + soilhum_{daily} * \Delta t}{tau_{soilhum}}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_t2m_long_ref_eqn3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_t2m_long_ref_eqn3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_season/season_t2m_long_ref_eqn3.tex	(revision 7236)
@@ -0,0 +1,10 @@
+\begin{equation}
+Tl_{ref} = MAX(\, Tl_{ref-min}, \, MIN( \, Tl_{ref-max}, \, Tl \,) \,)
+\end{equation}
+
+\noindent where Tl$_{ref}$ is the long-term reference 2-meter temperature, 
+Tl$_{ref-min}$ and Tl$_{ref-max}$ are the reference minimum and maximum
+ long-term 2-meter temperature which CHECK should be set at the beginning of this 
+subroutine, and Tl is the "long-term" 2-meter reference temperature, previously
+calculated.
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq1.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+f_{active\rightarrow slow}=1-(0.85-0.68\times clay)-f_{active\rightarrow passive}.
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq2.tex	(revision 7236)
@@ -0,0 +1,13 @@
+\begin{equation}
+Flux_{pool}=
+\left\{
+  \begin{array}{ll}
+	C_{pool}\times\frac{\Delta t}{\tau_{pool}}\times\epsilon_T\times\epsilon_H & \textrm{(natural vegetation)} \\
+	C_{pool}\times\frac{\Delta t}{\tau_{pool}}\times\epsilon_T\times\epsilon_H\times 1.2 & \textrm{(C3 crops)} \\
+	C_{pool}\times\frac{\Delta t}{\tau_{pool}}\times\epsilon_T\times\epsilon_H\times 1.4 & \textrm{(C4 crops)}
+  \end{array}
+\right. \nonumber
+\end{equation}
+,where $C_{pool}$, $\Delta t$, $\tau_{pool}$, $\epsilon_T$ and $\epsilon_H$ are respectively the pool carbon
+stock, the time step, the pool turnover time, and two control coefficients
+(temperature and humidity) defined in the ::stomate\_litter module
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq3.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+Flux_{active}=Flux_{active}\cdot(1-0.75\times clay) . \nonumber
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq4.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+C_{pool} = C_{pool}-Flux_{pool}
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq5.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq5.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq5.tex	(revision 7236)
@@ -0,0 +1,3 @@
+\begin{equation}
+Resp_{soil}=\sum_{pool}(f_{pool\rightarrow atmosphere}\times Flux_{pool}).
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq6.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq6.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_soilcarbon/soilcarbon_eq6.tex	(revision 7236)
@@ -0,0 +1,9 @@
+\begin{equation}
+\left\{
+  \begin{array}{lcll}
+	C_{active}&=&C_{active}&+\sum_{pool}(f_{pool\rightarrow active}\times Flux_{pool})\\
+	C_{slow}   &=&C_{slow}&+\sum_{pool}(f_{pool\rightarrow slow}\times Flux_{pool})\\
+	C_{passive}&=&C_{passive}&+\sum_{pool}(f_{pool\rightarrow passive}\times Flux_{pool})
+  \end{array}
+\right.
+\end{equation}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_age_senes_biomass_eqn5.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_age_senes_biomass_eqn5.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_age_senes_biomass_eqn5.tex	(revision 7236)
@@ -0,0 +1,5 @@
+\begin{equation}
+\Delta B   = B \times MIN(0.99,\frac{\Delta t}{a_c}\times (\frac{a}{a_c})^4)
+\end{equation}
+where $B$ is the biomass, $\Delta B$ is the fraction of biomass lost, $\Delta t$ is the times step (1 day)
+and $a_c$ is the critical leaf age, a PFT-dependend parameter.
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_clim_senes_biomass_eqn4.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_clim_senes_biomass_eqn4.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_clim_senes_biomass_eqn4.tex	(revision 7236)
@@ -0,0 +1,5 @@
+\begin{equation}
+\Delta B = B \times \frac{\Delta t} {tau_leaffall}
+\end{equation}
+where $B$ is the biomass, $\Delta B$ is the fraction of biomass lost, $\Delta t$ is the times step (1 day)
+and $tau_leaffall$ is the time constant of meteorological determined turnover.
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_lma_update_eqn1.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_lma_update_eqn1.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_lma_update_eqn1.tex	(revision 7236)
@@ -0,0 +1,5 @@
+\begin{equation}
+A = A + A_{i} \cdot f_{i}
+\end{equation}
+where $A$ is the mean leaf age, $A_{i}$ is the leaf age in leaf age class $i$ and $f_{i}$
+is the fraction of leaves in that class.
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_moist_crit_eqn3.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_moist_crit_eqn3.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_moist_crit_eqn3.tex	(revision 7236)
@@ -0,0 +1,8 @@
+\begin{equation}
+moist_{c}=MIN(MAX(moist_{min}+0.5(moist_{max}-moist_{min}),moist_{Senesc}),moist_{noSenesc})
+\end{equation}
+where $moist_{c}$ is the moisture availability critical level, $moist_{min}$ and 
+$moist_{max}$ are the last years moisture availability extrema for this location. 
+$moist_{Senesc}$ is the PFT dependend critical moisture level for which there is senescence and 
+$moist_{noSenesc}$ the PFT dependend critical moisture level above which there is no humidity 
+related senescence.
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_temp_crit_eqn2.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_temp_crit_eqn2.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_temp_crit_eqn2.tex	(revision 7236)
@@ -0,0 +1,6 @@
+\begin{equation}
+T_{crit}   = a\cdot T^{2}+b\cdot T+c
+\end{equation}
+where $T_{crit}$ is the critical temperature for senescence, $T$ is 
+the long term annual mean temperature and $a$,$b$ and $c$ are PFT-dependent 
+empirical parameters.
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_update_LAI_eqn7.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_update_LAI_eqn7.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_update_LAI_eqn7.tex	(revision 7236)
@@ -0,0 +1,5 @@
+\begin{equation}
+LAI = SLA \cdot B_{leaf}
+\end{equation} 
+where LAI is the Leaf Area Index, SLA is the Specific Leaf Are and B_{leaf} is
+the leaf biomass.
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_update_LeafAgeDistribution_eqn6.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_update_LeafAgeDistribution_eqn6.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/ORCHIDEE/src_stomate/stomate_turnover/turnover_update_LeafAgeDistribution_eqn6.tex	(revision 7236)
@@ -0,0 +1,7 @@
+\begin{equation}
+f_{t} = \frac {f_{t-1}\cdot B_{leaf,t-1} + \Delta lm} {B_{leaf,t}}
+\end{equation}
+where $f_{t}$ is the new leaf fraction, $f_{t-1}$ is the old leaf fraction, $B_{leaf,t}$ is the new total leaf biomass
+and $B_{leaf,t-1}$ is the old total leaf biomass. $\Delta lm$ is the change in leaf biomass in the considered class due to 
+senescence.
+
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/TOOLS/codealgo.awk
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/TOOLS/codealgo.awk	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/TOOLS/codealgo.awk	(revision 7236)
@@ -0,0 +1,169 @@
+# codealgo.awk - filter of ORCHIDEE f90 files
+# command : gawk -f codealgo.awk [-d] file.f90
+# create a file.f90_preproc_codealgo filtered with algo comments inside each routine all group 
+# in the Doxygen comment just before its beginning.  
+
+#**************************************************************
+# Author: Martial.Mancip
+# Contact: Martial.Mancip__at__ipsl.jussieu.fr
+# $Revision::                                          $ Revision of last commit
+# $Author::                                            $ Author of last commit
+# $Date:: 
+# IPSL (2006)
+#  This software is governed by the CeCILL licence see libIGCM/libIGCM_CeCILL.LIC
+# Modification: 
+#
+#**************************************************************
+#==========================
+function debugprint(str) {
+  if (debug) {
+     print str  | "cat 1>&2"
+  }
+}
+function myprint(str) {
+    print str >> output_file
+}
+
+
+function flush_line() {
+    if ( nblc > 0 ) {
+	if ( inside_algo == 1 ) {
+	    myprint(" !> </ul>")
+	}
+	for ( i=1; i < nblc+1; i++ ) {
+	      myprint(line[i]) 	    
+	}
+	nblc=0
+    }
+}
+
+
+#==========================
+BEGIN {
+
+    nbarg=ARGC
+    if (ARGV[1] == "-d") {
+	debug=1
+	file=ARGV[2]
+	delete ARGV[1] 
+	nbarg--
+    } else {
+	debug=0
+	file=ARGV[1]
+    }
+    output_file=file "_preproc_codealgo"
+    if (debug) {
+	lscommand=("ls " output_file)
+	outsys=system(lscommand)
+	debugprint("output of ls : " outsys)
+	if ( outsys == 0 ) {
+	    debugprint("Already find " output_file)
+	    outsys=system("rm " output_file)
+	    debugprint("output of rm : " outsys)
+	    system("touch " output_file)
+	}
+    }
+
+# When exit statement, 'END' rule is always executed, so defined a exit_value to manage this
+    exit_value=0
+    if (nbarg != 2) {
+	debugprint("Usage: codealgo.awk [-d] file.f90")
+	debugprint("")
+	debugprint("Args:")
+	debugprint("      file.f90 = source code to be parsed")
+	debugprint("") 
+	debugprint("Options:" )
+	debugprint("       -d = debug mode")
+	debugprint("") 
+	exit_value=1
+	exit 2
+    }
+    debugprint("filter " file " in " output_file) 
+
+    # Number of previous lines commented
+    nblc=0
+    # Flag indicates inside a routine
+    routine = 0
+    routine_name = ""
+    # detect begin of algo liste
+    inside_algo=0
+
+    IGNORECASE=1
+}
+
+#==========================
+{
+  debugprint($0)
+
+  if ( match($0, "^[^!('\"]*subroutine") || match($0, "^[^!('\"]*function") ) {
+
+      debugprint("routine line.")
+
+      nblc++
+      line[nblc]=$0
+
+      # Begin of algo search
+      if ( match(line[nblc],"^[[:space:]]*end") ) {
+	  debugprint("End of the routine.")
+	  if ( routine == 0 ) {
+	      # error !
+	      debugprint("error ! End of routine has been detected but no routine was opened.")
+	      exit 1
+	  } else {
+	      if ( match(line[nblc],routine_name) ) {
+		  # here we flush the whole routine
+		  debugprint("Normal End of a routine : flush previous lines.")
+		  flush_line()
+		  routine = 0
+		  inside_algo = 0
+		  nblc = 0
+	      } else {
+		  debugprint("Error in a routine : routine_name " routine_name " doesn't match.")
+		  exit 3
+	      }
+	  }
+      } else {
+	  debugprint("Begining of a new routine.")
+
+	  if ( routine == 1 ) {
+	      if ( match(line[nblc],routine_name) ) {
+		  debugprint("routine : " routine_name " detect two times. Precompilation ? OK.")
+	      } else {
+		  # error !
+		  debugprint("error ! Already find a routine not closed.")
+		  exit 1
+	      }
+	  } else {
+	      routine_name=$2
+	      sub(/\(.*/,"",routine_name)
+	      debugprint("routine : " routine_name)
+	      routine = 1
+	  }
+      }
+
+  } else if ( routine == 1 ) {
+
+      nblc++
+      line[nblc]=$0
+
+      if (match(line[nblc], "^[[:space:]]+\\!+>*[[:space:]]+[[:digit:]]+\\.*"))
+      {
+	  debugprint("New algo line.")
+	  if ( inside_algo == 0 ) {
+	      myprint(" !> ")
+	      myprint(" !> ALGORITHM : ")
+	      myprint(" !> <ul>")
+	      debugprint("ALGORITHM.")
+	      inside_algo = 1
+	  }
+	  sub(/\!+>*/,"!> <li> ")
+	  myprint($0)
+      }
+  } else if ( routine == 0 ) {
+	  myprint($0)
+  }
+}
+
+END {
+    close(output_file)
+}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/TOOLS/codedox.awk
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/TOOLS/codedox.awk	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/TOOLS/codedox.awk	(revision 7236)
@@ -0,0 +1,366 @@
+# codedox.awk - filter of ORCHIDEE f90 files
+# command : gawk -f codedox.awk [-d] file.f90
+# create a file.f90_preproc_codedox filtered
+
+#**************************************************************
+# Author: Martial.Mancip
+# Contact: Martial.Mancip__at__ipsl.jussieu.fr
+# $Revision::                                          $ Revision of last commit
+# $Author::                                            $ Author of last commit
+# $Date:: 
+# IPSL (2006)
+#  This software is governed by the CeCILL licence see libIGCM/libIGCM_CeCILL.LIC
+# Modification: 
+#
+#**************************************************************
+#==========================
+function debugprint(str) {
+  if (debug) {
+      if ( ldebug ) { 
+	  print "-> " str  | "cat 1>&2"
+      } else {
+	  print str  | "cat 1>&2"
+      }
+  }
+}
+function myprint(str) {
+    if ( ldebug ) { 
+	print str  | "cat 1>&2"
+    } else {
+	print str >> output_file
+    }
+}
+
+
+function flush_line() {
+    if ( nblc > 0 ) {
+	debugprint("==> flush")
+	for ( i=0; i < nblc; i++ ) {
+	      myprint(line[i]) 	    
+	}
+	nblc=0
+	iblc=0
+    }
+}
+
+function code_intent(iblc) {
+    debugprint("line with intent")
+    if (match(line[iblc], "intent *\\(in\\)")) {
+	sub(/.*\!+>*\-*/, " !> [in]",line[iblc])
+    } else if (match(line[iblc], "intent *\\(out\\)")) {
+	sub(/.*\!+>*\-*/, " !> [out]",line[iblc])
+    } else if (match(line[iblc], "intent *\\(inout\\)")) {
+	sub(/.*\!+>*\-*/, " !> [in,out]",line[iblc])
+    } else {        
+        print "unknown intent error : " line[iblc]
+	debugprint("unknown intent error : " line[iblc])
+	exit 1
+    } 
+    if ( icont == 1 ) {
+	line[iblc]=line[iblc]  "\\n"
+    }
+    debugprint("line after Doxygen intent :" line[iblc])
+
+    sub(/\!.*/, "")
+    line[nblc]=$0
+    nblc++
+    debugprint("Only code intent :" $0)
+}
+
+function code_INTENT_ (iblc) {
+    debugprint("line with INTENT")
+    if (match(line[iblc], "INTENT *\\(in\\)")) {
+	sub(/.*\!+>*\-*/, " !> [in]",line[iblc])
+    } else if (match(line[iblc], "INTENT *\\(out\\)")) {
+	sub(/.*\!+>*\-*/, " !> [out]",line[iblc])
+    } else if (match(line[iblc], "INTENT *\\(inout\\)")) {
+	sub(/.*\!+>*\-*/, " !> [in,out]",line[iblc])
+    } else if (match(line[iblc], "INTENT *\\(IN\\)")) {
+	sub(/.*\!+>*\-*/, " !> [in]",line[iblc])
+    } else if (match(line[iblc], "INTENT *\\(OUT\\)")) {
+	sub(/.*\!+>*\-*/, " !> [out]",line[iblc])
+    } else if (match(line[iblc], "INTENT *\\(INOUT\\)")) {
+	sub(/.*\!+>*\-*/, " !> [in,out]",line[iblc])
+    } else {	
+        print "unknown INTENT error : " line[iblc]
+	debugprint("unknown INTENT error : " line[iblc])
+	exit 1
+    } 
+    if ( icont == 1 ) {
+	line[iblc]=line[iblc]  "\\n"
+    }
+    debugprint("line after Doxygen INTENT :" line[iblc])
+
+    sub(/\!.*/, "")
+    line[nblc]=$0
+    nblc++
+    debugprint("Only code intent :" $0)
+}
+
+#==========================
+BEGIN {
+    ldebug=0
+    debug=0
+    if (ARGV[1] == "-d") {
+	debug=1
+	file=ARGV[2]
+ 	delete ARGV[1] 
+    } else if (ARGV[1] == "-dd") {
+	debug=1
+	ldebug=1
+	file=ARGV[2]
+	delete ARGV[1] 
+    } else {
+	file=ARGV[1]
+    }
+    debugprint("traitement de " file)
+
+    output_file=file "_preproc_codedox"
+    if (debug) {
+	if ( ! ldebug ) {
+	    lscommand=("ls " output_file)
+	    outsys=system(lscommand)
+	    debugprint("output of ls : " outsys)
+	    if ( outsys == 0 ) {
+		debugprint("Already find " output_file)
+		outsys=system("rm " output_file)
+		debugprint("output of rm : " outsys)
+		system("touch " output_file)
+	    }
+	}
+    }
+
+# When exit statement, 'END' rule is always executed, so defined a exit_value to manage this
+    exit_value=0
+    if ( ARGV[1] == "-h" ) {
+	debugprint("Usage: codedox.awk [-h] [-d|-dd] file.f90")
+	debugprint("")
+	debugprint("Args:")
+	debugprint("      file.f90 = source code to be parsed")
+	debugprint("") 
+	debugprint("Options:" )
+	debugprint("       -h = this usage")
+	debugprint("       -d = debug mode")
+	debugprint("       -dd = debug mode stdout")
+	debugprint("") 
+	exit_value=1
+	exit
+    }
+    # Number of previous lines commented
+    nblc=0
+
+    # Flag to point indented declaration
+    idecl=0
+    # index of first declaration comment 
+    icdecl=0
+    # Flag to point a continuation line inside a declaration
+    icont=0
+    # Number of the first line of declaration group inside line tab
+    nicont=0
+}
+
+#==========================
+{
+  debugprint($0)
+
+  # Divers modification de la ligne pour la compatibilitÃ© Doxygen
+  if (match($0, "!+")) {
+      
+      if (match($0, "!\\?")) {
+	  debugprint("Wrong comment")
+	  sub(/\!\?/, "!")
+	  debugprint("Correct wrong comment" $0)
+      } else if (match($0, "f90doc")) {
+	  debugprint("suppression de la ligne")
+	  next
+      } else if (match($0, "@call")) {
+	  debugprint("line with @call")
+	  sub(/@call/, "@see",$0)
+	  debugprint("line after correct call :" $0)
+      } else if (match($0, "@Version")) {
+          debugprint("line with @Version")
+          sub(/@Version/, "@version")
+          debugprint("line after Doxygen @version :" $0)
+      } else if (match($0, "@tex")) {
+	  match($0,"@tex([^@]+)@endtex",math)
+          debugprint("line with formula :" math[1])
+	  $0 = substr($0,1,match($0,"@tex")-1) "@htmlonly" math[1] "@endhtmlonly @latexonly" math[1] "@endlatexonly" substr($0,match($0,"@endtex")+7)
+      }
+
+      # traitement des simples cotes
+      if (match($0, "'") && ! match($0, "'.*'") ) {
+          debugprint("line with single cote")
+          sub(/'/, "''",$0)
+          debugprint("line without single cote : " $0)
+      }
+  }
+
+  if (match($0, "!+")) {
+      debugprint("line with comment")
+      
+      if ( idecl == 1 ) {
+	  debugprint("inside a decl " (match($0,"^[[:space:]]+!")) " " match($0,"!") " " icdecl ".")
+	  if ( (match($0,"^[[:space:]]+!")) && (match($0,"!") == icdecl) ) { 	
+	      line[nblc]=line[nblc-1]
+	      sub(/^[[:space:]]+\!+>*/," !>")
+	      # on Ã©crit le nouveau commentaire avant le prÃ©cÃ©dant
+	      line[nblc-1]=$0 "\\n"
+	      nblc++
+	      debugprint("continuation of declaration")
+	      next
+	  } else if ( icont == 1 ) {
+	      if (match($0,"!")) { 
+		  debugprint("continuation of declaration with &" nicont) 
+		  for ( i=nblc; i > nicont; i-- ) {
+		      line[i]=line[i-1]
+		  }
+		  nblc++
+
+		  line[nblc]=substr($0,1,icdecl-1)
+		  nblc++
+
+		  line[nicont+1]=line[nicont]
+
+		  line[nicont]=substr($0,icdecl)
+		  sub(/^\!+>*/," !>",line[nicont])
+		  line[nicont]=line[nicont] "\\n"
+		  for ( i=nicont-1; i < nblc; i++ ) {
+		      debugprint(":" i line[i])
+		  }
+	      } else {
+		  line[nblc]=$0
+		  nblc++
+		  debugprint("no comment in continuation of declaration with &") 
+	      }
+	      
+	      if ( match(line[nblc-1], "&") ) {
+		  if ( match(line[nblc-1], "&.*&") ) {
+		      icont = 1
+		      nicont=nicont+1
+		      debugprint("next line with &") 
+		  } else if ( match(line[nblc-1], "^[[:space:]]*&") ) {
+		      icont = 0
+		      nicont = 0
+		      debugprint("next line without &") 
+		  } else {
+		      icont = 1
+		      nicont=nicont+1
+		      debugprint("next line with &") 
+		  }
+	      } else {
+		  icont = 0
+		  nicont = 0
+		  debugprint(match(line[nblc-1], "^[[:space:]]+&*[^!]+&") match(line[nblc-1], "^[[:space:]]+[^!]+&[[:space:]]*!*"))
+	      }
+	      next
+	  } else {
+	      idecl=0
+	      icont = 0
+	      nicont = 0
+	      flush_line()
+	  }
+      }
+
+      iblc=nblc
+      line[nblc]=$0
+      nblc++
+
+      # commentary after a parameter documentation : need flush previous lines without Doxygen doc
+      if (match(line[iblc], "^[^!]+intent *\\(.*\\).*::")) {
+	  idecl=1
+	  icdecl=match($0,"!")
+	  if ( match(line[iblc], "[^!]*::[^!]*&") ) {
+	      icont = 1
+	      nicont=nblc
+	      debugprint("next line with &") 
+	  }
+	  code_intent(iblc)
+
+      } else if (match(line[iblc], "^[^!]+INTENT *\\(.*\\).*::")) {
+	  idecl=1
+	  icdecl=match($0,"!")
+	  if ( match(line[iblc], "[^!]*::[^!]*&") ) {
+	      icont = 1
+	      nicont=nblc
+	      debugprint("next line with &") 
+	  }
+	  code_INTENT_(iblc)
+
+      } else if (match(line[iblc], "^[^!]+::")) {
+	  debugprint("line with declaration")
+
+	  idecl=1
+	  icdecl=match($0,"!")
+	  if ( match(line[iblc], "[^!]*::[^!]*&") ) {
+	      icont = 1
+	      nicont=nblc
+	      debugprint("next line with &") 
+	  }
+
+	  sub(/.*\!+>*/, " !>",line[iblc])
+	  debugprint("line after Doxygen declaration :" line[iblc])
+
+	  sub(/\!.*/, "")
+	  debugprint("Only code declaration :" $0)
+	  line[nblc]=$0
+	  nblc++
+
+      }
+      next
+  } else if (match($0, "^[^!]*subroutine.*\\(.*") || match($0, "^[^!]*SUBROUTINE.*\\(.*") || 
+	     ( match($0, "^[^!]*subroutine ") && ! (match($0, "^[[:space:]]+end ")) ) || 
+	     ( match($0, "^[^!]*SUBROUTINE ") && ! (match($0, "^[[:space:]]+END ")) ) || 
+	     match($0, "^[^!]*function.*\\(.*") || match($0, "^[^!]*FUNCTION.*\\(.*") || 
+	     match($0, "^[^!]*module *") || match($0, "^[^!]*MODULE *") || 
+	     match($0, "^[^!]*interface *") || match($0, "^[^!]*INTERFACE *") ||
+	     match($0, "^[^!]+::")) {
+
+      debugprint("f90 declaration")
+
+      if ( idecl == 1 ) {
+	  idecl=0
+	  icont=0
+	  flush_line()
+      } 
+      if (nblc > 0 && ( match($0, "^[^!]+intent *\\(.*\\).*::") ||
+			match($0, "^[^!]+INTENT *\\(.*\\).*::") )) {
+	  if (match($0, "\\(in\\)") || match($0, "\\(IN\\)")) {
+	      sub(/.*\!+>*\-*/, " !> [in]",line[iblc])
+	  } else if (match($0, "\\(out\\)") || match($0, "\\(OUT\\)")) {
+	      sub(/.*\!+>*\-*/, " !> [out]",line[iblc])
+	  } else if (match($0, "\\(inout\\)") || match($0, "\\(INOUT\\)")) {
+	      sub(/.*\!+>*\-*/, " !> [in,out]",line[iblc])
+	  } else {	
+	      print "unknown INTENT error : " $0
+	      debugprint("unknown INTENT error : " $0)
+	      exit 1
+	  }
+      } else {
+
+	  for ( i=0; i < nblc; i++ ) {
+	      #  : ajout des commentaires Doxygen
+	      if (match(line[i], "!<")) {
+		  sub(/\^ *\!+</, " !>",line[i])
+	      } else {
+		  sub(/^ *\!\!/, " !>",line[i])
+	      }
+
+	      debugprint("traitement des lignes prÃ©cÃ©dentes : " line[i])
+	  }
+      }
+      flush_line()
+      myprint($0)
+      next
+  } else {
+      debugprint("normal line")
+
+      if ( idecl == 1 ) idecl=0
+
+      flush_line()
+      myprint($0)
+  }
+}
+
+END {
+    if ( ! ldebug ) close(output_file)
+}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/TOOLS/codeinc.awk
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/TOOLS/codeinc.awk	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/TOOLS/codeinc.awk	(revision 7236)
@@ -0,0 +1,121 @@
+# codeinc.awk - filter of ORCHIDEE f90 files
+# command : gawk -f codeinc.awk [-d] file.f90
+# create a file.f90_preproc_codeinc filtered
+
+#**************************************************************
+# Author: Martial.Mancip
+# Contact: Martial.Mancip__at__ipsl.jussieu.fr
+# $Revision::                                          $ Revision of last commit
+# $Author::                                            $ Author of last commit
+# $Date:: 
+# IPSL (2006)
+#  This software is governed by the CeCILL licence see libIGCM/libIGCM_CeCILL.LIC
+# Modification: 
+#
+#**************************************************************
+#==========================
+function debugprint(str) {
+  if (debug) {
+     print str  | "cat 1>&2"
+  }
+}
+function myprint(str) {
+    print str >> output_file
+}
+
+
+#==========================
+BEGIN {
+    debugprint("traitement de " ARGV[1])
+
+    nbarg=ARGC
+    if (ARGV[1] == "-d") {
+	debug=1
+	file=ARGV[2]
+	delete ARGV[1] 
+	nbarg--
+    } else {
+	debug=0
+	file=ARGV[1]
+    }
+    output_file=file "_preproc_codeinc"
+    if (debug) {
+	lscommand=("ls " output_file)
+	outsys=system(lscommand)
+	debugprint("output of ls : " outsys)
+	if ( outsys == 0 ) {
+	    debugprint("Already find " output_file)
+	    outsys=system("rm " output_file)
+	    debugprint("output of rm : " outsys)
+	    system("touch " output_file)
+	}
+    }
+
+# When exit statement, 'END' rule is always executed, so defined a exit_value to manage this
+    exit_value=0
+    if (nbarg != 2) {
+	debugprint("Usage: codeinc.awk [-d] file.f90")
+	debugprint("")
+	debugprint("Args:")
+	debugprint("      file.f90 = source code to be parsed")
+	debugprint("") 
+	debugprint("Options:" )
+	debugprint("       -d = debug mode")
+	debugprint("") 
+	exit_value=1
+	exit
+    }
+    codeinc=0
+    linecodeinc[1]=""
+    line[1]=""
+}
+
+#==========================
+{
+  debugprint($0)
+
+# Get information with MPI Program Information output on NEC
+  if (match($0, " *!> @codeinc *")) 
+  {
+      codeinc=1
+      nblines=0
+      Length=(match($0,"!>")-1)
+      spaces=substr($0,1,Length)
+      debugprint("Find @codeinc !" spaces Length)
+      myprint(spaces "!> @code")
+      next
+  } 
+  else if ( codeinc == 1 )
+  {
+      if (match($0, " *!> @endcodeinc *")) 
+      {
+	  codeinc=0
+	  debugprint("Find @endcodeinc !")
+	  for (i=0; i<nblines; i++) {  
+	      myprint(spaces "!> " linecodeinc[i])
+	  }
+ 	  myprint(spaces "!> @endcode")
+	  for (i=0; i<nblines; i++) {  
+	      myprint(line[i])
+	  }
+	  nblines=0
+      }
+      else
+      {
+	  line[nblines]=$0
+	  debugprint(nblines " | " line[nblines])
+	  linecodeinc[nblines]=substr(line[nblines],Length+1)
+	  debugprint(linecodeinc[nblines])
+	  nblines++
+      }
+  }
+  else
+  {
+      myprint($0)
+  }
+
+}
+
+END {
+    close(output_file)
+}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/footer.tex
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/footer.tex	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/footer.tex	(revision 7236)
@@ -0,0 +1,72 @@
+
+% \addcontentsline{toc}{chapter}{ANNEXE B : Table des notations} 
+% \markboth{\uppercase{\ Title Notations}}
+% {\uppercase{\ Notations}} \thispagestyle{empty} \input{./notation} %
+% \thispagestyle{empty} \newpage \thispagestyle{empty} \null \newpage \newpage 
+% {\pagestyle{empty}\cleardoublepage}
+
+\part{Annexes}
+
+\chapter{Index}
+\label{chap:index}
+
+\printindex
+
+\newpage
+\clearemptydoublepage
+
+\bibliographystyle{alpha}
+\bibliography{orchidee}
+\setcounter{chapter}{17}
+\addcontentsline{toc}{chapter}{Bibliography}
+\label{chap:biblio}
+
+\clearemptydoublepage
+
+This scientific documentation is the result of a huge effort led by the ORCHIDEE community,
+which reached a peak at the now famous ORCHIDEE summit, held at Saint-Lambert-Des-Bois (France), on 
+January, 19-20, 2012.
+
+Citation: To Be Defined
+
+List of Contributors:
+\begin{itemize}
+\item Bellassen Valentin, CDC Climat
+\item Cadule Patricia, IPSL
+\item Campoy AurÃ©lien, Sisyphe/UPMC
+\item Ciais Philippe, LSCE/IPSL
+\item de Noblet Nathalie, LSCE/IPSL
+\item de Weirdt Marjolein, UGent
+\item Ducharne AgnÃšs, Sisyphe/UPMC
+\item Gouttevin Isabelle, LGGE
+\item Guenet Betrand, LSCE/IPSL
+\item Guimberteau Mathieu, LOCEAN/IPSL
+\item Kato Tomomichi, LSCE/IPSL
+\item Koffi Ernest, LSCE/IPSL
+\item Kuppel Sylvain, LSCE/IPSL
+\item LathiÃšre Juliette, LSCE/IPSL
+\item Launois Thomas, LSCE/IPSL
+\item Luyssaert Sebastiaan, LSCE/IPSL
+\item MacBean Natasha, LSCE/IPSL
+\item Maignan Fabienne, LSCE/IPSL
+\item Mancip Martial, IPSL
+\item OttlÃ© Catherine, LSCE/IPSL
+\item Otto Juliane, LSCE/IPSL
+\item Peylin Philippe, LSCE/IPSL
+\item Polcher Jan, LMD/IPSL
+\item Poulter Benjamin, LSCE/IPSL
+\item Ryder James, LSCE/IPSL
+\item Saito Makoto, LSCE/IPSL
+\item Solyga Didier, LSCE/IPSL
+\item Tan Kun, LSCE/IPSL
+\item Valade Aude, LSCE/IPSL
+\item Verbecke Thomas, LSCE/IPSL
+\item Viovy Nicolas, LSCE/IPSL
+\item Vuichard Nicolas, LSCE/IPSL
+\item Wang Tao, LSCE/IPSL
+\item Yue Chao, LSCE/IPSL
+\end{itemize}
+
+
+
+\end{document}
Index: branches/publications/ORCHIDEE_CAN_NHA/DOC/header.tex.init
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/DOC/header.tex.init	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/DOC/header.tex.init	(revision 7236)
@@ -0,0 +1,252 @@
+\batchmode
+\documentclass[a4paper]{book}
+\usepackage{a4wide}
+\usepackage{makeidx}
+\usepackage[pdftex]{graphicx}
+\newcommand\textsubscript[1]{\ensuremath{{}_{\text{#1}}}}
+\usepackage{multicol}
+\usepackage{float}
+\usepackage{listings}
+\usepackage{color}
+\usepackage{ifthen}
+\usepackage[table]{xcolor}
+\usepackage{textcomp}
+\usepackage{alltt}
+\usepackage{times}
+\usepackage{ifpdf}
+\usepackage{hyperref}
+\hypersetup{pdftex,
+            pagebackref=true,
+            colorlinks=true,
+            linkcolor=blue,
+            citecolor=blue, 
+            filecolor=blue,
+            urlcolor=blue,
+            unicode,
+            pdftitle=ORCHIDEE Documentation,
+            pdfauthor=IPSL,
+            pdfsubject=Documentation,
+            pdfkeywords=ORCHIDEE Documentation Scientific Development}
+% Text styles
+\newcommand\textstyleInternetlink[1]{\textcolor[rgb]{0.0,0.0,0.5019608}{#1}}
+\newcommand\textstyleCitationHTML[1]{\textit{#1}}
+\makeatletter
+\newcommand\arraybslash{\let\\\@arraycr}
+\makeatother
+
+\usepackage[utf8]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage[english]{babel}
+%\usepackage[french]{babel}
+
+\usepackage{pifont}
+\usepackage{eurosym}
+\usepackage{amsmath}
+\usepackage{wasysym}
+\usepackage{amssymb,amsfonts,textcomp}
+\usepackage[top=2.54cm,bottom=2.54cm,left=3.175cm,right=3.175cm]{geometry}
+
+\usepackage{array}
+\usepackage{supertabular}
+\usepackage{hhline}
+% \newcommand\arraybslash{\let\\\@arraycr}
+\makeatother
+% Footnote rule
+\setlength{\skip\footins}{0.119cm}
+\renewcommand\footnoterule{\vspace*{-0.018cm}\setlength\leftskip{0pt}\setlength\rightskip{0pt plus 1fil}\noindent\textcolor{black}{\rule{0.25\columnwidth}{0.018cm}}\vspace*{0.101cm}}
+% Pages styles
+\makeatletter
+\newcommand\ps@Standard{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{}
+  \renewcommand\thepage{\arabic{page}}
+}
+\makeatother
+\pagestyle{Standard}
+\setlength\tabcolsep{1mm}
+\renewcommand\arraystretch{1.3}
+
+% Pages styles
+\makeatletter
+\newcommand\ps@Conversionvi{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{\@oddhead}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{\@oddfoot}
+  \renewcommand\thepage{\arabic{page}}
+}
+\newcommand\ps@Conversionv{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{\@oddhead}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{\@oddfoot}
+  \renewcommand\thepage{\arabic{page}}
+}
+\newcommand\ps@Conversioniv{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{\@oddhead}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{\@oddfoot}
+  \renewcommand\thepage{\arabic{page}}
+}
+% \newcommand\ps@Standard{
+%   \renewcommand\@oddhead{}
+%   \renewcommand\@evenhead{}
+%   \renewcommand\@oddfoot{}
+%   \renewcommand\@evenfoot{}
+%   \renewcommand\thepage{\arabic{page}}
+% }
+\newcommand\ps@Conversioniii{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{\@oddhead}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{\@oddfoot}
+  \renewcommand\thepage{\roman{page}}
+}
+\newcommand\ps@Conversionii{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{\@oddhead}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{\@oddfoot}
+  \renewcommand\thepage{\arabic{page}}
+}
+\newcommand\ps@Conversioni{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{\@oddhead}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{\@oddfoot}
+  \renewcommand\thepage{\roman{page}}
+}
+\newcommand\ps@Conversionxv{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{\@oddhead}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{\@oddfoot}
+  \renewcommand\thepage{\arabic{page}}
+}
+\newcommand\ps@Conversionxiv{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{\@oddhead}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{\@oddfoot}
+  \renewcommand\thepage{\arabic{page}}
+}
+\newcommand\ps@Conversionxiii{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{\@oddhead}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{\@oddfoot}
+  \renewcommand\thepage{\arabic{page}}
+}
+\newcommand\ps@Conversionxii{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{\@oddhead}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{\@oddfoot}
+  \renewcommand\thepage{\arabic{page}}
+}
+\newcommand\ps@Conversionxi{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{\@oddhead}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{\@oddfoot}
+  \renewcommand\thepage{\arabic{page}}
+}
+\newcommand\ps@Conversionx{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{\@oddhead}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{\@oddfoot}
+  \renewcommand\thepage{\arabic{page}}
+}
+\newcommand\ps@Conversionix{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{\@oddhead}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{\@oddfoot}
+  \renewcommand\thepage{\arabic{page}}
+}
+\newcommand\ps@Conversionviii{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{\@oddhead}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{\@oddfoot}
+  \renewcommand\thepage{\arabic{page}}
+}
+\newcommand\ps@Conversionvii{
+  \renewcommand\@oddhead{}
+  \renewcommand\@evenhead{\@oddhead}
+  \renewcommand\@oddfoot{}
+  \renewcommand\@evenfoot{\@oddfoot}
+  \renewcommand\thepage{\arabic{page}}
+}
+
+\usepackage{doxygen}
+\lstset{language=C++,inputencoding=utf8,basicstyle=\footnotesize,breaklines=true,breakatwhitespace=true,tabsize=8,numbers=left }
+\usepackage{indentfirst}
+\makeindex
+\setcounter{tocdepth}{3}
+\renewcommand{\footrulewidth}{0.4pt}
+\hfuzz=15pt
+\setlength{\emergencystretch}{15pt}
+\hbadness=750
+\tolerance=750
+
+\usepackage{minitoc}
+\setcounter{minitocdepth}{5}
+%\renewcommand{\mtctitle}{\em Plan du chapitre}
+
+\renewcommand{\chaptermark}[1]{\markboth{#1}{}}
+\renewcommand{\sectionmark}[1]{\markright{\thesection \ #1}}
+
+% Les headers (tÃªtes de page)
+% \usepackage{fancyhdr}
+% \pagestyle{fancy}
+% \fancyhf{}
+% \fancyhead[LE,RO]{\bfseries\thepage}
+% \fancyhead[LO]{\bfseries\rightmark}
+% \fancyhead[RE]{\bfseries\leftmark}
+% \fancypagestyle{plain}
+% \fancyhead{}
+\renewcommand{\headrulewidth}{1pt}
+ 
+
+\begin{document}
+\hypersetup{pageanchor=false,citecolor=blue}
+\begin{titlepage}
+\vspace*{7cm}
+\begin{center}
+\leavevmode
+\includegraphics[scale=1]{logo_orchidee.png}
+{ \\[1ex]\large MYTAG revision MYREV}\\
+\vspace*{0.5cm}
+{\Large IPSL (Pierre Simon Laplace Institute)}\\
+\vspace*{1cm}
+{\-ORCHIDEE is the land-surface scheme of the IPSL.\\
+This scheme is the result of the coupling of the SECHIBA land-surface
+scheme, \\
+which is dedicated to the surface energy and water balances, \\
+and the carbon and vegetation model STOMATE.}\\
+\vspace*{0.5cm}
+{\Large \today}
+\end{center}
+\end{titlepage}
+
+\dominitoc
+
+\part{Table Of Contents}
+\clearemptydoublepage
+\pagenumbering{roman}
+\tableofcontents
+%\clearemptydoublepage
+
+\pagenumbering{arabic}
+\hypersetup{pageanchor=true,citecolor=blue}
+
+\part{Documentation}
+\label{part:doc}
+
+
+
Index: branches/publications/ORCHIDEE_CAN_NHA/Doxyfile_ORCHIDEE.init
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/Doxyfile_ORCHIDEE.init	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/Doxyfile_ORCHIDEE.init	(revision 7236)
@@ -0,0 +1,288 @@
+# Doxyfile 1.7.3
+
+#---------------------------------------------------------------------------
+# Project related configuration options
+#---------------------------------------------------------------------------
+DOXYFILE_ENCODING      = UTF-8
+PROJECT_NAME           = ORCHIDEE
+PROJECT_NUMBER         = "MYTAG rev MYREV"
+PROJECT_BRIEF          = "The land-surface scheme of IPSL."
+PROJECT_LOGO           = MYPATH/ORCHIDEE/DOC/logo_orchidee.png
+OUTPUT_DIRECTORY       = MYPATH/ORCHIDEE/docs
+CREATE_SUBDIRS         = YES
+OUTPUT_LANGUAGE        = English
+BRIEF_MEMBER_DESC      = YES
+REPEAT_BRIEF           = YES
+ABBREVIATE_BRIEF       =
+ALWAYS_DETAILED_SEC    = YES
+INLINE_INHERITED_MEMB  = YES
+FULL_PATH_NAMES        = YES
+STRIP_FROM_PATH        = MYPATH/modeles_doc
+STRIP_FROM_INC_PATH    = MYPATH/ORCHIDEE/DOC
+SHORT_NAMES            = NO
+JAVADOC_AUTOBRIEF      = NO
+QT_AUTOBRIEF           = NO
+MULTILINE_CPP_IS_BRIEF = NO
+INHERIT_DOCS           = YES
+SEPARATE_MEMBER_PAGES  = YES
+TAB_SIZE               = 12
+ALIASES                = 
+OPTIMIZE_OUTPUT_FOR_C  = NO
+OPTIMIZE_OUTPUT_JAVA   = NO
+OPTIMIZE_FOR_FORTRAN   = YES
+OPTIMIZE_OUTPUT_VHDL   = NO
+EXTENSION_MAPPING      =
+BUILTIN_STL_SUPPORT    = NO
+CPP_CLI_SUPPORT        = NO
+SIP_SUPPORT            = NO
+IDL_PROPERTY_SUPPORT   = NO
+DISTRIBUTE_GROUP_DOC   = YES
+SUBGROUPING            = YES
+TYPEDEF_HIDES_STRUCT   = YES
+SYMBOL_CACHE_SIZE      = 9
+#---------------------------------------------------------------------------
+# Build related configuration options
+#---------------------------------------------------------------------------
+EXTRACT_ALL            = YES
+EXTRACT_PRIVATE        = YES
+EXTRACT_STATIC         = YES
+EXTRACT_LOCAL_CLASSES  = YES
+EXTRACT_LOCAL_METHODS  = YES
+EXTRACT_ANON_NSPACES   = YES
+HIDE_UNDOC_MEMBERS     = NO
+HIDE_UNDOC_CLASSES     = NO
+HIDE_FRIEND_COMPOUNDS  = NO
+HIDE_IN_BODY_DOCS      = NO
+INTERNAL_DOCS          = YES
+CASE_SENSE_NAMES       = NO
+HIDE_SCOPE_NAMES       = YES
+SHOW_INCLUDE_FILES     = YES
+FORCE_LOCAL_INCLUDES   = YES
+INLINE_INFO            = YES
+SORT_MEMBER_DOCS       = YES
+SORT_BRIEF_DOCS        = NO
+SORT_MEMBERS_CTORS_1ST = NO
+SORT_GROUP_NAMES       = NO
+SORT_BY_SCOPE_NAME     = NO
+STRICT_PROTO_MATCHING  = 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
+SHOW_FILES             = YES
+SHOW_NAMESPACES        = YES
+FILE_VERSION_FILTER    = 
+LAYOUT_FILE            =
+#---------------------------------------------------------------------------
+# 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           = doxygen.log
+#---------------------------------------------------------------------------
+# configuration options related to the input files
+#---------------------------------------------------------------------------
+INPUT                  = SRCPATH/ORCHIDEE \
+                         SRCPATH/ORCHIDEE_OL
+# \
+#                         SRCPATH/IOIPSL/src/
+INPUT_ENCODING         = UTF-8
+FILE_PATTERNS          = *.f90 \
+                         *.F90 \
+                         *.h
+RECURSIVE              = YES
+EXCLUDE                = 
+EXCLUDE_SYMLINKS       = YES
+EXCLUDE_PATTERNS       = 
+EXCLUDE_SYMBOLS        = 
+EXAMPLE_PATH           = MYPATH/ORCHIDEE/DOC
+EXAMPLE_PATTERNS       = *
+EXAMPLE_RECURSIVE      = NO
+IMAGE_PATH             = MYPATH/ORCHIDEE/DOC
+INPUT_FILTER           = 
+FILTER_PATTERNS        = 
+FILTER_SOURCE_FILES    = NO
+FILTER_SOURCE_PATTERNS =
+#---------------------------------------------------------------------------
+# configuration options related to source browsing
+#---------------------------------------------------------------------------
+SOURCE_BROWSER         = YES
+INLINE_SOURCES         = YES
+STRIP_CODE_COMMENTS    = NO
+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    = 5
+IGNORE_PREFIX          = 
+#---------------------------------------------------------------------------
+# configuration options related to the HTML output
+#---------------------------------------------------------------------------
+GENERATE_HTML          = YES
+HTML_OUTPUT            = html
+HTML_FILE_EXTENSION    = .html
+HTML_HEADER            = 
+# MYPATH/ORCHIDEE/DOC/header.html
+HTML_FOOTER            = 
+# MYPATH/ORCHIDEE/DOC/footer.html
+HTML_STYLESHEET        = 
+HTML_EXTRA_FILES       =
+HTML_COLORSTYLE_HUE    = 220
+HTML_COLORSTYLE_SAT    = 100
+HTML_COLORSTYLE_GAMMA  = 80
+HTML_TIMESTAMP         = YES
+HTML_ALIGN_MEMBERS     = YES
+HTML_DYNAMIC_SECTIONS  = YES
+GENERATE_DOCSET        = YES
+DOCSET_FEEDNAME        = "IPSL model"
+DOCSET_BUNDLE_ID       = fr.orchidee.ipsl.jussieu
+DOCSET_PUBLISHER_ID    = org.doxygen.Publisher
+DOCSET_PUBLISHER_NAME  = Publisher
+GENERATE_HTMLHELP      = NO
+CHM_FILE               = 
+HHC_LOCATION           = 
+GENERATE_CHI           = NO
+CHM_INDEX_ENCODING     =
+BINARY_TOC             = YES
+TOC_EXPAND             = YES
+GENERATE_QHP           = YES
+QCH_FILE               =
+QHP_NAMESPACE          = fr.orchidee.ipsl.jussieu
+QHP_VIRTUAL_FOLDER     = docs
+QHP_CUST_FILTER_NAME   =
+QHP_CUST_FILTER_ATTRS  =
+QHP_SECT_FILTER_ATTRS  =
+QHG_LOCATION           =
+GENERATE_ECLIPSEHELP   = YES
+ECLIPSE_DOC_ID         = org.doxygen.Project
+DISABLE_INDEX          = NO
+ENUM_VALUES_PER_LINE   = 4
+GENERATE_TREEVIEW      = YES
+USE_INLINE_TREES       = YES
+TREEVIEW_WIDTH         = 250
+EXT_LINKS_IN_WINDOW    = YES
+FORMULA_FONTSIZE       = 10
+FORMULA_TRANSPARENT    = YES
+USE_MATHJAX            = YES
+MATHJAX_RELPATH        = http://www.mathjax.org/mathjax
+SEARCHENGINE           = YES
+SERVER_BASED_SEARCH    = NO
+#---------------------------------------------------------------------------
+# configuration options related to the LaTeX output
+#---------------------------------------------------------------------------
+GENERATE_LATEX         = YES
+LATEX_OUTPUT           = latex
+LATEX_CMD_NAME         = latex
+MAKEINDEX_CMD_NAME     = makeindex
+COMPACT_LATEX          = NO
+EXTRA_PACKAGES         = 
+LATEX_HEADER           = MYPATH/ORCHIDEE/DOC/header.tex
+LATEX_FOOTER           = MYPATH/ORCHIDEE/DOC/footer.tex
+PDF_HYPERLINKS         = YES
+LATEX_HIDE_INDICES     = NO
+LATEX_SOURCE_CODE      = 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        = YES
+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        = NO
+PERL_PATH              = /usr/bin/perl
+#---------------------------------------------------------------------------
+# Configuration options related to the dot tool   
+#---------------------------------------------------------------------------
+CLASS_DIAGRAMS         = YES
+MSCGEN_PATH            = 
+HIDE_UNDOC_RELATIONS   = NO
+HAVE_DOT               = YES
+DOT_NUM_THREADS        = 0
+DOT_FONTNAME           = Helvetica
+DOT_FONTSIZE           = 10
+DOT_FONTPATH           =
+CLASS_GRAPH            = YES
+COLLABORATION_GRAPH    = YES
+GROUP_GRAPHS           = YES
+UML_LOOK               = YES
+TEMPLATE_RELATIONS     = YES
+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           = MYPATH/ORCHIDEE/DOC/DOT
+MSCFILE_DIRS           =
+DOT_GRAPH_MAX_NODES    = 50
+MAX_DOT_GRAPH_DEPTH    = 1000
+DOT_TRANSPARENT        = NO
+DOT_MULTI_TARGETS      = YES
+GENERATE_LEGEND        = YES
+DOT_CLEANUP            = YES
+#---------------------------------------------------------------------------
+#- ALIAS ORCHDIEE
+#---------------------------------------------------------------------------
+ALIASES += Bold{1}="<b>\1</b>"
+ALIASES += Emph{1}="<em>\1</em>"
Index: branches/publications/ORCHIDEE_CAN_NHA/ORCHIDEE_CeCILL.LIC
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/ORCHIDEE_CeCILL.LIC	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/ORCHIDEE_CeCILL.LIC	(revision 7236)
@@ -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: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-MPI.fcm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-MPI.fcm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-MPI.fcm	(revision 7236)
@@ -0,0 +1,17 @@
+%AR                  ar
+%MAKE                gmake
+%FPP                 cpp
+%COMPILER            /usr/local/bin/mpif90 
+%LINK                /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
+%BASE_LD             -g
+%MPI_FFLAGS          
+%MPI_LD              
+%OMP_FFLAGS          
+%OMP_LD              
+
Index: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-MPI.path
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-MPI.path	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-MPI.path	(revision 7236)
@@ -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: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-PW6_VARGAS.fcm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-PW6_VARGAS.fcm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-PW6_VARGAS.fcm	(revision 7236)
@@ -0,0 +1,15 @@
+%COMPILER            xlf_r
+%LINK                mpxlf_r
+%AR                  ar
+%MAKE                gmake
+%FPP_FLAGS           -P -I/usr/local/pub/FFTW/3.2/include
+%FPP_DEF             NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_FFTW
+%BASE_FFLAGS         -qautodbl=dbl4 -qxlf90=autodealloc -qmaxmem=-1 -qzerosize -I/usr/local/pub/FFTW/3.2/include
+%PROD_FFLAGS         -O3
+%DEV_FFLAGS          -O2 -qfullpath -qinitauto=7FBFFFFF -qfloat=nans -qflttrap=overflow:zerodivide:invalid:enable -qsigtrap
+%DEBUG_FFLAGS        -g -qfullpath -qnooptimize -qinitauto=7FBFFFFF  -qfloat=nans -qflttrap=overflow:zerodivide:invalid:enable -qsigtrap -qcheck
+%MPI_FFLAGS          -I/usr/lpp/ppe.poe/include/thread64
+%OMP_FFLAGS          -qsmp=omp
+%BASE_LD             -lessl -L/usr/local/pub/FFTW/3.2/lib -lfftw3
+%MPI_LD              
+%OMP_LD              -qsmp=omp
Index: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-PW6_VARGAS.path
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-PW6_VARGAS.path	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-PW6_VARGAS.path	(revision 7236)
@@ -0,0 +1,4 @@
+set NETCDF_LIBDIR=/usr/local/pub/NetCDF/3.6.2/lib
+set NETCDF_INCDIR=/usr/local/pub/NetCDF/3.6.2/include
+set IOIPSL_INCDIR=../../../lib
+set IOIPSL_LIBDIR=../../../lib
Index: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-SX8_MERCURE.fcm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-SX8_MERCURE.fcm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-SX8_MERCURE.fcm	(revision 7236)
@@ -0,0 +1,16 @@
+%AR                  sxar
+%MAKE                make
+%COMPILER            sxmpif90
+%LINK                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 
+%BASE_LD             -size_t64 -lblas
+%MPI_FFLAGS          " "
+%MPI_LD              " "
+%OMP_FFLAGS          -P openmp
+%OMP_LD              -P openmp  -Wl,"-ZL 8G"
+
Index: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-SX8_MERCURE.path
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-SX8_MERCURE.path	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-SX8_MERCURE.path	(revision 7236)
@@ -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: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_ADA.fcm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_ADA.fcm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_ADA.fcm	(revision 7236)
@@ -0,0 +1,16 @@
+%COMPILER            mpiifort
+%LINK                mpiifort
+%AR                  ar
+%MAKE                gmake
+%FPP_FLAGS           -P -traditional
+%FPP_DEF             
+%BASE_FFLAGS         -integer-size 32 -real-size 64 -align all -mcmodel=large 
+%PROD_FFLAGS         -O2 -ip -fp-model strict -axAVX,SSE4.2
+%DEV_FFLAGS          -p -g -O1 -fpe0 -traceback
+%DEBUG_FFLAGS        -p -g -O0 -fpe-all=0 -traceback -ftrapuv -fp-stack-check -check all -debug
+%MPI_FFLAGS
+%OMP_FFLAGS          -openmp -openmp-threadprivate compat
+%BASE_LD             -shared-intel -Wl,-rpath=/smplocal/pub/NetCDF/4.1.3/mpi/lib:/smplocal/pub/HDF5/1.8.9/par/lib 
+%MPI_LD
+%OMP_LD              -openmp
+
Index: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_ADA.path
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_ADA.path	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_ADA.path	(revision 7236)
@@ -0,0 +1,7 @@
+NETCDF_LIBDIR="${NETCDF_LDFLAGS:-/smplocal/pub/NetCDF/4.1.3/mpi/lib -lnetcdff -lnetcdf -lstdc++ -L/smplocal/pub/HDF5/1.8.9/par/lib -Bstatic -lhdf5_hl -lhdf5_fortran -lhdf5 -Bdynamic -lz}"
+NETCDF_INCDIR="${NETCDF_FFLAGS:-/smplocal/pub/HDF5/1.8.9/par/include -I/smplocal/pub/NetCDF/4.1.3/mpi/include}"
+IOIPSL_INCDIR=${ORCHDIR}/../../lib
+IOIPSL_LIBDIR=${ORCHDIR}/../../lib
+XIOS_INCDIR=${ORCHDIR}/../XIOS/inc
+XIOS_LIBDIR="${ORCHDIR}/../XIOS/lib -lxios"
+
Index: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_CURIE.fcm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_CURIE.fcm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_CURIE.fcm	(revision 7236)
@@ -0,0 +1,15 @@
+%COMPILER            mpif90
+%LINK                mpif90
+%AR                  ar
+%MAKE                gmake
+%FPP_FLAGS           -P -traditional
+%FPP_DEF             NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_MKL
+%BASE_FFLAGS         -i4 -r8 -auto -align all -I${MKLROOT}/include
+%PROD_FFLAGS         -O3 -fp-model precise
+%DEV_FFLAGS          -p -g -O2 -traceback -fp-stack-check -ftrapuv
+%DEBUG_FFLAGS        -p -g -traceback -fp-stack-check -ftrapuv -check bounds
+%MPI_FFLAGS
+%OMP_FFLAGS          -openmp -openmp-threadprivate compat 
+%BASE_LD             -i4 -r8 -auto $MKL_LIBS
+%MPI_LD
+%OMP_LD              -openmp
Index: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_CURIE.path
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_CURIE.path	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_CURIE.path	(revision 7236)
@@ -0,0 +1,7 @@
+NETCDF_LIBDIR="$NETCDF_LIB_DIR -lnetcdff -lnetcdf -lstdc++"
+NETCDF_INCDIR=$NETCDF_INC_DIR
+IOIPSL_INCDIR=${ORCHDIR}/../../lib
+IOIPSL_LIBDIR=${ORCHDIR}/../../lib
+XIOS_INCDIR=${ORCHDIR}/../XIOS/inc
+XIOS_LIBDIR="${ORCHDIR}/../XIOS/lib -lxios"
+
Index: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_TITANE.fcm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_TITANE.fcm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_TITANE.fcm	(revision 7236)
@@ -0,0 +1,15 @@
+%COMPILER            mpif90
+%LINK                mpif90
+%AR                  ar
+%MAKE                gmake
+%FPP_FLAGS           -P -traditional
+%FPP_DEF             NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_MKL
+%BASE_FFLAGS         -i4 -r8 -automatic -align all -I${MKLROOT}/include
+%PROD_FFLAGS         -O3
+%DEV_FFLAGS          -p -g -O3 -traceback -fp-stack-check -ftrapuv
+%DEBUG_FFLAGS        -p -g -traceback
+%MPI_FFLAGS
+%OMP_FFLAGS          -openmp
+%BASE_LD             -p -i4 -r8 -automatic $MKL_LIBS
+%MPI_LD
+%OMP_LD              -openmp
Index: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_TITANE.path
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_TITANE.path	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-X64_TITANE.path	(revision 7236)
@@ -0,0 +1,5 @@
+set NETCDF_LIBDIR=$NETCDF_LIB_DIR
+set NETCDF_INCDIR=$NETCDF_INC_DIR
+set IOIPSL_INCDIR=../../../lib
+set IOIPSL_LIBDIR=../../../lib
+
Index: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-gfortran.fcm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-gfortran.fcm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-gfortran.fcm	(revision 7236)
@@ -0,0 +1,15 @@
+%COMPILER            gfortran
+%LINK                gfortran
+%AR                  ar
+%MAKE                make
+%FPP_FLAGS           -P -C -traditional
+%FPP_DEF             NC_DOUBLE
+%BASE_FFLAGS         -fdefault-real-8
+%PROD_FFLAGS         -O3 -funroll-all-loops
+%DEV_FFLAGS          -O
+%DEBUG_FFLAGS        -ffpe-trap=invalid,zero,overflow -fbounds-check -g3 -O0 -fstack-protector-all
+%MPI_FFLAGS
+%OMP_FFLAGS          
+%BASE_LD      
+%MPI_LD
+%OMP_LD              
Index: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-gfortran.path
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-gfortran.path	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-gfortran.path	(revision 7236)
@@ -0,0 +1,4 @@
+NETCDF_LIBDIR=/usr/local/lib
+NETCDF_INCDIR=/usr/local/include
+IOIPSL_INCDIR=${ORCHDIR}/../../lib
+IOIPSL_LIBDIR=${ORCHDIR}/../../lib
Index: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-ifort_LSCE.fcm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-ifort_LSCE.fcm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-ifort_LSCE.fcm	(revision 7236)
@@ -0,0 +1,15 @@
+%COMPILER            mpif90
+%LINK                mpif90
+%AR                  ar
+%MAKE                gmake
+%FPP_FLAGS           -P -traditional
+%FPP_DEF             NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_MKL
+%BASE_FFLAGS         -i4 -r8 -auto -align all -I${MKLROOT}/include -fp-model precise
+%PROD_FFLAGS         -O3 
+%DEV_FFLAGS          -p -g -O2 -traceback -fp-stack-check 
+%DEBUG_FFLAGS        -p -g -traceback -fp-stack-check -ftrapuv -check bounds
+%MPI_FFLAGS
+%OMP_FFLAGS          -openmp
+%BASE_LD             -i4 -r8 
+%MPI_LD
+%OMP_LD              -openmp
Index: branches/publications/ORCHIDEE_CAN_NHA/arch/arch-ifort_LSCE.path
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/arch/arch-ifort_LSCE.path	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/arch/arch-ifort_LSCE.path	(revision 7236)
@@ -0,0 +1,4 @@
+NETCDF_LIBDIR="-L/usr/local/lib -lnetcdff -lnetcdf"
+NETCDF_INCDIR=/usr/local/include
+IOIPSL_INCDIR=../../../lib
+IOIPSL_LIBDIR=../../../lib
Index: branches/publications/ORCHIDEE_CAN_NHA/bld.cfg
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/bld.cfg	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/bld.cfg	(revision 7236)
@@ -0,0 +1,82 @@
+# ----------------------- FCM extract configuration file -----------------------
+cfg::type                           bld
+cfg::version                        1.0
+
+
+# ------------------------------------------------------------------------------
+# Build information
+# ------------------------------------------------------------------------------
+
+
+inc arch.fcm
+inc config.fcm
+
+%ROOT_PATH         $PWD
+%CONFIG_PATH       %ROOT_PATH/.config
+%SRC_PATH          %ROOT_PATH
+
+
+src::global       %SRC_PATH/src_global
+src::parallel     %SRC_PATH/src_parallel
+src::sechiba      %SRC_PATH/src_sechiba
+src::stomate      %SRC_PATH/src_stomate
+src::parameters   %SRC_PATH/src_parameters
+src::orchidee_ol  %SRC_PATH/src_driver
+src::ext_src      %EXT_SRC
+
+bld::lib::global         orglob
+bld::lib::parallel       parallel
+bld::lib::sechiba        sechiba
+bld::lib::stomate        stomate
+bld::lib::parameters     parameters
+bld::lib::orchidee_ol    orchidee_ol
+bld::lib                 orchidee
+
+bld::target              liborglob.a libparallel.a libsechiba.a libstomate.a libparameters.a liborchidee.a
+bld::target              %EXEC
+bld::exe_dep             ext_src global parallel sechiba stomate parameters orchidee_ol
+
+dir::root            %CONFIG_PATH
+dir::lib             %ROOT_PATH/lib
+dir::bin             %ROOT_PATH/bin
+dir::inc             %ROOT_PATH/lib
+dir::tmp             %ROOT_PATH/tmp_src
+
+#search_src           1
+
+bld::tool::fc        %COMPILER 
+bld::tool::ld        %LINK
+bld::tool::ar        %AR
+bld::tool::make      %MAKE
+bld::tool::fflags    %FFLAGS %INCDIR
+bld::tool::ldflags   %LD_FFLAGS %LIBDIR -lioipsl -lnetcdf   
+
+bld::tool::cppflags  %FPP_FLAGS %INCDIR
+bld::tool::fppflags  %FPP_FLAGS %INCDIR
+bld::tool::fppkeys   %CPP_KEY
+
+
+# Pre-process code before analysing dependencies
+bld::pp              1
+infile_ext::f90 fpp::fpp9x::source
+
+# Ignore the following dependencies
+bld::excl_dep        inc::netcdf.inc
+bld::excl_dep        use::netcdf
+bld::excl_dep        h::netcdf.inc
+bld::excl_dep        h::mpif.h
+bld::excl_dep        inc::mpif.h
+bld::excl_dep        use::ioipsl
+bld::excl_dep        USE::defprec
+bld::excl_dep        USE::calendar
+bld::excl_dep        USE::xios
+
+# Don't generate interface files
+bld::tool::geninterface none
+
+# Allow ".inc" as an extension for CPP include files
+bld::infile_ext::inc  CPP::INCLUDE
+
+# extension for module output
+bld::outfile_ext::mod .mod
+bld::tool::SHELL   /bin/bash
Index: branches/publications/ORCHIDEE_CAN_NHA/makeorchidee_fcm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/makeorchidee_fcm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/makeorchidee_fcm	(revision 7236)
@@ -0,0 +1,422 @@
+#!/bin/bash
+
+#==============================================================================================================================\n
+#  MODULE 	: 
+# 
+#  CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+#
+#  LICENCE      : IPSL (2006)
+#  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+#
+# Author: Martial.Mancip
+# Contact: josefine.ghattas_at_ipsl.jussieu.fr
+# $Revision::                                   $ Revision of last commit
+# $Author::                                     $ Author of last commit
+# $Date::
+#
+# Modification:
+#   26/04/13, P. Maugis : comments and notice
+#   18/07/13, A. Cozic  : translate in bash to fit with idris and tgcc 
+#   01/10/13, J. Ghattas : add options full, job and ext_src
+#
+####################################################################################################
+
+####################################################################################################
+#
+# This script has several possible functions :
+#   1. Compiling ORCHIDEE
+#   2. Building of the documentation
+#
+#***************************************************************************************************
+#
+# command lines :
+#
+#   1) makeorchidee_fcm   [ -parallel  PARALLEL_TYPE ]
+#                         [ -driver ]
+#                         [ -arch ARCHitecture ]
+#                         [ -prod | -dev | -debug ]
+#
+#   2) makeorchidee_fcm   [ -doc | -doc_para ] ## actually doc_para is commented
+#                         [ -rmdoc ]
+#                         [ -doc_tree ]
+#
+
+parallel_mode=NONE
+is_driver_opt=FALSE
+is_arch_opt=FALSE 
+is_compile_opt=FALSE
+clean=FALSE
+default_compile_flags="%PROD_FFLAGS"
+xios=FALSE
+full=""
+job=1
+ext_src=""
+
+export P_P=""
+export SECTIONS_PARA=""
+
+ORCHDIR=`/bin/pwd`
+fcm_path=$ORCHDIR/tools/FCM_V1.2/bin
+
+while (($# > 0))
+  do
+  case $1 in
+      "-h") cat <<fin
+
+########################################################################
+# 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
+    ( none | NONE | seq ) : sequential mode (default)
+
+[ -driver ] : compilation of ORCHIDEE driver if equal TRUE
+
+[ -arch ARCHitecture ] : if TRUE, change architecture for ARCHitecture
+
+[ -xios ] : compilation with XIOS
+
+[ -noxios ] : compilation without XIOS
+
+[ -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)
+
+| -full ] : activate full recompiling 
+
+| -clean ] : delete all files produceed during previous compilation
+
+[ -j x ] : activate parallel compiling on x task, default 1 task
+
+[ -ext_src path] : path to an additional set of routines to compile with the model
+
+[ -doc ] : generate documentation with Doxygen (exit after doc computation)
+
+[ -doc_para ] : generate documentation with Doxygen with parallelization calls
+
+[ -rmdoc ] : remove documentation directory (before generate new documentation with Doxygen ?)
+
+[ -doc_tree ] : generate tree of ORCHIDEE directories for each file
+
+fin
+    exit;;
+########################################################################
+# Lecture des differentes options
+########################################################################
+
+    "-parallel")
+        parallel_mode=$2 ; shift ; shift ;; 
+                       
+    "-driver")
+         is_driver_opt=TRUE
+        shift ;;
+
+    "-arch")
+        is_arch_opt=TRUE
+        arch="$2" ; shift ; shift ;;
+
+    "-xios")
+         xios=TRUE
+        shift ;;
+
+    "-noxios")
+         xios=FALSE
+        shift ;;
+
+    "-prod")
+        is_compile_opt=TRUE
+        compile_flags="%PROD_FFLAGS"
+        shift ;;
+
+    "-dev")
+        is_compile_opt=TRUE
+        compile_flags="%DEV_FFLAGS"
+        shift ;;
+
+    "-debug")
+        is_compile_opt=TRUE
+        compile_flags="%DEBUG_FFLAGS"
+        shift ;;
+
+     "-j")
+        job="$2" ; shift ; shift ;;
+
+     "-full")
+        full='-full'
+        shift ;;
+
+     "-clean")
+        clean=TRUE
+        shift ;;
+
+      "-ext_src")
+        ext_src=$2 ; shift ; shift ;;
+
+#    "-doc_para")
+#        setenv P_P -DCPP_PARA
+#	setenv SECTIONS_PARA "-e s&ENABLED_SECTIONS\ *= &ENABLED_SECTIONS       = CPP_PARA&g"
+#	goto doc
+
+	"-doc")
+#####################################################################################################
+
+# 2) Building the documentation:
+# ------------------------------
+# We assume to start in the ORCHIDEE directory
+#
+#****  Directory structure:
+#
+# ..                       : parent of the start dir.
+#   -- ORCHIDEE            : ($MODELPATH), start directory
+#       - src_sechiba
+#       - src_stomate
+#       + DOC
+#       + webdoc
+#   -- IOIPSL
+#       - src
+#   ++ modeles_doc         : ($SRCPATH), source files for the documentation, emptied at start, temporary
+#
+#****  gawk scripts called :
+#
+# codeinc.awk              : encaspulates code parts in Doxygen documentation
+# codedox.awk              : transforms almost all comments in Doxygen comments for documentation
+# codealgo.awk             : emphasizes main algorithm description of each routine in their Doxygen documentation
+#
+#****
+        unalias cd
+
+	export REV=`svn info | grep vision | sed -e 's&.*vision.*: \([0-9]*\)&\1&' | head -n 1`
+	export TAG=`svn info | grep URL | sed -e 's&.*URL.*: svn://forge.ipsl.jussieu.fr/orchidee/\(.*\)&\1&' | head -n 1 | xargs dirname`
+       	cd ..
+
+	\rm -rf modeles_doc
+	export MODELPATH=${PWD}
+	\mkdir modeles_doc
+	export SRCPATH=${MODELPATH}/modeles_doc
+
+	find IOIPSL/src \( -not -path '*.svn*' \
+			-a \( -name '*.f90' -o -name "*.F90" -o -name "*.h" \) \) \
+		    -exec bash -c 'mkdir -p '${SRCPATH}'/$( dirname {} ); cp -p {} '${SRCPATH}'/$( dirname {} )' \;
+
+	find ORCHIDEE \( -not -path '*.svn*' \
+			-a \( -name '*.f90' -o -name "*.F90" -o -name "*.h" \) \) \
+		    -exec bash -c 'mkdir -p '${SRCPATH}'/$( dirname {} ); cp -p {} '${SRCPATH}'/$( dirname {} )' \;
+	cd ${SRCPATH}
+	# Use standard preprocessor to suppress all preproc directives
+	\find . -name "*.f90" -exec cpp -P -C -traditional -x assembler-with-cpp ${P_P} '{}' '{}'_ \;
+	\find . -name "*.f90" -print -exec mv -f '{}'_ '{}' \;
+
+	# use codeinc script to encaspulate code parts in Doxygen documentation
+	\find . -name "*.f90" -exec gawk -f ${MODELPATH}/ORCHIDEE/DOC/TOOLS/codeinc.awk '{}' \; > /dev/null
+	\find . -name "*.f90" -print -exec mv -f '{}'_preproc_codeinc '{}' \;
+	# use codedox script to transform almost all comments in Doxygen comments for documentation (use with care !)
+	\find . -name "*.f90" -exec gawk -f ${MODELPATH}/ORCHIDEE/DOC/TOOLS/codedox.awk '{}' \; > /dev/null
+	\find . -name "*.f90" -print -exec mv -f '{}'_preproc_codedox '{}' \;
+
+	# use codealgo script to emphasize main algorithm description of each routine in their Doxygen documentation
+	\find . -name "*.f90" -exec gawk -f ${MODELPATH}/ORCHIDEE/DOC/TOOLS/codealgo.awk '{}' \; > /dev/null
+	\find . -name "*.f90" -print -exec mv -f '{}'_preproc_codealgo '{}' \;
+        cd ../ORCHIDEE
+	\rm -f ${MODELPATH}/ORCHIDEE/Doxyfile_ORCHIDEE
+	sed -e 's&MYPATH&'${MODELPATH}'&g' -e 's&SRCPATH&'${SRCPATH}'&g' \
+            -e 's&MYTAG&'${TAG}'&' -e 's&MYREV&'${REV}'&' ${SECTIONS_PARA} \
+            ${MODELPATH}/ORCHIDEE/Doxyfile_ORCHIDEE.init > ${MODELPATH}/ORCHIDEE/Doxyfile_ORCHIDEE
+	\rm -f ${MODELPATH}/ORCHIDEE/DOC/header.tex
+	sed -e "s&MYTAG&${TAG}&" -e "s&MYREV&${REV}&" \
+            ${MODELPATH}/ORCHIDEE/DOC/header.tex.init > ${MODELPATH}/ORCHIDEE/DOC/header.tex
+	ln -s /home/orchidee01/maignan/ORCHIDEE/DOC/IMAGES ${MODELPATH}/ORCHIDEE/DOC/IMAGES
+	gmake doc
+	gmake bib
+	gmake toc
+	\rm -rf ${MODELPATH}/ORCHIDEE/webdoc
+	\mv ${MODELPATH}/ORCHIDEE/docs/html ${MODELPATH}/ORCHIDEE/webdoc
+	gmake index
+	gmake toc
+	\rm -rf ${SRCPATH}
+	cp ${MODELPATH}/ORCHIDEE/docs/latex/refman.pdf ${MODELPATH}/ORCHIDEE/documentation.pdf
+	exit
+        shift ;;
+
+
+     "-rmdoc")
+	\rm -rf docs
+        shift ;;
+
+     "-doc_tree") 
+        cd ..
+	find ORCHIDEE \( -not -path '*.svn*' \
+			-a \( -name '*.f90' -o -name "*.F90" -o -name "*.h" \) \) \
+		    -exec bash -c 'mkdir -p ORCHIDEE/DOC/$( dirname {} )/$( echo $( basename {} ) | sed -e "s/\..*//" )' \;
+	cd ORCHIDEE
+        shift ;;
+
+    *)
+        echo "unknown option "$1" , exiting..."
+        exit 
+   esac
+done
+
+#####################################################################################################
+# 0) Clean directory from files produced during previous compilation
+# --------------------------------------
+if [[ "$clean" == "TRUE" ]] ; then
+    rm -fr .config
+    rm -fr lib
+    rm -fr bin
+    rm -fr tmp_src
+    rm -f ../../lib/intersurf.mod
+    rm -f ../../lib/liborglob.a 
+    rm -f ../../lib/libparallel.a 
+    rm -f ../../lib/libsechiba.a 
+    rm -f ../../lib/libstomate.a 
+    rm -f ../../lib/libparameters.a 
+    rm -f ../../lib/liborchidee_ol.a
+    rm -f ../../lib/liborchidee.a
+
+    exit
+fi
+
+# 1) Compilation du code direct avec fcm
+# --------------------------------------
+# Add fcm in environement path
+export PATH=${fcm_path}:${PATH}
+
+#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
+  fi
+  
+  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
+  fi
+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
+  fi
+
+  if [[ ! -e arch.fcm ]]
+ then
+    echo "architecture file : << arch.path >> is missing, exiting...."
+    exit
+  fi
+fi
+  
+# set compiler flags
+FFLAGS="%BASE_FFLAGS"
+LD_FFLAGS="%BASE_LD"
+CPP_KEY="%FPP_DEF"
+
+# set compiler flags for optimisation
+if [[ "$is_compile_opt" == "FALSE" ]]
+ then
+  compile_flags=$default_compile_flags
+fi
+FFLAGS=${FFLAGS}" "$compile_flags
+LD_FFLAGS=${LD_FFLAGS}" "$compile_flags
+
+# set compiler flags for parallelism
+echo "parallel_mode = "${parallel_mode}
+
+if [[ "$parallel_mode" == "mpi" ]] || [[ "$parallel_mode" == "MPI" ]]
+then 
+    FFLAGS="${FFLAGS} %MPI_FFLAGS"
+    LD_FFLAGS="%MPI_LD ${LD_FFLAGS}"
+    CPP_KEY="CPP_PARA ${CPP_KEY}"
+elif [[ "$parallel_mode" == "omp" ]] || [[ "$parallel_mode" == "OMP" ]]
+then
+    FFLAGS="${FFLAGS} %OMP_FFLAGS"
+    LD_FFLAGS="%OMP_LD ${LD_FFLAGS}"
+    CPP_KEY="CPP_OMP CPP_PARA ${CPP_KEY}"
+elif [[ "$parallel_mode" == "mpi_omp" ]] || [[ "$parallel_mode" == "MPI_OMP" ]]
+then
+    FFLAGS="${FFLAGS} %MPI_FFLAGS %OMP_FFLAGS"
+    LD_FFLAGS="%MPI_LD %OMP_LD ${LD_FFLAGS}"
+    CPP_KEY="CPP_OMP CPP_PARA ${CPP_KEY}"
+elif [[ "$parallel_mode" == "none" ]] || [[ "$parallel_mode" == "NONE" ]] || [[ "$parallel_mode" == "seq" ]]
+then
+    echo "Compiling for sequential mode"
+else
+    echo "This option for parallel_mode is not implemeted. Choose between mpi, omp, mpi_omp and none."
+    exit
+fi
+
+
+if [[ "$xios" == "TRUE" ]] 
+  then
+    CPP_KEY="XIOS ${CPP_KEY}"
+fi
+
+# set target
+TARGET=liborchidee.a
+if [[ "$is_driver_opt" == "TRUE" ]] 
+then
+    TARGET="liborchidee_ol.a dim2_driver.exe teststomate.exe forcesoil.exe"
+fi
+
+source ./arch.path
+
+# build config file
+config_fcm="config.fcm"
+rm -f $config_fcm
+touch $config_fcm
+
+echo "%ARCH          $arch"                             >> $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
+if [[ "$xios" == "TRUE" ]]
+  then
+   echo "%INCDIR        -I$NETCDF_INCDIR -I$IOIPSL_INCDIR -I$XIOS_INCDIR" >> $config_fcm
+   echo "%LIBDIR        -L$NETCDF_LIBDIR -L$IOIPSL_LIBDIR -L$XIOS_LIBDIR" >> $config_fcm
+else
+   echo "%INCDIR        -I$NETCDF_INCDIR -I$IOIPSL_INCDIR" >> $config_fcm
+   echo "%LIBDIR        -L$NETCDF_LIBDIR -L$IOIPSL_LIBDIR" >> $config_fcm
+fi
+echo "%EXT_SRC       $ext_src"                          >> $config_fcm
+
+
+# Delete interface module from modipsl/lib directory
+rm -f ../../lib/intersurf.mod
+
+# Do the compiling
+fcm build -j $job $full
+
+# Copy into modipsl/lib directory libraries and interface module needed by LMDZ
+cp lib/lib*a ../../lib/.
+cp lib/intersurf.mod ../../lib/.
+
+# Copy executables to modipsl/bin directory
+if [[ "$is_driver_opt" == "TRUE" ]] 
+then
+    cp bin/dim2_driver.exe ../../bin/orchidee_ol
+    cp bin/teststomate.exe ../../bin/teststomate
+    cp bin/forcesoil.exe ../../bin/forcesoil
+fi
+
+
Index: branches/publications/ORCHIDEE_CAN_NHA/src_driver/AA_make
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_driver/AA_make	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_driver/AA_make	(revision 7236)
@@ -0,0 +1,66 @@
+#-
+#- $Id$
+#-
+MODS1 = dim2_driver.f90 \
+        weather.f90 \
+        readdim2.f90 \
+        teststomate.f90 \
+        forcesoil.f90 \
+        getprec.f90
+
+all : orchidee_ol teststomate forcesoil
+
+orchidee_ol:
+	$(M_K) m_orchidee_ol
+	@echo orchidee_ol is OK
+
+m_orchidee_ol: $(BINDIR)/orchidee_ol
+$(BINDIR)/orchidee_ol: \
+  $(SXIOIPSL_LIB) $(SXPARAM_LIB) $(SXPARALLEL_LIB) $(SXORGLOB_LIB) $(SXSTOMATE_LIB) $(SXSECHIBA_LIB) \
+  $(MODEL_LIB)(weather.o) $(MODEL_LIB)(readdim2.o) \
+  $(MODEL_LIB)(dim2_driver.o)
+	$(A_G) $(MODEL_LIB) dim2_driver.o
+	$(F_L) -o $(BINDIR)/orchidee_ol dim2_driver.o $(L_O) \
+          $(SXMODEL_LIB) $(SXSECHIBA_LIB) $(SXSTOMATE_LIB) \
+          $(SXPARALLEL_LIB) $(SXORGLOB_LIB) $(SXPARAM_LIB) $(SXIOIPSL_LIB) $(NCDF_LIB) 
+	$(RM) dim2_driver.o
+
+teststomate:
+	$(M_K) m_teststomate
+	@echo teststomate is OK
+
+m_teststomate: $(BINDIR)/teststomate
+$(BINDIR)/teststomate: \
+  $(SXIOIPSL_LIB) $(SXPARALLEL_LIB) $(SXPARAM_LIB) $(SXORGLOB_LIB) $(SXSTOMATE_LIB) $(SXSECHIBA_LIB) \
+  $(MODEL_LIB)(teststomate.o)
+	$(A_G) $(MODEL_LIB) teststomate.o
+	$(F_L) -o $(BINDIR)/teststomate teststomate.o $(L_O) \
+          $(SXMODEL_LIB) $(SXSECHIBA_LIB) $(SXSTOMATE_LIB) \
+          $(SXPARALLEL_LIB) $(SXORGLOB_LIB) $(SXPARAM_LIB) $(SXIOIPSL_LIB) $(NCDF_LIB)
+	$(RM) teststomate.o
+
+forcesoil:
+	$(M_K) m_forcesoil
+	@echo m_forcesoil is OK
+
+m_forcesoil: $(BINDIR)/forcesoil
+$(BINDIR)/forcesoil: \
+  $(SXIOIPSL_LIB) $(SXPARALLEL_LIB) $(SXPARAM_LIB) $(SXORGLOB_LIB) $(SXSTOMATE_LIB) $(SXSECHIBA_LIB) \
+  $(MODEL_LIB)(forcesoil.o)
+	$(A_G) $(MODEL_LIB) forcesoil.o
+	$(F_L) -o $(BINDIR)/forcesoil forcesoil.o $(L_O) \
+          $(SXMODEL_LIB) $(SXSECHIBA_LIB) $(SXSTOMATE_LIB) \
+          $(SXPARALLEL_LIB) $(SXORGLOB_LIB) $(SXPARAM_LIB) $(SXIOIPSL_LIB) $(NCDF_LIB)
+	$(RM) forcesoil.o
+
+libioipsl:
+	(cd ../../IOIPSL/src; $(M_K) -f Makefile)
+
+clean:
+	$(RM) $(MODEL_LIB)
+
+$(MODEL_LIB)(%.o): %.f90
+	$(F_C) $(F_O) -I$(NCDF_INC) $*.f90
+	$(A_C) $(MODEL_LIB) $*.o
+	$(RM) $*.o
+
Index: branches/publications/ORCHIDEE_CAN_NHA/src_driver/AA_make.ldef
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_driver/AA_make.ldef	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_driver/AA_make.ldef	(revision 7236)
@@ -0,0 +1,49 @@
+#-
+#- $Id$
+#-
+SHELL = /bin/sh
+#---------------------------------------------------------------------
+LIBDIR = ../../../lib
+MODDIR = $(LIBDIR)
+BINDIR = ../../../bin
+SCPDIR = ../../scripts
+ORDIR  = ..
+#---------------------------------------------------------------------
+MODEL_LIB = $(LIBDIR)/liborchidee.a
+SXMODEL_LIB = $(MODEL_LIB)
+#-Q- sxnec SXMODEL_LIB = $(LIBDIR)/libsxorchidee.a
+#-Q- sx6nec SXMODEL_LIB = $(LIBDIR)/libsxorchidee.a
+#-Q- sx8brodie SXMODEL_LIB = $(LIBDIR)/libsxorchidee.a
+#-
+IOIPSL_LIB = $(LIBDIR)/libioipsl.a
+SXIOIPSL_LIB = $(IOIPSL_LIB)
+#-
+PARAM_LIB = $(LIBDIR)/libparameters.a
+SXPARAM_LIB = $(PARAM_LIB)
+#-Q- sxnec SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
+#-Q- sx6nec SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
+#-Q- sx8brodie SXPARAM_LIB = $(LIBDIR)/libsxparameters.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- sx8brodie SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.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- sx8brodie SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a
+#-
+SECHIBA_LIB = $(LIBDIR)/libsechiba.a
+SXSECHIBA_LIB = $(SECHIBA_LIB)
+#-Q- sxnec SXSECHIBA_LIB = $(LIBDIR)/libsxsechiba.a
+#-Q- sx6nec SXSECHIBA_LIB = $(LIBDIR)/libsxsechiba.a
+#-Q- sx8brodie SXSECHIBA_LIB = $(LIBDIR)/libsxsechiba.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- sx8brodie SXSTOMATE_LIB = $(LIBDIR)/libsxstomate.a
Index: branches/publications/ORCHIDEE_CAN_NHA/src_driver/dim2_driver.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_driver/dim2_driver.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_driver/dim2_driver.f90	(revision 7236)
@@ -0,0 +1,1776 @@
+PROGRAM driver
+!< $HeadURL$ 
+!< $Date$
+!< $Author$
+!< $Revision$
+!- IPSL (2006)
+!-  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!---------------------------------------------------------------------
+!- This PROGRAM is the driver of the dim2 version of SECHIBA. It's
+!- main use is for PILPS type experiments. To run it you need to have
+!- the following software :
+!- - SECHIBA
+!- - ioipsl
+!- - netcdf
+!- - F90 compiler
+!- - tk (optional but very useful for configuring the model)
+!- Obviously also the associated Makefiles.
+!-
+!- The forcing data needs to be in netCDF format and should
+!- contain the following variables :
+!- - Incoming SW radiation
+!- - Incoming LW radiation
+!- - Precipitation
+!- - Air temperature at a reference level
+!- - Air humidity at the same level
+!- - wind at the same level
+!- - surface pressure
+!-
+!- Once you have all this and compiled the model you can configure it.
+!- Type make config and set all the values presented in the menu.
+!- This tool will create a run.def which will be used by the model.
+!- The run.def can also be edited by hand but it is more tedious.
+!- Once this run.def is created the model is ready to run.
+!---------------------------------------------------------------------
+  USE netcdf
+  USE ioipsl_para
+  USE grid
+  USE intersurf,  ONLY : intersurf_main
+  USE constantes
+  USE readdim2
+  USE mod_orchidee_para
+  USE timer
+!-
+  IMPLICIT NONE
+!-
+  INTEGER :: iim, jjm, llm
+  INTEGER :: im, jm, lm, tm, is, force_id, itest, jtest
+  REAL :: dt, dt_force, dt_rest, date0, date0_rest
+  REAL :: zlflu
+  REAL :: alpha
+!-
+  REAL, ALLOCATABLE, DIMENSION(:,:) :: &
+ & swdown, sinang, precip_rain, precip_snow, tair_obs, u, v, &
+ & qair_obs, pb, lwdown, &
+ & eair_obs, zlev_vec, zlevuv_vec, relax
+!- Variables which are forcings for SECHIBA
+  REAL, ALLOCATABLE, DIMENSION(:,:) :: &
+ & petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag, &
+ & for_u, for_v, for_swnet, for_swdown, for_sinang, for_lwdown, &
+ & for_psurf, for_qair, for_tair, for_eair, &
+ & for_ccanopy, for_rau
+!!$, tmp_eair, tmp_tair, &
+!!$ & tmp_qair, tmp_pb
+!-
+  REAL, ALLOCATABLE, DIMENSION(:,:) :: &
+ & for_contfrac, old_zlev, old_qair, old_eair, tsol_rad, vevapp, &
+ & temp_sol_NEW, temp_sol_old, qsurf, dtdt, coastalflow, riverflow, &
+ & fluxsens, fluxlat, emis, z0
+!!$, epot_sol
+!-
+  INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: for_neighbours
+!-
+  REAL, ALLOCATABLE, DIMENSION(:,:,:) :: for_resolution
+!-
+  REAL, ALLOCATABLE, DIMENSION(:,:,:) :: albedo
+  REAL, ALLOCATABLE, DIMENSION(:,:) :: albedo_vis
+  REAL, ALLOCATABLE, DIMENSION(:,:) :: albedo_nir
+!-
+  INTEGER, ALLOCATABLE, DIMENSION(:) :: kindex
+  REAL, ALLOCATABLE, DIMENSION(:,:) :: lon, lat
+  REAL, ALLOCATABLE, DIMENSION(:)   :: tmplev
+!-
+  REAL :: old_tair
+  REAL :: atmco2
+  INTEGER :: nbindex
+  REAL :: julian, ss
+  INTEGER :: yy, mm, dd
+!-
+  LOGICAL :: relaxation
+!-
+  CHARACTER(LEN=80) :: filename, driv_restname_in, driv_restname_out
+  CHARACTER(LEN=30) :: time_str, var_name
+!-
+  INTEGER :: it, istp, istp_old, rest_id, it_force
+!-
+  INTEGER :: split, split_start, nb_spread, for_offset
+  INTEGER :: itau_dep, itau_dep_rest, itau_fin, itau_skip, itau_len
+
+  INTEGER,DIMENSION(2) :: ml
+!-
+  LOGICAL :: last_CALL, first_CALL, debug
+  LOGICAL :: no_inter, inter_lin, netrad_cons
+!-
+  ! to check variables passed to intersurf
+  INTEGER :: ik
+  INTEGER :: i,j
+  LOGICAL, PARAMETER :: longprint = .FALSE.
+
+  REAL, ALLOCATABLE, DIMENSION(:,:) :: &
+  & fluxsens_g,vevapp_g,old_zlev_g,old_qair_g,old_eair_g,for_rau_g, &
+  & petAcoef_g, petBcoef_g,peqAcoef_g,peqBcoef_g,albedo_g,z0_g
+  LOGICAL :: Flag
+  LOGICAL :: driver_reset_time
+
+  REAL :: fill_init
+
+  fill_init=REAL(nf90_fill_real,r_std)
+  CALL ioconf_expval(val_exp)
+!-
+! Init parallelism
+
+  CALL Init_orchidee_para
+  CALL init_timer
+  CALL start_timer(timer_global)
+  CALL start_timer(timer_mpi)
+ 
+! driver only for process root
+  
+!---------------------------------------------------------------------
+!-
+! set debug to have more information
+!-
+  !Config Key   = DEBUG_INFO
+  !Config Desc  = Flag for debug information
+  !Config If    = [-]
+  !Config Def   = n
+  !Config Help  = This option allows to switch on the output of debug
+  !Config         information without recompiling the code.
+  !Config Units = [FLAG] 
+!-
+  debug = .FALSE.
+  CALL getin_p('DEBUG_INFO',debug)
+!=====================================================================
+!- 1.0 This section defines the general set-up of the experiment :
+!-   - Forcing data to be used with its time step
+!-   - Restart file to be used
+!-   - The time step that will be used
+!-   - The starting date of the simulation
+!-   - Length of integration
+!-   - Basic flags for SSIPSL
+!=====================================================================
+!- 1.1 Initialize the driving variables. It essentialy gets the mode
+!-     used and the size of the driving variables.
+!=====================================================================
+  IF (debug) WRITE(numout,*) 'Reading name of the forcing file'
+!- 
+ !Config Key   = FORCING_FILE
+ !Config Desc  = Name of file containing the forcing data
+ !Config If    = [-]
+ !Config Def   = forcing_file.nc
+ !Config Help  = This is the name of the file which should be opened
+ !Config         for reading the forcing data of the dim0 model.
+ !Config         The format of the file has to be netCDF and COADS
+ !Config         compliant.
+ !Config Units = [FILE] 
+!- 
+  filename='forcing_file.nc'
+  CALL getin_p('FORCING_FILE',filename)
+!-
+  IF (debug) WRITE(numout,*) 'Opening forcing file'
+!-
+! We call flininfo to obtain the dimensions
+! of iim, jjm and others.
+! This information will allow us to allocate all the space needed.
+!-
+  CALL forcing_info &
+ &  (filename, iim, jjm, llm, tm, date0, dt_force, force_id) 
+!-
+  WRITE(numout,*) 'Out of flininfo : date0 ', date0, &
+       'iim, jjm, llm, tm',iim,jjm,llm,tm,' dt_force ',dt_force
+!-
+  CALL init_ioipsl_para
+!-
+  IF (debug) THEN
+    WRITE(numout,*) 'Allocate memory for the driver :', iim, jjm, llm
+  ENDIF
+!-
+  ALLOCATE (tmplev(llm)) 
+  tmplev(llm)=zero
+  ALLOCATE &
+ & (swdown(iim,jjm), sinang(iim,jjm), precip_rain(iim,jjm), precip_snow(iim,jjm), &
+ &  tair_obs(iim,jjm), u(iim,jjm), v(iim,jjm), qair_obs(iim,jjm), &
+ &  pb(iim,jjm), lwdown(iim,jjm), &
+ &  eair_obs(iim,jjm), zlev_vec(iim,jjm), zlevuv_vec(iim,jjm), relax(iim,jjm))
+!- 
+  ALLOCATE &
+ & (petAcoef(iim,jjm), peqAcoef(iim,jjm), &
+ &  petBcoef(iim,jjm), peqBcoef(iim,jjm), &
+ &  cdrag(iim,jjm), for_u(iim,jjm), for_v(iim,jjm), &
+ &  for_swnet(iim,jjm), for_swdown(iim,jjm), for_sinang(iim,jjm), for_lwdown(iim,jjm), &
+ &  for_psurf(iim,jjm), for_qair(iim,jjm), for_tair(iim,jjm), &
+ &  for_eair(iim,jjm), for_ccanopy(iim,jjm), for_rau(iim,jjm))
+!!$, &
+!!$ &  tmp_eair(iim,jjm), tmp_tair(iim,jjm), &
+!!$ &  tmp_qair(iim,jjm), tmp_pb(iim,jjm))
+!-
+  ALLOCATE &
+ & (for_contfrac(iim,jjm), for_neighbours(iim,jjm,8), for_resolution(iim,jjm,2), &
+ &  old_zlev(iim,jjm), old_qair(iim,jjm), old_eair(iim,jjm), &
+ &  tsol_rad(iim,jjm), vevapp(iim,jjm), &
+ &  temp_sol_NEW(iim,jjm), temp_sol_old(iim,jjm), &
+ &  dtdt(iim,jjm), coastalflow(iim,jjm), riverflow(iim,jjm), &
+ &  fluxsens(iim,jjm), fluxlat(iim,jjm), emis(iim,jjm), &
+ &  z0(iim,jjm), qsurf(iim,jjm))
+!!$, epot_sol(iim,jjm)
+!-
+  ALLOCATE(albedo(iim,jjm,2))
+  ALLOCATE(albedo_vis(iim,jjm),albedo_nir(iim,jjm))
+!-
+  ALLOCATE(kindex(iim*jjm))
+  ALLOCATE(lon(iim,jjm), lat(iim,jjm))
+!-- 
+  swdown(:,:) = fill_init
+  precip_rain(:,:) = 0.0
+  precip_snow(:,:) = 0.0
+  tair_obs(:,:) = 0.0
+  u(:,:) = fill_init
+  v(:,:) = fill_init
+  qair_obs(:,:) = fill_init
+  pb(:,:) = fill_init
+  lwdown(:,:) = fill_init
+  eair_obs(:,:) = fill_init
+  zlev_vec(:,:) = 0.0
+  zlevuv_vec(:,:) = 0.0
+  relax(:,:) = 0.0
+  petAcoef(:,:) = 0.0
+  peqAcoef(:,:) = 0.0
+  petBcoef(:,:) = 0.0
+  peqBcoef(:,:) = 0.0
+  cdrag(:,:) = 0.0
+  for_u(:,:) = fill_init
+  for_v(:,:) = fill_init
+  for_swnet(:,:) = fill_init
+  for_swdown(:,:) = fill_init
+  for_lwdown(:,:) = fill_init
+  for_psurf(:,:) = fill_init
+  for_qair(:,:) = fill_init
+  for_tair(:,:) = fill_init
+  for_eair(:,:) = fill_init
+  for_ccanopy(:,:) = 0.0
+  for_rau(:,:) = fill_init
+  for_contfrac(:,:) = 0.0
+  for_neighbours(:,:,:) = 0
+  for_resolution(:,:,:) = 0.0
+  old_zlev(:,:) = 0.0
+  old_qair(:,:) = 0.0
+  old_eair(:,:) = 0.0
+  tsol_rad(:,:) = 0.0
+  vevapp(:,:) = 0.0
+  temp_sol_NEW(:,:) = fill_init
+  temp_sol_old(:,:) = fill_init
+  dtdt(:,:) = 0.0
+  coastalflow(:,:) = 0.0
+  riverflow(:,:) = 0.0
+  fluxsens(:,:) = fill_init
+  fluxlat(:,:) = fill_init
+  emis(:,:) = 0.0
+  z0(:,:) = fill_init
+  qsurf(:,:) = 0.0
+  albedo(:,:,:) = fill_init
+  albedo_vis(:,:) = fill_init
+  albedo_nir(:,:) = fill_init
+  kindex(:) = 0
+  lon(:,:) = 0.0
+  lat(:,:) = 0.0
+!-
+! We need to know the grid.
+! Then we can initialize the restart files, and then we
+! can give read the restart files in the forcing subroutine.
+!-
+  CALL forcing_grid (iim,jjm,llm,lon,lat,init_f=.FALSE.)
+!=====================================================================
+!- 1.2 Time step to be used.
+!-     This is relative to the time step of the  forcing data
+!=====================================================================
+  IF ( .NOT. weathergen ) THEN
+     !Config Key   = SPLIT_DT
+     !Config Desc  = splits the timestep imposed by the forcing
+     !Config If    = NOT(WEATHERGEN)
+     !Config Def   = 12
+     !Config Help  = With this value the time step of the forcing
+     !Config         will be devided. In principle this can be run
+     !Config         in explicit mode but it is strongly suggested
+     !Config         to use the implicit method so that the
+     !Config         atmospheric forcing has a smooth evolution.
+     !Config Units = [-]
+!-
+     split = 12
+     CALL getin_p('SPLIT_DT', split)
+  ELSE
+     split = 1
+  ENDIF
+!-
+! The time step which is going to be used is computed
+! from the forcing time step and the user input.
+!-
+  IF (split > 0) THEN
+     dt = dt_force/split
+  ELSE
+     split = 1
+     dt = dt_force
+  ENDIF
+!=====================================================================
+!- 1.3 Initialize the restart file for the driver
+!=====================================================================
+  !Config Key   = RESTART_FILEIN
+  !Config Desc  = Name of restart to READ for initial conditions
+  !Config If    = [-]
+  !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.
+  !Config Units = [FILE]
+!-
+  driv_restname_in = 'NONE'
+  CALL getin_p('RESTART_FILEIN',driv_restname_in)
+  if (debug) WRITE(numout,*) 'INPUT RESTART_FILE : ',TRIM(driv_restname_in)
+!-
+  !Config Key   = RESTART_FILEOUT
+  !Config Desc  = Name of restart files to be created by the driver
+  !Config If    = [-]
+  !Config Def   = driver_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
+  !Config Units = [FILE]
+!-
+  driv_restname_out = 'driver_rest_out.nc'
+  CALL getin_p('RESTART_FILEOUT', driv_restname_out)
+  if (debug) WRITE(numout,*) 'OUTPUT RESTART_FILE : ',TRIM(driv_restname_out)
+!-
+! Set default values for the start and end of the simulation
+! in the forcing chronology.
+
+  CALL gather2D_mpi(lon,lon_g)
+  CALL gather2D_mpi(lat,lat_g)
+
+
+  !Config Key   = DRIVER_reset_time
+  !Config Desc  = Overwrite time values from the driver restart file
+  !Config If    = [-]
+  !Config Def   = FALSE
+  !Config Units = [FLAG]
+  
+  driver_reset_time=.FALSE.
+  CALL getin_p('DRIVER_reset_time', driver_reset_time)
+  IF (debug) WRITE(numout,*) 'driver_reset_time=',driver_reset_time
+
+  IF (is_root_prc) THEN
+     ! Set default values for the time variables
+     itau_dep_rest = 0
+     date0_rest = date0
+     dt_rest = dt
+
+     IF (debug) WRITE(numout,*) &
+          'Before driver restart file initialization : itau_dep_rest, date0_rest, dt_rest = ', &
+          itau_dep_rest, date0_rest, dt_rest
+
+     CALL restini &
+          (driv_restname_in, iim_g, jjm_g, lon_g, lat_g, llm, tmplev, &
+          driv_restname_out, itau_dep_rest, date0_rest, dt_rest, rest_id, driver_reset_time)
+
+     IF (debug) WRITE(numout,*) &
+          'After driver restart file initialization : itau_dep_rest, date0_rest, dt_rest = ', &
+          itau_dep_rest, date0_rest, dt_rest
+
+     IF (itau_dep_rest == 0 .OR. driver_reset_time) THEN
+        ! Restart file did not exist or we decide to overwrite time values in it.
+        ! Set time values to read the begining of the forcing file.
+        itau_dep=0
+        itau_fin=tm
+        date0_rest = date0
+     ELSE
+        ! Take time values from restart file
+        itau_dep = itau_dep_rest
+        itau_fin = itau_dep+tm
+     ENDIF
+
+     WRITE(numout,*) &
+          'Restart file initialized : itau_dep, itau_fin, date0_rest, dt_rest = ', &
+          itau_dep, itau_fin, date0_rest, dt_rest
+  ENDIF
+
+  ! Communicate values from root_prc to all the others
+  CALL bcast (itau_dep_rest)
+  CALL bcast (itau_dep)
+  CALL bcast (itau_fin)
+  CALL bcast (date0_rest)
+  CALL bcast (dt_rest)
+
+
+!=====================================================================
+!- 1.4 Here we do the first real reading of the driving. It only
+!-     gets a few variables.
+!=====================================================================
+
+! prepares kindex table from the information obtained
+! from the forcing data and reads some initial values for
+! temperature, etc.
+!- 
+  kindex(1) = 1
+!-
+  CALL forcing_READ &
+ &  (filename, rest_id, .TRUE., .FALSE., &
+ &   0, itau_dep, 0, split, nb_spread, netrad_cons, &
+ &   date0, dt_force, iim, jjm, lon, lat, zlev_vec, zlevuv_vec, tm, &
+ &   swdown, sinang, precip_rain, precip_snow, tair_obs, &
+ &   u, v, qair_obs, pb, lwdown, for_contfrac, for_neighbours, for_resolution, &
+ &   for_swnet, eair_obs, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag, for_ccanopy, &
+ &   kindex, nbindex, force_id)
+!-
+  WRITE (numout,*) ">> Number of land points =",nbindex
+  IF (nbindex == 0) THEN
+     WRITE(numout,*) "Limits : (W,E / N,S)", limit_west, limit_east, &
+          &                             limit_north, limit_south
+     CALL ipslerr_p ( 3, 'dim2_driver','number of land points error.', &
+          &         ' is zero !','stop driver')
+  ENDIF
+
+  jlandindex = (((kindex(1:nbindex)-1)/iim) + 1)
+  ilandindex = (kindex(1:nbindex) - (jlandindex(1:nbindex)-1)*iim)
+  IF (longprint) THEN
+     WRITE(numout,*) "kindex of land points : ", kindex(1:nbindex)
+     WRITE(numout,*) "index i of land points : ", ilandindex
+     WRITE(numout,*) "index j of land points : ", jlandindex 
+  ENDIF
+
+  im = iim; jm = jjm; lm = llm;
+  IF ( (iim > 1).AND.(jjm > 1) ) THEN
+    jtest = INT((kindex(INT(nbindex/2))-1)/iim)+1
+    itest = MAX( 1, kindex(INT(nbindex/2))-(jtest-1)*iim )
+  ELSE
+    jtest = 1
+    itest = 1
+  ENDIF
+  IF (debug) WRITE(numout,*) "test point in dim2_driver : ",itest,jtest
+!-
+  IF ((im /= iim) .AND. (jm /= jjm) .AND. (lm /= llm))  THEN
+    WRITE(numout,*) ' dimensions are not good. Verify FILE :'
+    WRITE(numout,*) ' filename = ',filename
+    WRITE(numout,*) ' im, jm, lm lus         = ', im, jm, lm
+    WRITE(numout,*) ' iim, jjm, llm demandes = ', iim, jjm, llm
+    STOP 'dim2_driver'
+  ENDIF  
+!=====================================================================
+!- 1.5  Configures the time-steps and other parameters 
+!-      of the run.
+!=====================================================================
+!-
+! If the time steping of the restart is different from the one
+! of the forcing we need to convert the itau_dep into the
+! chronology of the forcing. This ensures that the forcing will
+! start at the date of the restart file. Obviously the itau_fin
+! needs to be shifted as well !
+!-
+  IF ( (dt_rest /= dt_force).AND.(itau_dep > 1) ) THEN
+    itau_dep = NINT((itau_dep*dt_rest )/dt_force)
+    itau_fin = itau_dep+tm
+    if (debug) WRITE(numout,*) &
+ & 'The time steping of the restart is different from the one ',&
+ & 'of the forcing we need to convert the itau_dep into the ',&
+ & 'chronology of the forcing. This ensures that the forcing will ',&
+ & 'start at the date of the restart file. Obviously the itau_fin ',&
+ & 'needs to be shifted as well : itau_dep, itau_fin ', &
+ & itau_dep, itau_fin
+  ENDIF
+!-
+! Same things if the starting dates are not the same.
+! Everything should look as if we had only one forcing file !
+!-
+  IF (date0 /= date0_rest) THEN
+    WRITE(numout,*) 'date0_rest , date0 : ',date0_rest , date0
+    for_offset = NINT((date0_rest-date0)*one_day/dt_force)
+  ELSE
+    for_offset = 0
+  ENDIF
+  WRITE(numout,*) 'OFFSET FOR THE data read :', for_offset
+
+  CALL ioconf_startdate(date0_rest)
+!-
+  !Config Key   = TIME_SKIP
+  !Config Desc  = Time in the forcing file at which the model is started.
+  !Config If    = [-]
+  !Config Def   = 0
+  !Config Help  = This time give the point in time at which the model
+  !Config         should be started. If exists, the date of the restart file is use.
+  !Config         The FORMAT of this date can be either of the following :
+  !Config         n   : time step n within the forcing file
+  !Config         nS  : n seconds after the first time-step in the file
+  !Config         nD  : n days after the first time-step
+  !Config         nM  : n month after the first time-step (year of 365 days)
+  !Config         nY  : n years after the first time-step (year of 365 days)
+  !Config         Or combinations :
+  !Config         nYmM: n years and m month
+  !Config Units = [seconds, days, months, years]
+!-
+  itau_skip = 0
+  WRITE(time_str,'(I10)') itau_skip
+  CALL getin_p('TIME_SKIP', time_str)
+!-
+! Transform into itau
+!-
+  CALL tlen2itau (time_str, dt_force, date0, itau_skip)
+!-
+  itau_dep = itau_dep+itau_skip
+!-
+! We need to select the right position of the splited time steps.
+!-
+  istp = itau_dep*split+1
+  IF (MOD(istp-1,split) /= 0) THEN
+    split_start = MOD(istp-1,split)+1
+  ELSE
+    split_start = 1
+  ENDIF
+  istp_old = itau_dep_rest
+!!$  it_force = MAX(MOD(itau_dep,INT(one_day*one_year/dt_force)),1)+itau_skip
+!!$  WRITE(numout,*) 'itau_dep, it_force :', itau_dep, it_force
+!-
+  itau_len = itau_fin-itau_dep
+!-
+  !Config Key   = TIME_LENGTH
+  !Config Desc  = Length of the integration in time.
+  !Config If    = [-]
+  !Config Def   = DEF
+  !Config Help  = Length of integration. By default the entire length
+  !Config         of the forcing is used. The FORMAT of this date can
+  !Config         be either of the following :
+  !Config         n   : time step n within the forcing file
+  !Config         nS  : n seconds after the first time-step in the file
+  !Config         nD  : n days after the first time-step
+  !Config         nM  : n month after the first time-step (year of 365 days)
+  !Config         nY  : n years after the first time-step (year of 365 days)
+  !Config         Or combinations :
+  !Config         nYmM: n years and m month
+  !Config Units = [seconds, days, months, years]
+!-
+  WRITE(time_str,'(I10)') itau_len
+  CALL getin_p('TIME_LENGTH', time_str)
+!-
+! Transform into itau
+!-
+  CALL tlen2itau (time_str, dt_force, date0, itau_len)
+!-
+  itau_fin = itau_dep+itau_len
+!-
+  WRITE(numout,*) '>> Time origine in the forcing file :', date0
+  WRITE(numout,*) '>> Time origine in the restart file :', date0_rest
+  WRITE(numout,*) '>> Simulate starts at forcing time-step : ', itau_dep
+  WRITE(numout,*) '>> The splited time-steps start at (Sets the '
+  WRITE(numout,*) '>>  chronology for the history and restart files):',istp
+  WRITE(numout,*) '>> The time spliting starts at :', split_start
+  WRITE(numout,*) '>> Simulation ends at forcing time-step: ', itau_fin
+  WRITE(numout,*) '>> Length of the simulation is thus :', itau_len
+  WRITE(numout,*) '>> Length of the forcing data is in time-steps : ', tm
+  IF (tm < itau_len) THEN
+     CALL ipslerr_p ( 2, 'dim2_driver','Length of the simulation is greater than.', &
+ &         ' Length of the forcing data is in time-steps','verify TIME_LENGTH parameter.')
+  ENDIF
+  WRITE(numout,*) '>> Time steps : true, forcing and restart : ', dt,dt_force,dt_rest
+
+!=====================================================================
+!- 2.0 This section is going to define the details by which
+!-     the input data is going to be used to force the
+!-     land-surface scheme. The tasks are the following :
+!-   - Is the coupling going to be explicit or implicit
+!-   - Type of interpolation to be used.
+!-   - At which height are the atmospheric forcings going to be used ?
+!-   - Is a relaxation method going to be used on the forcing
+!-   - Does net radiation in the interpolated data need to be conserved
+!-   - How do we distribute precipitation.
+!=====================================================================
+  !Config Key   = RELAXATION
+  !Config Desc  = method of forcing
+  !Config If    = [-]
+  !Config Def   = n
+  !Config Help  = A method is proposed by which the first atmospheric
+  !Config         level is not directly forced by observations but
+  !Config         relaxed with a time constant towards observations.
+  !Config         For the moment the methods tends to smooth too much
+  !Config         the diurnal cycle and introduces a time shift.
+  !Config         A more sophisticated method is needed.
+  !Config Units = [FLAG]
+!-
+  relaxation = .FALSE.
+  CALL getin_p('RELAXATION', relaxation)  
+  IF ( relaxation ) THEN
+     WRITE(numout,*) 'dim2_driver : The relaxation option is temporarily disabled as it does not'
+     WRITE(numout,*) '              produce energy conservation in ORCHIDEE. If you intend to use it'
+     WRITE(numout,*) '              you should validate it.'
+     STOP 'dim2_driver'
+!- 
+     !Config Key   = RELAX_A
+     !Config Desc  = Time constant of the relaxation layer
+     !Config If    = RELAXATION
+     !Config Def   = 1.0
+     !Config Help  = The time constant associated to the atmospheric
+     !Config         conditions which are going to be computed
+     !Config         in the relaxed layer. To avoid too much
+     !Config         damping the value should be larger than 1000.
+     !Config Units = [days?]
+!-
+     alpha = 1000.0
+     CALL getin_p('RELAX_A', alpha)
+  ENDIF
+!-
+  no_inter = .TRUE.
+  inter_lin = .FALSE.
+
+  !Config Key   = NO_INTER 
+  !Config Desc  = No interpolation IF split is larger than 1
+  !Config If    = [-]
+  !Config Def   = y
+  !Config Help  = Choose IF you do not wish to interpolate linearly.
+  !Config Units = [FLAG]
+  CALL getin_p('NO_INTER', no_inter)
+
+  !Config Key   = INTER_LIN
+  !Config Desc  = Interpolation IF split is larger than 1
+  !Config If    = [-]
+  !Config Def   = n
+  !Config Help  = Choose IF you wish to interpolate linearly.
+  !Config Units = [FLAG]
+  CALL getin_p('INTER_LIN', inter_lin)
+!-
+  IF (inter_lin) THEN
+     no_inter = .FALSE.
+  ELSE
+     no_inter = .TRUE.
+  ENDIF
+!-
+  IF (split == 1) THEN
+    no_inter = .TRUE.
+    inter_lin = .FALSE.
+  ENDIF
+!-
+  !Config Key   = SPRED_PREC
+  !Config Desc  = Spread the precipitation.
+  !Config If    = [-]
+  !Config Def   = 1
+  !Config Help  = Spread the precipitation over n steps of the splited forcing 
+  !Config         time step. This ONLY applied if the forcing time step has been splited.
+  !Config         If the value indicated is greater than SPLIT_DT, SPLIT_DT is used for it.
+  !Config Units = [-]
+!-
+  nb_spread = 1
+  CALL getin_p('SPRED_PREC', nb_spread)  
+  IF (nb_spread > split) THEN
+    WRITE(numout,*) 'WARNING : nb_spread is too large it will be '
+    WRITE(numout,*) '          set to the value of split'
+    nb_spread = split
+  ELSE IF (split == 1) THEN
+    nb_spread = 1
+  ENDIF
+!-
+  IF (inter_lin) THEN
+     !Config Key   = NETRAD_CONS
+     !Config Desc  = Conserve net radiation in the forcing
+     !Config Def   = y
+     !Config If    = INTER_LIN
+     !Config Help  = When the interpolation is used the net radiation
+     !Config         provided by the forcing is not conserved anymore.
+     !Config         This should be avoided and thus this option should
+     !Config         be TRUE (y).
+     !Config         This option is not used for short-wave if the
+     !Config         time-step of the forcing is longer than an hour.
+     !Config         It does not make sense to try and reconstruct
+     !Config         a diurnal cycle and at the same time conserve the 
+     !Config         incoming solar radiation.
+     !Config Units = [FLAG]
+     !-
+     netrad_cons = .TRUE.
+     CALL getin_p('NETRAD_CONS', netrad_cons)
+  ELSE
+     netrad_cons = .FALSE.
+  ENDIF
+!=====================================================================
+!- 3.0 Finaly we can prepare all the variables before launching
+!-     the simulation !
+!=====================================================================
+! Initialize LOGICAL and the length of the integration
+!-
+  last_CALL = .FALSE.
+  first_CALL = .TRUE.
+!-
+  temp_sol_NEW(:,:) = tp_00
+!-  
+  !Config Key   = ATM_CO2
+  !Config Desc  = Value for atm CO2
+  !Config If    = [-]
+  !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.
+  !Config Units = [ppm]
+!-
+  atmco2=350.
+  CALL getin_p('ATM_CO2',atmco2)
+  for_ccanopy(:,:)=atmco2
+!-
+! Preparing for the implicit scheme.
+! This means loading the prognostic variables from the restart file.
+!-
+  Flag=.FALSE.
+  IF (is_root_prc) THEN
+     ALLOCATE(fluxsens_g(iim_g,jjm_g))
+     var_name= 'fluxsens'
+     CALL restget &
+ &        (rest_id, var_name, iim_g, jjm_g, 1, istp_old, .TRUE., fluxsens_g)
+     IF (ALL(fluxsens_g(:,:) == val_exp)) THEN
+        Flag=.TRUE.
+     ELSE
+        Flag=.FALSE.
+     ENDIF
+  ELSE
+     ALLOCATE(fluxsens_g(0,1))
+  ENDIF
+  CALL bcast(Flag)
+  IF (.NOT. Flag) THEN
+     CALL scatter2D_mpi(fluxsens_g,fluxsens)
+  ELSE
+     fluxsens(:,:) = zero
+  ENDIF
+  DEALLOCATE(fluxsens_g)
+!-
+  IF (is_root_prc) THEN
+     ALLOCATE(vevapp_g(iim_g,jjm_g))
+     var_name= 'vevapp'
+     CALL restget &
+ &        (rest_id, var_name, iim_g, jjm_g, 1, istp_old, .TRUE., vevapp_g)
+     IF (ALL(vevapp_g(:,:) == val_exp)) THEN
+        Flag=.TRUE.
+     ELSE
+        Flag=.FALSE.
+     ENDIF
+  ELSE
+     ALLOCATE(vevapp_g(0,1))
+  ENDIF
+  CALL bcast(Flag)
+  IF (.NOT. Flag) THEN
+     CALL scatter2D_mpi(vevapp_g,vevapp)
+  ELSE
+     vevapp(:,:) = zero
+  ENDIF
+  DEALLOCATE(vevapp_g)
+!-
+  IF (is_root_prc) THEN
+     ALLOCATE(old_zlev_g(iim_g,jjm_g))
+     var_name= 'zlev_old'
+     CALL restget &
+ &        (rest_id, var_name, iim_g, jjm_g, 1, istp_old, .TRUE., old_zlev_g)
+     IF (ALL(old_zlev_g(:,:) == val_exp)) THEN
+        Flag=.TRUE.
+     ELSE
+        Flag=.FALSE.
+     ENDIF
+  ELSE
+     ALLOCATE(old_zlev_g(0,1))
+  ENDIF
+  CALL bcast(Flag)
+  IF ( .NOT. Flag ) THEN
+     CALL scatter2D_mpi(old_zlev_g,old_zlev)
+  ELSE
+     old_zlev(:,:)=zlev_vec(:,:)
+  ENDIF
+  DEALLOCATE(old_zlev_g)
+!-
+  IF (is_root_prc) THEN
+     ALLOCATE(old_qair_g(iim_g,jjm_g))
+     var_name= 'qair_old'
+     CALL restget &
+ &       (rest_id, var_name, iim_g, jjm_g, 1, istp_old, .TRUE., old_qair_g)
+    IF (ALL(old_qair_g(:,:) == val_exp)) THEN
+      Flag=.TRUE.
+    ELSE
+      Flag=.FALSE.
+    ENDIF
+  ELSE
+     ALLOCATE(old_qair_g(0,1))
+  ENDIF
+  CALL bcast(Flag)
+  IF ( .NOT. Flag ) THEN
+     CALL scatter2D_mpi(old_qair_g,old_qair)
+  ELSE
+     old_qair(:,:) = qair_obs(:,:)
+  ENDIF
+  DEALLOCATE(old_qair_g)
+!-
+  IF (is_root_prc) THEN
+     ALLOCATE(old_eair_g(iim_g,jjm_g))
+     var_name= 'eair_old'
+     CALL restget &
+ &        (rest_id, var_name, iim_g, jjm_g, 1, istp_old, .TRUE., old_eair_g)
+    IF (ALL(old_eair_g(:,:) == val_exp)) THEN
+      Flag=.TRUE.
+    ELSE
+      Flag=.FALSE.
+    ENDIF
+  ELSE
+     ALLOCATE(old_eair_g(0,1))
+  ENDIF
+  CALL bcast(Flag)
+  IF ( .NOT. Flag ) THEN
+     CALL scatter2D_mpi(old_eair_g,old_eair)
+  ELSE
+     DO ik=1,nbindex
+        i=ilandindex(ik)
+        j=jlandindex(ik)
+        old_eair(i,j) = cp_air * tair_obs(i,j) + cte_grav*zlev_vec(i,j)
+     ENDDO
+  ENDIF
+  DEALLOCATE(old_eair_g)
+!-
+! old density is also needed because we do not yet have the right pb
+!-
+!=> obsolète ??!! (tjrs calculé après forcing_read) 
+  IF (is_root_prc) THEN
+     ALLOCATE(for_rau_g(iim_g,jjm_g))
+     var_name= 'rau_old'
+     CALL restget &
+ &        (rest_id, var_name, iim_g, jjm_g, 1, istp_old, .TRUE., for_rau_g)
+    IF (ALL(for_rau_g(:,:) == val_exp)) THEN
+      Flag=.TRUE.
+    ELSE
+      Flag=.FALSE.
+    ENDIF
+  ELSE
+     ALLOCATE(for_rau_g(0,1))
+  ENDIF
+  CALL bcast(Flag)
+  IF ( .NOT. Flag ) THEN
+     CALL scatter2D_mpi(for_rau_g,for_rau)
+  ELSE
+     DO ik=1,nbindex
+        i=ilandindex(ik)
+        j=jlandindex(ik)
+        for_rau(i,j) = pb(i,j)/(cte_molr*(tair_obs(i,j)))
+     ENDDO
+  ENDIF
+  DEALLOCATE(for_rau_g)
+!-
+! For this variable the restart is extracted by SECHIBA
+!-
+  temp_sol_NEW(:,:) = tair_obs(:,:)
+!- 
+  if (.NOT. is_watchout) THEN
+!-
+!   This does not yield a correct restart in the case of relaxation
+!-
+     IF (is_root_prc) THEN
+        ALLOCATE(petAcoef_g(iim_g,jjm_g))
+        var_name= 'petAcoef'
+        CALL restget &
+ &           (rest_id, var_name, iim_g, jjm_g, 1, istp_old, .TRUE., petAcoef_g)
+        IF (ALL(petAcoef_g(:,:) == val_exp)) THEN
+           Flag=.TRUE.
+        ELSE
+           Flag=.FALSE.
+        ENDIF
+     ELSE
+        ALLOCATE(petAcoef_g(0,1))
+     ENDIF
+     CALL bcast(Flag)
+     IF ( .NOT. Flag ) THEN
+        CALL scatter2D_mpi(petAcoef_g,petAcoef)
+     ELSE
+        petAcoef(:,:) = zero
+     ENDIF
+     DEALLOCATE(petAcoef_g)
+!--
+     IF (is_root_prc) THEN
+        ALLOCATE(petBcoef_g(iim_g,jjm_g))
+        var_name= 'petBcoef'
+        CALL restget &
+ &           (rest_id, var_name, iim_g, jjm_g, 1, istp_old, .TRUE., petBcoef_g)
+        IF (ALL(petBcoef_g(:,:) == val_exp)) THEN
+           Flag=.TRUE.
+        ELSE
+           Flag=.FALSE.
+        ENDIF
+     ELSE
+        ALLOCATE(petBcoef_g(0,1))
+     ENDIF
+     CALL bcast(Flag)
+     IF ( .NOT. Flag ) THEN
+        CALL scatter2D_mpi(petBcoef_g,petBcoef)
+     ELSE
+        petBcoef(:,:) = old_eair(:,:)
+     ENDIF
+     DEALLOCATE(petBcoef_g)
+!--
+     IF (is_root_prc) THEN
+        ALLOCATE(peqAcoef_g(iim_g,jjm_g))
+        var_name= 'peqAcoef'
+        CALL restget &
+ &           (rest_id, var_name, iim_g, jjm_g, 1, istp_old, .TRUE., peqAcoef_g)
+        IF (ALL(peqAcoef_g(:,:) == val_exp)) THEN
+           Flag=.TRUE.
+        ELSE
+           Flag=.FALSE.
+        ENDIF
+     ELSE
+        ALLOCATE(peqAcoef_g(0,1))
+     ENDIF
+     CALL bcast(Flag)
+     IF ( .NOT. Flag ) THEN
+        CALL scatter2D_mpi(peqAcoef_g,peqAcoef)
+     ELSE
+        peqAcoef(:,:) = zero
+     ENDIF
+     DEALLOCATE(peqAcoef_g)
+!--
+     IF (is_root_prc) THEN
+        ALLOCATE(peqBcoef_g(iim_g,jjm_g))
+        var_name= 'peqBcoef'
+        CALL restget &
+ &           (rest_id, var_name, iim_g, jjm_g, 1, istp_old, .TRUE., peqBcoef_g)
+        IF (ALL(peqBcoef_g(:,:) == val_exp)) THEN
+           Flag=.TRUE.
+        ELSE
+           Flag=.FALSE.
+        ENDIF
+     ELSE
+        ALLOCATE(peqBcoef_g(0,1))
+     ENDIF
+     CALL bcast(Flag)
+     IF ( .NOT. Flag ) THEN
+        CALL scatter2D_mpi(peqBcoef_g,peqBcoef)
+     ELSE
+        peqBcoef(:,:) = old_qair(:,:)
+     ENDIF
+     DEALLOCATE(peqBcoef_g)
+  ENDIF
+!-
+! And other variables which need initial variables. These variables
+! will get properly initialized by ORCHIDEE when it is called for 
+! the first time.
+!-
+  albedo(:,:,:) = 0.13
+  emis(:,:) = 1.0
+  z0(:,:) = 0.1
+!--
+!=====================================================================
+!- 4.0 START THE TIME LOOP
+!=====================================================================
+
+!ANNE!  CALL init_timer   
+
+  it = itau_dep+1
+  DO WHILE ( it <= itau_fin )
+!----
+    it_force = it+for_offset
+    IF (it_force < 0) THEN
+      WRITE(numout,*) 'The day is not in the forcing file :', &
+ &               it_force, it, for_offset
+      STOP 'dim2_driver'
+    ENDIF
+!!$    IF (it_force > itau_dep+tm) THEN
+!!$       WRITE(numout,*) 'ERROR : more time-steps than data'
+!!$       WRITE(numout,*) 'it_force : ', it_force, ' itau_dep+tm : ', itau_dep+tm
+!!$      STOP 'dim2_driver'
+!!$    ENDIF 
+!---
+    is=split_start
+    DO WHILE ( is <= split )
+!-----
+      julian = itau2date(istp, date0_rest, dt)
+      CALL ju2ymds(julian, yy, mm, dd, ss)
+      IF (debug) THEN
+         WRITE(numout,*) "=============================================================="
+         WRITE(numout,"('New iteration at date : ',I4,'-',I2.2,'-',I2.2,':',F8.4)") &
+              &               yy,mm,dd,ss/3600.
+#ifdef CPP_PARA
+         IF (is_root_prc) THEN
+            WRITE(*,*) "=============================================================="
+            WRITE(*,"('New iteration at date : ',I4,'-',I2.2,'-',I2.2,':',F8.4)") &
+              &               yy,mm,dd,ss/3600.
+         ENDIF
+#endif
+      ENDIF
+!----- 
+      IF ( (it == itau_fin).AND.(is == split) ) THEN
+        last_CALL = .TRUE.
+      ENDIF
+!-----
+      IF (debug) WRITE(numout,*) 'Into forcing_read'
+!-----
+      CALL forcing_READ &
+ &      (filename, rest_id, .FALSE., last_call, &
+ &       it_force, istp, is, split, nb_spread, netrad_cons, &
+ &       date0_rest, dt_force, iim, jjm, lon, lat, zlev_vec, zlevuv_vec, tm, &
+ &       swdown, sinang, precip_rain, precip_snow, tair_obs, &
+ &       u, v, qair_obs, pb, for_lwdown, for_contfrac, for_neighbours, for_resolution, &
+ &       for_swnet, eair_obs, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag, for_ccanopy, &
+ &       kindex, nbindex, force_id)
+
+!-----
+!---- SECHIBA expects surface pressure in hPa
+!-----
+      for_psurf(:,:)  = pb(:,:)/100.
+
+      IF (longprint) THEN
+         WRITE(numout,*) "dim2_driver 0 ",it_force 
+         WRITE(numout,*) ">> Index of land points =",kindex(1:nbindex)
+         WRITE(numout,*) "Lowest level wind speed North = ", &
+              & (/ ( u(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Lowest level wind speed East = ", &
+              & (/ ( v(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "z0            ; Surface roughness = ", &
+              & (/ ( z0(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Height of first layer = ", &
+              & (/ ( zlev_vec(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Lowest level specific humidity = ", &
+              & (/ ( qair_obs(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Rain precipitation = ", &
+              & (/ ( precip_rain(ilandindex(ik), jlandindex(ik))*dt,ik=1,nbindex ) /)
+         WRITE(numout,*) "Snow precipitation = ", &
+              & (/ ( precip_snow(ilandindex(ik), jlandindex(ik))*dt,ik=1,nbindex ) /)
+         WRITE(numout,*) "Down-welling long-wave flux = ", &
+              & (/ ( for_lwdown(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Net surface short-wave flux = ", &
+              & (/ ( for_swnet(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Downwelling surface short-wave flux = ", &
+              & (/ ( swdown(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Air temperature in Kelvin = ", &
+              & (/ ( tair_obs(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Air potential energy = ", &
+              & (/ ( eair_obs(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "CO2 concentration in the canopy = ", &
+              & (/ ( for_ccanopy(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Coeficients A from the PBL resolution = ", &
+              & (/ ( petAcoef(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "One for T and another for q = ", &
+              & (/ ( peqAcoef(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Coeficients B from the PBL resolution = ", &
+              & (/ ( petBcoef(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "One for T and another for q = ", &
+              & (/ ( peqBcoef(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Cdrag = ", &
+              & (/ ( cdrag(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /) 
+         WRITE(numout,*) "CO2 concentration in the canopy = ", &
+              & (/ ( for_ccanopy(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /) 
+         WRITE(numout,*) "Lowest level pressure = ", &
+              & (/ ( for_psurf(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Geographical coordinates lon = ", &
+              & (/ (  lon(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Geographical coordinates lat = ", &
+              & (/ (  lat(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Fraction of continent in the grid = ", &
+              & (/ ( for_contfrac(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+      ENDIF
+!-----
+!---- Prepare : tmp_qair, tmp_eair, tmp_tair, tmp_pb
+!---- and     : for_u, for_v, for_lwdown, for_swnet, for_swdown
+!---- All the work is done in forcing_read
+!---- We do not need the no_inter options as we will
+!---- allways interpolate
+!----- 
+      IF (debug) WRITE(numout,*) 'Prepare the atmospheric forcing'
+!----- 
+      IF (.NOT. is_watchout) THEN
+         DO ik=1,nbindex
+            i=ilandindex(ik)
+            j=jlandindex(ik)
+            eair_obs(i,j) = cp_air*tair_obs(i,j)+cte_grav*zlev_vec(i,j)
+            for_swnet(i,j) = (1.-(albedo(i,j,1)+albedo(i,j,2))/2.)*swdown(i,j)
+         ENDDO
+      ENDIF
+      DO ik=1,nbindex
+         i=ilandindex(ik)
+         j=jlandindex(ik)
+         for_swdown(i,j) = swdown(i,j)
+         for_sinang(i,j) = sinang(i,j)
+      ENDDO
+!----- 
+!---- Computing the buffer zone !
+!----- 
+      IF (relaxation) THEN
+         DO ik=1,nbindex
+            i=ilandindex(ik)
+            j=jlandindex(ik)
+            for_qair(i,j) = peqAcoef(i,j)*(-1.) * vevapp(i,j)*dt+peqBcoef(i,j)
+!-------
+            for_eair(i,j) = petAcoef(i,j)*(-1.) * fluxsens(i,j)+petBcoef(i,j)
+!-------
+         ENDDO
+         DO ik=1,nbindex
+            i=ilandindex(ik)
+            j=jlandindex(ik)
+            for_tair(i,j) = (for_eair(i,j) - cte_grav*zlev_vec(i,j))/cp_air
+!-------
+!!$        if (.NOT. is_watchout) &
+!!$             epot_sol(:,:) = cp_air*temp_sol_NEW(:,:)
+!-------
+         ENDDO
+         DO ik=1,nbindex
+            i=ilandindex(ik)
+            j=jlandindex(ik)
+            for_rau(i,j) = pb(i,j) / (cte_molr*for_tair(i,j))
+!-------
+            relax(i,j) = for_rau(i,j)*alpha 
+         ENDDO
+
+         DO ik=1,nbindex
+            i=ilandindex(ik)
+            j=jlandindex(ik)
+            zlflu = zlev_vec(i,j)/2.0*dt
+            peqAcoef(i,j) = 1.0/(zlflu+relax(i,j))
+            peqBcoef(i,j) = (relax(i,j) * qair_obs(i,j)/(zlflu+relax(i,j))) + & 
+                 & for_qair(i,j)/(1.0+relax(i,j)/zlflu)
+         ENDDO
+!-------
+!        relax(:,:) = for_rau(:,:)*alpha 
+         DO ik=1,nbindex
+            i=ilandindex(ik)
+            j=jlandindex(ik)
+            petAcoef(i,j) = 1.0/(zlflu+relax(i,j))
+            petBcoef(i,j) = ( relax(i,j) * eair_obs(i,j) / (zlflu+relax(i,j)) ) &
+                 & + for_eair(i,j)/(1.0+relax(i,j)/zlflu)
+         ENDDO
+      ELSE
+         for_qair(:,:) = fill_init
+         for_eair(:,:) = fill_init
+         for_tair(:,:) = fill_init
+         DO ik=1,nbindex
+            i=ilandindex(ik)
+            j=jlandindex(ik)
+            for_qair(i,j) = qair_obs(i,j)
+            for_eair(i,j) = eair_obs(i,j)
+            for_tair(i,j) = tair_obs(i,j)
+         ENDDO
+!-------
+!!$        if (.NOT. is_watchout) &
+!!$             epot_sol(:,:) =  cp_air*temp_sol_NEW(:,:)
+!-------
+         DO ik=1,nbindex
+            i=ilandindex(ik)
+            j=jlandindex(ik)
+            for_rau(i,j) = pb(i,j) / (cte_molr*for_tair(i,j))
+         ENDDO
+!-------
+         IF (.NOT. is_watchout) THEN
+           petAcoef(:,:) = 0.0
+           peqAcoef(:,:) = 0.0
+           DO ik=1,nbindex
+              i=ilandindex(ik)
+              j=jlandindex(ik)
+              petBcoef(i,j) = eair_obs(i,j)
+              peqBcoef(i,j) = qair_obs(i,j)
+           ENDDO
+        ENDIF
+      ENDIF
+!-----
+      IF (.NOT. is_watchout) &
+           cdrag(:,:)  = 0.0
+      for_ccanopy(:,:)=atmco2
+!-----
+!---- SECHIBA expects wind, temperature and humidity at the same height.
+!---- If this is not the case then we need to correct for that.
+!-----
+      DO ik=1,nbindex
+         i=ilandindex(ik) 
+         j=jlandindex(ik)
+         for_u(i,j) = u(i,j)*LOG(zlev_vec(i,j)/z0(i,j)) / &
+              LOG(zlevuv_vec(i,j)/z0(i,j)) 
+         for_v(i,j) = v(i,j)*LOG(zlev_vec(i,j)/z0(i,j)) / &
+              LOG(zlevuv_vec(i,j)/z0(i,j))
+      END DO
+            
+!-----
+!---- Prepare the other variables WITH the special CASE
+!---- of splited time steps
+!----
+!---- PRINT input value for debug
+!-----
+      IF (debug) THEN
+        WRITE(numout,*) ' >>>>>> time step it_force = ',it_force
+        WRITE(numout,*) &
+ &       ' tair, qair, eair = ', &
+ &       for_tair(itest,jtest),for_qair(itest,jtest), &
+ &       for_eair(itest,jtest)
+        WRITE(numout,*) &
+ &       ' OBS : tair, qair, eair = ', &
+ &       tair_obs(itest,jtest),qair_obs(itest,jtest), &
+ &       eair_obs(itest,jtest)
+        WRITE(numout,*) ' u et v = ',for_u(itest,jtest),for_v(itest,jtest)
+        WRITE(numout,*) ' precip rain et snow = ', &
+        & precip_rain(itest,jtest),precip_snow(itest,jtest)
+        WRITE(numout,*) ' lwdown et swnet = ', &
+        & for_lwdown(itest,jtest),for_swnet(itest,jtest)
+        WRITE(numout,*) ' petAcoef et peqAcoef = ', &
+        & petAcoef(itest,jtest), peqAcoef(itest,jtest)
+        WRITE(numout,*) ' petBcoef et peqAcoef = ', &
+        & petBcoef(itest,jtest),peqBcoef(itest,jtest)
+        WRITE(numout,*) ' zlev = ',zlev_vec(itest,jtest)
+      ENDIF
+!-----
+      IF (first_CALL) THEN
+
+        DO ik=1,nbindex
+           i=ilandindex(ik)
+           j=jlandindex(ik)
+           for_swdown(i,j) = swdown(i,j)
+           for_sinang(i,j) = sinang(i,j)
+        ENDDO
+        IF (longprint) THEN
+           WRITE(numout,*) "dim2_driver first_CALL ",it_force 
+           WRITE(numout,*) ">> Index of land points =",kindex(1:nbindex)
+           WRITE(numout,*) "Lowest level wind speed North = ", &
+             &     (/ ( for_u(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "Lowest level wind speed East = ", &
+             &     (/ ( for_v(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "z0            ; Surface roughness = ", &
+             &     (/ ( z0(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "Height of first layer = ", &
+             &     (/ ( zlev_vec(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "Lowest level specific humidity = ", &
+             &     (/ ( for_qair(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "Rain precipitation = ", &
+             &     (/ ( precip_rain(ilandindex(ik), jlandindex(ik))*dt,ik=1,nbindex ) /)
+           WRITE(numout,*) "Snow precipitation = ", &
+             &     (/ ( precip_snow(ilandindex(ik), jlandindex(ik))*dt,ik=1,nbindex ) /)
+           WRITE(numout,*) "Down-welling long-wave flux = ", &
+             &     (/ ( for_lwdown(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "Net surface short-wave flux = ", &
+             &     (/ ( for_swnet(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "Downwelling surface short-wave flux = ", &
+             &     (/ ( for_swdown(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "Air temperature in Kelvin = ", &
+             &     (/ ( for_tair(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "Air potential energy = ", &
+             &     (/ ( for_eair(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "CO2 concentration in the canopy = ", &
+             &     (/ ( for_ccanopy(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "Coeficients A from the PBL resolution = ", &
+             &     (/ ( petAcoef(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "One for T and another for q = ", &
+             &     (/ ( peqAcoef(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "Coeficients B from the PBL resolution = ", &
+             &     (/ ( petBcoef(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "One for T and another for q = ", &
+             &     (/ ( peqBcoef(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "Cdrag = ", &
+             &     (/ ( cdrag(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "Lowest level pressure = ", &
+             &     (/ ( for_psurf(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "Geographical coordinates lon = ", &
+             &     (/ (  lon(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "Geographical coordinates lat = ", &
+             &     (/ (  lat(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "Fraction of continent in the grid = ", &
+             &     (/ ( for_contfrac(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+        ENDIF
+!-------
+!------ CALL sechiba to initialize fields
+!------ and have some initial results: emis, albedo, z0
+!-------
+        CALL intersurf_main &
+ &        (istp_old, iim, jjm, nbindex, kindex, dt, &
+ &         first_CALL, .FALSE., lon, lat, for_contfrac, for_neighbours, for_resolution, date0_rest, &
+!       first level conditions
+ &         zlev_vec, for_u, for_v, &
+ &         for_qair, for_tair, for_eair, for_ccanopy, &
+!       Variables for the implicit coupling
+ &         cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+!       Rain, snow, radiation and surface pressure
+ &         precip_rain, precip_snow, &
+ &         for_lwdown, for_swnet, for_swdown, for_psurf, &
+!       Output : Fluxes
+ &         vevapp, fluxsens, fluxlat, coastalflow, riverflow,  &
+!       Surface temperatures and surface properties
+ &         tsol_rad, temp_sol_NEW, qsurf, albedo, emis, z0, & 
+!       VOC : radiation
+ &         for_sinang)
+
+        CALL Stop_timer(timer_global)
+        CALL Stop_timer(timer_mpi)
+        CALL Start_timer(timer_global)
+        CALL Start_timer(timer_mpi)
+        !
+        first_CALL = .FALSE.
+        !
+        ! Get Restart values for albedo and z0, 
+        ! as they modify forcing variables swnet and wind.
+!-------
+        ! albedo 
+        IF (is_root_prc) THEN
+           ALLOCATE(albedo_g(iim_g,jjm_g))
+        ELSE
+           ALLOCATE(albedo_g(0,1))
+        ENDIF
+        !
+        IF (is_root_prc) THEN
+           var_name= 'albedo_vis'
+           CALL restget &
+                &        (rest_id, var_name, iim_g, jjm_g, 1, istp_old, .TRUE., albedo_g)
+           IF (ALL(albedo_g(:,:) == val_exp)) THEN
+              Flag=.TRUE.
+           ELSE
+              Flag=.FALSE.
+           ENDIF
+        ENDIF
+        CALL bcast(Flag)
+        IF ( .NOT. Flag ) THEN
+           CALL scatter2D_mpi(albedo_g,albedo_vis)
+           albedo(:,:,1)=albedo_vis(:,:)
+        ELSE
+           albedo_vis(:,:)=albedo(:,:,1)
+        ENDIF
+        !
+        IF (is_root_prc) THEN
+           var_name= 'albedo_nir'
+           CALL restget &
+                &        (rest_id, var_name, iim_g, jjm_g, 1, istp_old, .TRUE., albedo_g)
+           IF (ALL(albedo_g(:,:) == val_exp)) THEN
+              Flag=.TRUE.
+           ELSE
+              Flag=.FALSE.
+           ENDIF
+        ENDIF
+        CALL bcast(Flag)
+        IF ( .NOT. Flag ) THEN
+           CALL scatter2D_mpi(albedo_g,albedo_nir)
+           albedo(:,:,2)=albedo_nir(:,:)
+        ELSE
+           albedo_nir(:,:)=albedo(:,:,2)
+        ENDIF
+        !
+        DEALLOCATE(albedo_g)
+        !--
+        ! z0 
+        IF (is_root_prc) THEN
+           ALLOCATE(z0_g(iim_g,jjm_g))
+           var_name= 'z0'
+           CALL restget &
+                &        (rest_id, var_name, iim_g, jjm_g, 1, istp_old, .TRUE., z0_g)
+           IF (ALL(z0_g(:,:) == val_exp)) THEN
+              Flag=.TRUE.
+           ELSE
+              Flag=.FALSE.
+           ENDIF
+        ELSE
+           ALLOCATE(z0_g(0,1))
+        ENDIF
+        CALL bcast(Flag)
+        IF (.NOT. Flag) &
+             CALL scatter2D_mpi(z0_g,z0)
+        DEALLOCATE(z0_g)
+!-------
+        DO ik=1,nbindex
+           i=ilandindex(ik)
+           j=jlandindex(ik)
+           temp_sol_old(i,j) = temp_sol_NEW(i,j)
+           for_swnet(i,j) = (1.- (albedo(i,j,1)+albedo(i,j,2))/2.)*swdown(i,j)
+           for_swdown(i,j) = swdown(i,j)
+           for_sinang(i,j) = sinang(i,j)
+        ENDDO
+!
+!     MM : z0 have been modified then we must lower the wind again
+!-----
+!---- SECHIBA expects wind, temperature and humidity at the same height.
+!---- If this is not the case then we need to correct for that.
+!-----
+        DO ik=1,nbindex 
+           i=ilandindex(ik) 
+           j=jlandindex(ik) 
+           for_u(i,j) = u(i,j) * LOG(zlev_vec(i,j)/z0(i,j)) / & 
+                LOG(zlevuv_vec(i,j)/z0(i,j)) 
+           for_v(i,j) = v(i,j) * LOG(zlev_vec(i,j)/z0(i,j)) / &
+                LOG(zlevuv_vec(i,j)/z0(i,j)) 
+        END DO
+        
+!-----
+!---- PRINT input value after first_CALL for debug
+!-----
+        IF (debug) THEN
+           WRITE(numout,*) ' >>>>>> after first_CALL = ',first_CALL
+           WRITE(numout,*) ' u et v = ',for_u(itest,jtest),for_v(itest,jtest)
+           WRITE(numout,*) ' swnet = ', for_swnet(itest,jtest)
+        ENDIF
+!-------
+        IF (longprint) THEN
+           WRITE(numout,*) "dim2_driver first_CALL outputs"
+           !       Output : Fluxes
+           WRITE(numout,*) "vevapp        ; Total of evaporation = ", &
+             &     (/ ( vevapp(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,'(A,100F20.10)') "Sensible heat flux = ", &
+             &     (/ ( fluxsens(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,'(A,100F20.10)') "Latent heat flux = ", &
+             &     (/ ( fluxlat(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "coastalflow   ; Diffuse flow of water into the ocean (m^3/dt) = ", &
+             &     (/ ( coastalflow(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "riverflow     ; Largest rivers flowing into the ocean (m^3/dt) = ", &
+             &     (/ ( riverflow(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           !       Surface temperatures and surface properties
+           WRITE(numout,*) "tsol_rad      ; Radiative surface temperature = ", &
+             &     (/ ( tsol_rad(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "temp_sol_new  ; New soil temperature = ", &
+             &     (/ ( temp_sol_NEW(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "qsurf         ; Surface specific humidity = ", &
+             &     (/ ( qsurf(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "albedoVIS = ", &
+             &     (/ ( albedo(ilandindex(ik), jlandindex(ik), 1),ik=1,nbindex ) /)
+           WRITE(numout,*) "albedoNIR = ", &
+             &     (/ ( albedo(ilandindex(ik), jlandindex(ik), 2),ik=1,nbindex ) /)
+           WRITE(numout,*) "emis          ; Emissivity = ", &
+             &     (/ ( emis(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+           WRITE(numout,*) "z0            ; Surface roughness = ", &
+             &     (/ ( z0(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+        ENDIF
+!-------
+        IF (debug) THEN
+          WRITE(numout,*) &
+ &         ' OUT rest : z0, albedoVIS, albedoNIR, emis = ', &
+ &         z0(itest,jtest),albedo(itest,jtest,1), &
+ &                         albedo(itest,jtest,2),emis(itest,jtest)
+          WRITE(numout,*) ' OUT rest : coastal and river flow = ', &
+ &         coastalflow(itest,jtest), riverflow(itest,jtest)
+          WRITE(numout,*) ' OUT rest : tsol_rad, vevapp = ', &
+ &         tsol_rad(itest,jtest), vevapp(itest,jtest)
+          WRITE(numout,*) ' OUT rest : temp_sol_new =', &
+ &         temp_sol_NEW(itest,jtest)
+        ENDIF
+    
+!ANNE/        CALL barrier_para
+!ANNE/        CALL start_timer(timer_global)
+!ANNE/        CALL start_timer(timer_mpi)
+   
+      ENDIF
+!-----
+!---- Calling SECHIBA and doing the number crunching.
+!---- Note that for the first time step SECHIBA is called twice.
+!----
+!---- All H_2O fluxes are now in Kg/m^2s
+!-----
+      IF (longprint) THEN
+         WRITE(numout,*) "dim2_driver ",it_force 
+         WRITE(numout,*) ">> Index of land points =",kindex(1:nbindex)
+         WRITE(numout,*) "Lowest level wind speed North = ", &
+           &     (/ ( for_u(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Lowest level wind speed East = ", &
+           &     (/ ( for_v(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "z0            ; Surface roughness = ", &
+           &     (/ ( z0(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Height of first layer = ", &
+           &     (/ ( zlev_vec(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Lowest level specific humidity = ", &
+           &     (/ ( for_qair(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Rain precipitation = ", &
+           &     (/ ( precip_rain(ilandindex(ik), jlandindex(ik))*dt,ik=1,nbindex ) /)
+         WRITE(numout,*) "Snow precipitation = ", &
+           &     (/ ( precip_snow(ilandindex(ik), jlandindex(ik))*dt,ik=1,nbindex ) /)
+         WRITE(numout,*) "Down-welling long-wave flux = ", &
+           &     (/ ( for_lwdown(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Net surface short-wave flux = ", &
+           &     (/ ( for_swnet(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Downwelling surface short-wave flux = ", &
+           &     (/ ( for_swdown(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Air temperature in Kelvin = ", &
+           &     (/ ( for_tair(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Air potential energy = ", &
+           &     (/ ( for_eair(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "CO2 concentration in the canopy = ", &
+           &     (/ ( for_ccanopy(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Coeficients A from the PBL resolution = ", &
+           &     (/ ( petAcoef(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "One for T and another for q = ", &
+           &     (/ ( peqAcoef(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Coeficients B from the PBL resolution = ", &
+           &     (/ ( petBcoef(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "One for T and another for q = ", &
+           &     (/ ( peqBcoef(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Cdrag = ", &
+           &     (/ ( cdrag(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Lowest level pressure = ", &
+           &     (/ ( for_psurf(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Geographical coordinates lon = ", &
+           &     (/ (  lon(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Geographical coordinates lat = ", &
+           &     (/ (  lat(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Fraction of continent in the grid = ", &
+           &     (/ ( for_contfrac(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+      ENDIF
+      
+      CALL intersurf_main &
+ &      (istp, iim, jjm, nbindex, kindex, dt, &
+ &       first_CALL, last_CALL, lon, lat, for_contfrac, for_neighbours, for_resolution, date0_rest, &
+!     first level conditions
+ &       zlev_vec, for_u, for_v, &
+ &       for_qair, for_tair, for_eair, for_ccanopy, &
+!     Variables for the implicit coupling
+ &       cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+!     Rain, snow, radiation and surface pressure
+ &       precip_rain, precip_snow, &
+ &       for_lwdown, for_swnet, for_swdown, for_psurf, &
+!     Output : Fluxes
+ &       vevapp, fluxsens, fluxlat, coastalflow, riverflow,  &
+!     Surface temperatures and surface properties
+ &       tsol_rad, temp_sol_NEW, qsurf, albedo, emis, z0, &
+!       VOC : radiation
+ &       for_sinang)
+
+!-------
+      IF (longprint) THEN
+         WRITE(numout,*) "dim2_driver outputs"
+         !       Output : Fluxes
+         WRITE(numout,*) "vevapp        ; Total of evaporation = ", &
+           &     (/ ( vevapp(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Sensible heat flux = ", &
+           &     (/ ( fluxsens(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "Latent heat flux = ", &
+           &     (/ ( fluxlat(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "coastalflow   ; Diffuse flow of water into the ocean (m^3/dt) = ", &
+           &     (/ ( coastalflow(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "riverflow     ; Largest rivers flowing into the ocean (m^3/dt) = ", &
+           &     (/ ( riverflow(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         !       Surface temperatures and surface properties
+         WRITE(numout,*) "tsol_rad      ; Radiative surface temperature = ", &
+           &     (/ ( tsol_rad(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "temp_sol_new  ; New soil temperature = ", &
+           &     (/ ( temp_sol_NEW(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "qsurf         ; Surface specific humidity = ", &
+           &     (/ ( qsurf(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "albedoVIS = ", &
+           &     (/ ( albedo(ilandindex(ik), jlandindex(ik), 1),ik=1,nbindex ) /)
+         WRITE(numout,*) "albedoNIR = ", &
+           &     (/ ( albedo(ilandindex(ik), jlandindex(ik), 2),ik=1,nbindex ) /)
+         WRITE(numout,*) "emis          ; Emissivity = ", &
+           &     (/ ( emis(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+         WRITE(numout,*) "z0            ; Surface roughness = ", &
+           &     (/ ( z0(ilandindex(ik), jlandindex(ik)),ik=1,nbindex ) /)
+      ENDIF
+!-----
+      dtdt(:,:) = zero
+      DO ik=1,nbindex
+         i=ilandindex(ik)
+         j=jlandindex(ik)
+         dtdt(i,j) = ABS(temp_sol_NEW(i,j)-temp_sol_old(i,j))/dt
+      ENDDO
+!-----
+!---- Test if the point with the largest change has more than 5K per dt
+!-----
+      IF (MAXVAL(dtdt(:,:)) > 5./dt) THEN
+        ml = MAXLOC(dtdt)
+        CALL ju2ymds(julian, yy, mm, dd, ss)
+        WRITE(numout,"('ATT :',I5,' big temperature jumps on ', &
+ &       I4,'-',I2.2,'-',I2.2,':',F8.4)") &
+ &       COUNT(dtdt(:,:) > 5./dt),yy,mm,dd,ss/3600.
+        WRITE(numout,*) &
+ &       'Maximum change of surface temperature located at :', &
+ &       lon(ml(1),ml(2)),lat(ml(1),ml(2))
+        WRITE(numout,*) 'Coordinates in grid space: ',ml(1),ml(2)
+        WRITE(numout,*) 'Change from ',temp_sol_old(ml(1),ml(2)), &
+ &       ' to ',temp_sol_new(ml(1),ml(2)),&
+ &       'with sw_in = ',for_swnet(ml(1),ml(2))
+        old_tair = &
+ &        (old_eair(ml(1),ml(2))-cte_grav*old_zlev(ml(1),ml(2)))/cp_air
+        WRITE(numout,*) 'Air temperature change from ',old_tair, &
+ &       ' to ',for_tair(ml(1),ml(2))
+        WRITE(numout,*) 'Max of dtdt : ',dtdt(ml(1),ml(2)),' with dt = ',dt
+      ENDIF
+!-----
+      temp_sol_old(:,:) = temp_sol_NEW(:,:)
+!-----
+!---- PRINT output value for debug
+!-----
+      IF (debug) THEN
+        WRITE(numout,*) ' OUT : z0, albedoVIS, albedoNIR, emis = ', &
+ &       z0(itest,jtest),albedo(itest,jtest,1), &
+ &                       albedo(itest,jtest,2),emis(itest,jtest)
+        WRITE(numout,*) ' OUT : coastal and river flow = ',&
+ &       coastalflow(itest,jtest), riverflow(itest,jtest)
+        WRITE(numout,*) ' OUT : tsol_rad, vevapp = ', &
+ &       tsol_rad(itest,jtest), vevapp(itest,jtest)
+        WRITE(numout,*) ' OUT : temp_sol_new =', temp_sol_NEW(itest,jtest)
+      ENDIF
+!-----
+!---- Give some variables to the output package
+!---- for saving on the history tape
+!-----
+      IF (debug) WRITE(numout,*) 'history written for ', istp
+!-----
+      istp_old = istp
+      istp = istp+1
+!-----
+      old_zlev(:,:) = zlev_vec(:,:)
+      old_qair(:,:) = for_qair(:,:)
+      old_eair(:,:) = for_eair(:,:)
+!-----
+      is = is + 1
+    ENDDO
+    split_start = 1
+!!$    it_force =it_force+1
+    IF (it==itau_fin-1) THEN
+     
+     CALL Write_Load_Balance(REAL(Get_cpu_time(timer_mpi),r_std))
+
+    ENDIF
+    it = it + 1
+!!! CALL histsync
+  ENDDO
+!-
+! Archive in restart file the prognostic variables
+!-
+  IF (debug) WRITE(numout,*) 'Write the restart for the driver', istp_old
+!-
+  var_name = 'fluxsens'
+  IF (is_root_prc) THEN
+     ALLOCATE(fluxsens_g(iim_g,jjm_g))
+  ELSE
+     ALLOCATE(fluxsens_g(0,1))
+  ENDIF
+  CALL gather2D_mpi(fluxsens , fluxsens_g)
+  IF(is_root_prc) CALL restput (rest_id, var_name, iim_g, jjm_g, 1, istp_old, fluxsens_g)
+  DEALLOCATE(fluxsens_g)
+  
+  var_name = 'vevapp'
+  IF (is_root_prc) THEN
+     ALLOCATE(vevapp_g(iim_g,jjm_g))
+  ELSE
+     ALLOCATE(vevapp_g(0,1))
+  ENDIF
+  CALL gather2D_mpi( vevapp, vevapp_g)
+  IF(is_root_prc) CALL restput (rest_id, var_name, iim_g, jjm_g, 1, istp_old, vevapp_g)
+  DEALLOCATE(vevapp_g)
+  
+  var_name = 'zlev_old'
+  IF (is_root_prc) THEN
+     ALLOCATE(old_zlev_g(iim_g,jjm_g))
+  ELSE
+     ALLOCATE(old_zlev_g(0,1))
+  ENDIF
+  CALL gather2D_mpi( old_zlev, old_zlev_g)
+  IF(is_root_prc) CALL restput (rest_id, var_name, iim_g, jjm_g, 1, istp_old, old_zlev_g)
+  DEALLOCATE(old_zlev_g)
+  
+  var_name = 'qair_old'
+  IF (is_root_prc) THEN
+     ALLOCATE(old_qair_g(iim_g,jjm_g))
+  ELSE
+     ALLOCATE(old_qair_g(0,1))
+  ENDIF
+  CALL gather2D_mpi( old_qair, old_qair_g)
+  IF(is_root_prc) CALL restput (rest_id, var_name, iim_g, jjm_g, 1, istp_old, old_qair_g)
+  DEALLOCATE(old_qair_g)
+  
+  var_name = 'eair_old'
+  IF (is_root_prc) THEN
+     ALLOCATE(old_eair_g(iim_g,jjm_g))
+  ELSE
+     ALLOCATE(old_eair_g(0,1))
+  ENDIF
+  CALL gather2D_mpi( old_eair, old_eair_g)
+  IF(is_root_prc) CALL restput (rest_id, var_name, iim_g, jjm_g, 1, istp_old, old_eair_g)
+  DEALLOCATE(old_eair_g)
+  
+  var_name = 'rau_old'
+  IF (is_root_prc) THEN
+     ALLOCATE(for_rau_g(iim_g,jjm_g))
+  ELSE
+     ALLOCATE(for_rau_g(0,1))
+  ENDIF
+  CALL gather2D_mpi( for_rau, for_rau_g)
+  IF(is_root_prc) CALL restput (rest_id, var_name, iim_g, jjm_g, 1, istp_old, for_rau_g)
+  DEALLOCATE(for_rau_g)
+  
+  IF (is_root_prc) THEN
+     ALLOCATE(albedo_g(iim_g,jjm_g))
+  ELSE
+     ALLOCATE(albedo_g(0,1))
+  ENDIF
+  var_name= 'albedo_vis'
+  albedo_vis(:,:)=albedo(:,:,1)
+  CALL gather2D_mpi(albedo_vis,albedo_g)
+  IF(is_root_prc) CALL restput (rest_id, var_name, iim_g, jjm_g, 1, istp_old, albedo_g)  
+  !
+  var_name= 'albedo_nir'
+  albedo_nir(:,:)=albedo(:,:,2)
+  CALL gather2D_mpi(albedo_nir,albedo_g)
+  IF(is_root_prc) CALL restput (rest_id, var_name, iim_g, jjm_g, 1, istp_old, albedo_g)  
+  DEALLOCATE(albedo_g)
+
+  IF (is_root_prc) THEN
+     ALLOCATE(z0_g(iim_g,jjm_g))
+  ELSE
+     ALLOCATE(z0_g(0,1))
+  ENDIF
+  var_name= 'z0'
+  CALL gather2D_mpi(z0,z0_g)
+  IF(is_root_prc) CALL restput (rest_id, var_name, iim_g, jjm_g, 1, istp_old, z0_g)  
+  DEALLOCATE(z0_g)
+
+  if (.NOT. is_watchout) THEN
+     var_name = 'petAcoef'
+     IF (is_root_prc) THEN
+        ALLOCATE(petAcoef_g(iim_g,jjm_g))
+     ELSE
+        ALLOCATE(petAcoef_g(0,1))
+     ENDIF
+     CALL gather2D_mpi( petAcoef, petAcoef_g)
+     IF(is_root_prc) CALL restput (rest_id, var_name, iim_g, jjm_g, 1, istp_old, petAcoef_g)
+     DEALLOCATE(petAcoef_g)
+  
+     var_name = 'petBcoef'
+     IF (is_root_prc) THEN
+        ALLOCATE(petBcoef_g(iim_g,jjm_g))
+     ELSE
+        ALLOCATE(petBcoef_g(0,1))
+     ENDIF
+     CALL gather2D_mpi( petBcoef, petBcoef_g)
+     IF(is_root_prc) CALL restput (rest_id, var_name, iim_g, jjm_g, 1, istp_old, petBcoef_g)
+     DEALLOCATE(petBcoef_g)
+  
+     var_name = 'peqAcoef'
+     IF (is_root_prc) THEN
+        ALLOCATE(peqAcoef_g(iim_g,jjm_g))
+     ELSE
+        ALLOCATE(peqAcoef_g(0,1))
+     ENDIF
+     CALL gather2D_mpi( peqAcoef, peqAcoef_g)
+     IF(is_root_prc) CALL restput (rest_id, var_name, iim_g, jjm_g, 1, istp_old, peqAcoef_g)
+     DEALLOCATE(peqAcoef_g)
+  
+     var_name = 'peqBcoef'
+     IF (is_root_prc) THEN
+        ALLOCATE(peqBcoef_g(iim_g,jjm_g))
+     ELSE
+        ALLOCATE(peqBcoef_g(0,1))
+     ENDIF
+     CALL gather2D_mpi( peqBcoef, peqBcoef_g)
+     IF(is_root_prc) CALL restput (rest_id, var_name, iim_g, jjm_g, 1, istp_old, peqBcoef_g)
+     DEALLOCATE(peqBcoef_g)
+  ENDIF
+!-
+  IF (debug) WRITE(numout,*) 'Restart for the driver written'
+!=====================================================================
+!- 5.0 Closing all files
+!=====================================================================
+  CALL flinclo(force_id)
+  IF ( debug )  WRITE(numout,*) 'FLIN CLOSED'
+  CALL histclo
+  IF ( debug )   WRITE(numout,*) 'HIST CLOSED'      
+    
+  IF(is_root_prc) THEN
+     CALL restclo
+     IF ( debug )  WRITE(numout,*) 'REST CLOSED'
+     CALL getin_dump
+     IF ( debug )  WRITE(numout,*) 'GETIN CLOSED'
+  ENDIF
+
+  
+  WRITE(numout,*) '-------------------------------------------'
+  WRITE(numout,*) '------> CPU Time Global ',Get_cpu_Time(timer_global)
+  WRITE(numout,*) '------> CPU Time without mpi ',Get_cpu_Time(timer_mpi)
+  WRITE(numout,*) '------> Real Time Global ',Get_real_Time(timer_global)
+  WRITE(numout,*) '------> real Time without mpi ',Get_real_Time(timer_mpi)
+  WRITE(numout,*) '-------------------------------------------'
+  CALL Finalize_mpi
+!---------------
+!  CALL Write_Load_Balance(Get_cpu_time(timer_mpi))
+
+!-
+  WRITE(numout,*) 'END of dim2_driver'
+!---------------
+END PROGRAM driver
Index: branches/publications/ORCHIDEE_CAN_NHA/src_driver/forcesoil.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_driver/forcesoil.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_driver/forcesoil.f90	(revision 7236)
@@ -0,0 +1,659 @@
+! =================================================================================================================================
+! PROGRAM       : forcesoil
+!
+! CONTACT	: orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      	: IPSL (2006). This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        This subroutine runs the soilcarbon submodel using specific initial conditions 
+!! and driving variables in order to obtain soil carbon stocks closed to the steady-state values 
+!! quicker than when using the ''full'' ORCHIDEE.  
+!!	
+!!\n DESCRIPTION: None
+!! This subroutine computes the soil carbon stocks by calling the soilcarbon routine at each time step. \n
+!! The aim is to obtain soil carbon stocks closed to the steady-state values and ultimately to create  
+!! an updated stomate restart file for the stomate component. The state variables of the subsystem are the clay content 
+!! (fixed value) and the soil carbon stocks. Initial conditions for the state variables are read in an  
+!! input stomate restart file. Driving variables are Soil carbon input, Water and Temperature stresses on 
+!! Organic Matter decomposition. Driving variables are read from a specific forcing file produced by a former run of ORCHIDEE
+!! (SECHIBA+STOMATE). \n 
+!! The FORCESOIL program first consists in reading a set of input files, allocating variables and 
+!! preparing output stomate restart file. \n                                                             
+!! Then, a loop over time is performed in which the soilcarbon routine is called at each time step. \n
+!! Last, final values of the soil carbon stocks are written into the output stomate restart file. \n
+!! No flag is associated with the use of the FORCESOIL program. \n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S) : None    
+!!
+!! FLOWCHART    : None
+!!
+!! SVN		:
+!! $HeadURL: $ 
+!! $Date: $
+!! $Revision: $
+!! \n
+!_ =================================================================================================================================
+
+PROGRAM forcesoil
+ 
+  USE netcdf
+  !-
+  USE defprec
+  USE constantes
+  USE constantes_mtc
+  USE pft_parameters 
+  USE stomate_data
+  USE ioipsl_para
+  USE mod_orchidee_para
+  USE stomate_soilcarbon
+
+!  USE parallel
+  !-
+  IMPLICIT NONE
+  !-
+  CHARACTER(LEN=80)                          :: sto_restname_in,sto_restname_out
+  INTEGER(i_std)                             :: iim,jjm                !! Indices (unitless)
+
+  INTEGER(i_std),PARAMETER                   :: llm = 1                !! Vertical Layers (requested by restini routine) (unitless)
+  INTEGER(i_std)                             :: kjpindex               !! Domain size (unitless)
+
+  INTEGER(i_std)                             :: itau_dep,itau_len      !! Time step read in the restart file (?) 
+                                                                       !! and number of time steps of the simulation (unitless) 
+  CHARACTER(LEN=30)                          :: time_str               !! Length of the simulation (year)
+  REAL(r_std)                                :: dt_files               !! time step between two successive itaus (?) 
+                                                                       !! (requested by restini routine) (seconds)
+  REAL(r_std)                                :: date0                  !! Time at which itau = 0 (requested by restini routine) (?)
+  INTEGER(i_std)                             :: rest_id_sto            !! ID of the input restart file (unitless)
+  CHARACTER(LEN=20), SAVE                    :: thecalendar = 'noleap' !! Type of calendar defined in the input restart file 
+                                                                       !! (unitless)
+  !-
+  CHARACTER(LEN=100)                         :: Cforcing_name          !! Name of the forcing file (unitless)
+  INTEGER                                    :: Cforcing_id            !! ID of the forcing file (unitless)
+  INTEGER                                    :: v_id                   !! ID of the variable 'Index' stored in the forcing file 
+                                                                       !! (unitless)
+  REAL(r_std)                                :: dt_forcesoil           !! Time step at which soilcarbon routine is called (days) 
+  INTEGER                                    :: nparan                 !! Number of values stored per year in the forcing file 
+                                                                       !! (unitless)
+  INTEGER                                    :: nbyear
+  INTEGER(i_std),DIMENSION(:),ALLOCATABLE    :: indices                !! Grid Point Index used per processor (unitless)
+  INTEGER(i_std),DIMENSION(:),ALLOCATABLE    :: indices_g              !! Grid Point Index for all processor (unitless)
+  REAL(r_std),DIMENSION(:),ALLOCATABLE       :: x_indices_g            !! Grid Point Index for all processor (unitless)
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE     :: lon, lat               !! Longitude and Latitude of each grid point defined 
+                                                                       !! in lat/lon (2D) (degrees)
+  REAL(r_std),DIMENSION(llm)                 :: lev                    !! Number of level (requested by restini routine) (unitless)
+
+
+  INTEGER                                    :: i,m,iatt,iv,iyear  !! counters (unitless)
+
+  CHARACTER(LEN=80)                          :: var_name
+  CHARACTER(LEN=800)                         :: taboo_vars         !! string used for storing the name of the variables 
+                                                                   !! of the stomate restart file that are not automatically 
+                                                                   !! duplicated from input to output restart file (unitless)
+  REAL(r_std),DIMENSION(1)                   :: xtmp               !! scalar read/written in restget/restput routines (unitless)
+  INTEGER(i_std),PARAMETER                   :: nbvarmax=300       !! maximum # of variables assumed in the stomate restart file 
+                                                                   !! (unitless)
+  INTEGER(i_std)                             :: nbvar              !! # of variables effectively present 
+                                                                   !! in the stomate restart file (unitless)
+  CHARACTER(LEN=50),DIMENSION(nbvarmax)      :: varnames           !! list of the names of the variables stored 
+                                                                   !! in the stomate restart file (unitless)
+  INTEGER(i_std)                             :: varnbdim           !! # of dimensions of a given variable 
+                                                                   !! of the stomate restart file
+  INTEGER(i_std),PARAMETER                   :: varnbdim_max=20    !! maximal # of dimensions assumed for any variable 
+                                                                   !! of the stomate restart file 
+  INTEGER,DIMENSION(varnbdim_max)            :: vardims            !! length of each dimension of a given variable 
+                                                                   !! of the stomate restart file
+  LOGICAL                                    :: l1d                !! boolean : TRUE if all dimensions of a given variable 
+                                                                   !! of the stomate restart file are of length 1 (ie scalar) 
+                                                                   !! (unitless)
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE     :: var_3d             !! matrix read/written in restget/restput routines (unitless)
+  REAL(r_std)                                :: x_tmp              !! temporary variable used to store return value 
+                                                                   !! from nf90_get_att (unitless)
+  CHARACTER(LEN=10)  :: part_str                                   !! string suffix indicating the index of a PFT 
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)  :: clay_g             !! clay fraction (nbpglo) (unitless)
+  REAL(r_std),DIMENSION(:,:,:,:),ALLOCATABLE :: soilcarbon_input_g !! soil carbon input (nbpglob,ncarb,nvm,time) 
+                                                                   !! (\f$gC m^{-2} dt_forcesoil^{-1}\f$) 
+  REAL(r_std),DIMENSION(:,:,:),ALLOCATABLE   :: control_temp_g     !! Temperature control (nbp_glo,above/below,time) on OM decomposition 
+                                                                   !! (unitless)
+  REAL(r_std),DIMENSION(:,:,:),ALLOCATABLE   :: control_moist_g    !! Moisture control (nbp_glo,abo/below,time) on OM decomposition 
+                                                                   !! ?? Should be defined per PFT as well (unitless)
+  REAL(r_std),DIMENSION(:,:,:),ALLOCATABLE   :: carbon_g           !! Soil carbon stocks (nbp_glo,ncarb,nvm) (\f$gC m^{-2}\f$)
+
+  REAL(r_std),ALLOCATABLE :: clay(:)                   !! clay fraction (nbp_loc) (unitless)
+  REAL(r_std),ALLOCATABLE :: soilcarbon_input(:,:,:,:) !! soil carbon input (nbp_loc,ncarb,nvm,time) 
+                                                       !! (\f$gC m^{-2} dt_forcesoil^{-1}\f$) 
+  REAL(r_std),ALLOCATABLE :: control_temp(:,:,:)       !! Temperature control (nbp_loc,above/below,time) on OM decomposition 
+                                                       !! (unitless)
+  REAL(r_std),ALLOCATABLE :: control_moist(:,:,:)      !! Moisture control (nbp_loc,abo/below,time) on OM decomposition 
+                                                       !! ?? Should be defined per PFT as well (unitless)
+  REAL(r_std),ALLOCATABLE :: carbon(:,:,:)             !! Soil carbon stocks (nbp_loc,ncarb,nvm) (\f$gC m^{-2}\f$)
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE     :: resp_hetero_soil  !! Heterotrophic respiration (\f$gC m^{-2} dt_forcesoil^{-1}\f$) 
+                                                                  !! (requested by soilcarbon routine but not used here) 
+
+  INTEGER(i_std)                             :: ier,iret          !! Used for hangling errors 
+
+  CHARACTER(LEN=30) :: temp_name 
+  LOGICAL :: debug                                                !! boolean used for printing messages
+  LOGICAL :: l_error                                              !! boolean for memory allocation
+  REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:,:) :: matrixA         !! Carbon fluxes matrix*
+  REAL(r_std), DIMENSION(:,:),ALLOCATABLE    :: dummy_veget_max   !! the subroutin soil carbon needs veget_max to check for the
+                                                                  !! closure of the C_balance. This is of interest in this
+                                                                  !! routine. A dummy variable is passed
+
+!_ =================================================================================================================================
+ 
+  CALL Init_orchidee_para
+  CALL init_timer
+
+!-
+! Configure the number of PFTS 
+!-
+  
+  ! 1. Read the number of PFTs
+  !
+  !Config Key   = NVM
+  !Config Desc  = number of PFTs  
+  !Config If    = OK_SECHIBA or OK_STOMATE
+  !Config Def   = 13
+  !Config Help  = The number of vegetation types define by the user
+  !Config Units = [-]
+  CALL getin_p('NVM',nvm)
+
+  ! 2. Allocation
+  l_error = .FALSE.
+  ALLOCATE(pft_to_mtc(nvm),stat=ier)
+  l_error = l_error .OR. (ier .NE. 0)
+  IF (l_error) THEN
+     STOP 'pft_to_mtc (forcesoil only) : error in memory allocation'
+  ENDIF
+
+  ! 3. Initialisation of the correspondance table
+  pft_to_mtc(:) = undef_int
+  
+  ! 4.Reading of the conrrespondance table in the .def file
+  !
+  !Config Key   = PFT_TO_MTC
+  !Config Desc  = correspondance array linking a PFT to MTC
+  !Config if    = OK_SECHIBA or OK_STOMATE
+  !Config Def   = 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13
+  !Config Help  =
+  !Config Units = [-]
+  CALL getin_p('PFT_TO_MTC',pft_to_mtc)
+
+  ! 4.1 if nothing is found, we use the standard configuration
+  IF(nvm == nvmc ) THEN
+     IF(pft_to_mtc(1) == undef_int) THEN
+        WRITE(numout,*) 'Note to the user : we will use ORCHIDEE to its standard configuration'
+        pft_to_mtc(:) = (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13 /)
+     ENDIF
+  ELSE   
+     IF(pft_to_mtc(1) == undef_int) THEN
+        WRITE(numout,*)' The array PFT_TO_MTC is empty : we stop'
+     ENDIF
+  ENDIF
+  
+  ! 4.2 What happened if pft_to_mtc(j) > nvmc (if the mtc doesn't exist)?
+  DO i = 1, nvm
+     IF(pft_to_mtc(i) > nvmc) THEN
+        WRITE(numout,*) "the MTC you chose doesn't exist"
+        STOP 'we stop reading pft_to_mtc'
+     ENDIF
+  ENDDO
+  
+  ! 4.3 Check if pft_to_mtc(1) = 1 
+  IF(pft_to_mtc(1) /= 1) THEN
+     WRITE(numout,*) 'the first pft has to be the bare soil'
+     STOP 'we stop reading next values of pft_to_mtc'
+  ELSE
+     DO i = 2,nvm
+        IF(pft_to_mtc(i) == 1) THEN
+           WRITE(numout,*) 'only pft_to_mtc(1) has to be the bare soil'
+           STOP 'we stop reading pft_to_mtc'
+        ENDIF
+     ENDDO
+  ENDIF
+  
+  ! 5. Allocate and initialize natural ans is_c4
+  
+  ! 5.1 Memory allocation
+  l_error = .FALSE.
+  ALLOCATE(natural(nvm),stat=ier)
+  l_error = l_error .OR. (ier .NE. 0)
+  ALLOCATE(is_c4(nvm),stat=ier)
+
+  IF (l_error) THEN
+     STOP 'natural or is_c4 (forcesoil only) : error in memory allocation'
+  ENDIF
+
+  ! 5.2 Initialisation
+  DO i = 1, nvm
+     natural(i) = natural_mtc(pft_to_mtc(i))
+     is_c4(i) = is_c4_mtc(pft_to_mtc(i))
+  ENDDO
+
+!-
+!-
+! set debug to have more information
+!-
+  !Config Key   = DEBUG_INFO
+  !Config Desc  = Flag for debug information
+  !Config If    = 
+  !Config Def   = n
+  !Config Help  = This option allows to switch on the output of debug
+  !Config         information without recompiling the code.
+  !Config Units = [FLAG]
+!-
+  debug = .FALSE.
+  CALL getin_p('DEBUG_INFO',debug)
+  !!- 
+  !! 1. Initialisation stage
+  !! Reading a set of input files, allocating variables and preparing output restart file.     
+  !!-
+  ! Define restart file name
+  ! for reading initial conditions (sto_restname_in var) and for writting final conditions (sto_restname_out var). 
+  ! User values are used if present in the .def file.
+  ! If not present, default values (stomate_start.nc and stomate_rest_out.c) are used.
+  !-
+  IF (is_root_prc) THEN
+     sto_restname_in = 'stomate_start.nc'
+     CALL getin ('STOMATE_RESTART_FILEIN',sto_restname_in)
+     WRITE(numout,*) 'STOMATE INPUT RESTART_FILE: ',TRIM(sto_restname_in)
+     sto_restname_out = 'stomate_rest_out.nc'
+     CALL getin ('STOMATE_RESTART_FILEOUT',sto_restname_out)
+     WRITE(numout,*) 'STOMATE OUTPUT RESTART_FILE: ',TRIM(sto_restname_out)
+     !-
+     ! Open the input file and Get some Dimension and Attributes ID's 
+     !-
+     iret = NF90_OPEN (sto_restname_in, NF90_NOWRITE, rest_id_sto)
+     iret = NF90_INQUIRE_DIMENSION (rest_id_sto,1,len=iim_g)
+     iret = NF90_INQUIRE_DIMENSION (rest_id_sto,2,len=jjm_g)
+     iret = NF90_INQ_VARID (rest_id_sto, "time", iv)
+     iret = NF90_GET_ATT (rest_id_sto, iv, 'calendar',thecalendar)
+     iret = NF90_CLOSE (rest_id_sto)
+     i=INDEX(thecalendar,ACHAR(0))
+     IF ( i > 0 ) THEN
+        thecalendar(i:20)=' '
+     ENDIF
+     !-
+     ! Allocate longitudes and latitudes
+     !-
+     ALLOCATE (lon(iim_g,jjm_g))
+     ALLOCATE (lat(iim_g,jjm_g))
+     lon(:,:) = zero
+     lat(:,:) = zero
+     lev(1)   = zero
+     !-
+     CALL restini &
+          & (sto_restname_in, iim_g, jjm_g, lon, lat, llm, lev, &
+          &  sto_restname_out, itau_dep, date0, dt_files, rest_id_sto)
+  ENDIF
+
+  CALL bcast(date0)
+  CALL bcast(thecalendar)
+  WRITE(numout,*) "calendar = ",thecalendar
+  !-
+  ! calendar
+  !-
+  CALL ioconf_calendar (thecalendar)
+  CALL ioget_calendar  (one_year,one_day)
+  CALL ioconf_startdate(date0)
+  !
+  !! For master process only
+  !
+  IF (is_root_prc) THEN
+     !-
+     ! define forcing file's name (Cforcing_name var)
+     ! User value is used if present in the .def file
+     ! If not, default (NONE) is used
+     !-
+     Cforcing_name = 'NONE'
+     CALL getin ('STOMATE_CFORCING_NAME',Cforcing_name)
+     !-
+     ! Open FORCESOIL's forcing file to read some basic info (dimensions, variable ID's)
+     ! and allocate variables.
+     !-
+     iret = NF90_OPEN (TRIM(Cforcing_name),NF90_NOWRITE,Cforcing_id)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'forcesoil', &
+             &        'Could not open file : ', &
+             &          Cforcing_name,'(Do you have forget it ?)')
+     ENDIF
+     !-
+     ! Total Domain size is stored in nbp_glo variable
+     !-
+     ier = NF90_GET_ATT (Cforcing_id,NF90_GLOBAL,'kjpindex',x_tmp)
+     nbp_glo = NINT(x_tmp)
+     !-
+     ! Number of values stored per year in the forcing file is stored in nparan var.
+     !-
+     ier = NF90_GET_ATT (Cforcing_id,NF90_GLOBAL,'nparan',x_tmp)
+     nparan = NINT(x_tmp)
+     ier = NF90_GET_ATT (Cforcing_id,NF90_GLOBAL,'nbyear',x_tmp)
+     nbyear = NINT(x_tmp)
+     !-
+     ALLOCATE (indices_g(nbp_glo))
+     ALLOCATE (clay_g(nbp_glo))
+     !-
+     ALLOCATE (x_indices_g(nbp_glo),stat=ier)
+     ier = NF90_INQ_VARID (Cforcing_id,'index',v_id)
+     ier = NF90_GET_VAR   (Cforcing_id,v_id,x_indices_g)
+     indices_g(:) = NINT(x_indices_g(:))
+     WRITE(numout,*) mpi_rank,"indices globaux : ",indices_g
+     DEALLOCATE (x_indices_g)
+     !-
+     ier = NF90_INQ_VARID (Cforcing_id,'clay',v_id)
+     ier = NF90_GET_VAR   (Cforcing_id,v_id,clay_g)
+     !-
+     ! time step of forcesoil program (in days)
+     !-
+     dt_forcesoil = one_year / FLOAT(nparan)
+     WRITE(numout,*) 'time step (d): ',dt_forcesoil
+     WRITE(numout,*) 'nparan: ',nparan
+     WRITE(numout,*) 'nbyear: ',nbyear    
+     !-
+     ! read and write the variables in the output restart file we do not modify within the Forcesoil program
+     ! ie all variables stored in the input restart file except those stored in taboo_vars
+     !-
+     taboo_vars ='$lon$ $lat$ $lev$ $nav_lon$ $nav_lat$ $nav_lev$ $time$ $time_steps$ '// &
+          &             '$day_counter$ $dt_days$ $date$ '
+     !-
+     DO m = 1,nvm
+        WRITE(part_str,'(I2)') m
+        IF (m < 10) part_str(1:1) = '0'
+        temp_name = '$carbon_'//part_str(1:LEN_TRIM(part_str))//'$'
+        taboo_vars = TRIM(taboo_vars)//' '//TRIM(temp_name)
+     ENDDO
+     !-
+     CALL ioget_vname(rest_id_sto, nbvar, varnames)
+     !-
+     ! read and write some special variables (1D or variables that we need)
+     !-
+     var_name = 'day_counter'
+     CALL restget (rest_id_sto, var_name, 1, 1, 1, itau_dep, .TRUE., xtmp)
+     CALL restput (rest_id_sto, var_name, 1, 1, 1, itau_dep, xtmp)
+     !-
+     var_name = 'dt_days'
+     CALL restget (rest_id_sto, var_name, 1, 1, 1, itau_dep, .TRUE., xtmp)
+     CALL restput (rest_id_sto, var_name, 1, 1, 1, itau_dep, xtmp)
+     !-
+     var_name = 'date'
+     CALL restget (rest_id_sto, var_name, 1, 1, 1, itau_dep, .TRUE., xtmp)
+     CALL restput (rest_id_sto, var_name, 1, 1, 1, itau_dep, xtmp)
+     !-
+     DO iv=1,nbvar
+        !-- check if the variable is to be written here
+        IF (INDEX(taboo_vars,'$'//TRIM(varnames(iv))//'$') == 0 ) THEN
+           !---- get variable dimensions, especially 3rd dimension
+           CALL ioget_vdim &
+                &      (rest_id_sto, varnames(iv), varnbdim_max, varnbdim, vardims)
+           l1d = ALL(vardims(1:varnbdim) == 1)
+           !---- read it
+           IF (l1d) THEN
+              CALL restget &
+                   &        (rest_id_sto, TRIM(varnames(iv)), 1, vardims(3), &
+                   &         1, itau_dep, .TRUE., xtmp)
+           ELSE
+              ALLOCATE( var_3d(nbp_glo,vardims(3)), stat=ier)
+              IF (ier /= 0) STOP 'ALLOCATION PROBLEM'
+              !----
+              CALL restget &
+                   &        (rest_id_sto, TRIM(varnames(iv)), nbp_glo, vardims(3), &
+                   &         1, itau_dep, .TRUE., var_3d, "gather", nbp_glo, indices_g)
+           ENDIF
+           !---- write it
+           IF (l1d) THEN
+              CALL restput &
+                   &        (rest_id_sto, TRIM(varnames(iv)), 1, vardims(3), &
+                   &         1, itau_dep, xtmp)
+           ELSE
+              CALL restput &
+                   &        (rest_id_sto, TRIM(varnames(iv)), nbp_glo, vardims(3), &
+                   &         1, itau_dep, var_3d, 'scatter',  nbp_glo, indices_g)
+              !----
+              DEALLOCATE(var_3d)
+           ENDIF
+        ENDIF
+     ENDDO
+     !-
+     ! read soil carbon stocks values stored in the input restart file
+     !-
+     ALLOCATE(carbon_g(nbp_glo,ncarb,nvm))
+     carbon_g(:,:,:) = 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 &
+             &    (rest_id_sto, var_name, nbp_glo, ncarb , 1, itau_dep, &
+             &     .TRUE., carbon_g(:,:,m), 'gather', nbp_glo, indices_g)
+        IF (ALL(carbon_g(:,:,m) == val_exp)) carbon_g(:,:,m) = zero
+        !-- do not write this variable: it will be modified.
+     ENDDO
+     WRITE(numout,*) "date0 : ",date0, itau_dep
+     !-
+     ! Analytical spinup is set to false
+     !
+     spinup_analytic = .FALSE.
+
+     ! Length of the run (in Years)
+     ! User value is used if present in the .def file
+     ! If not, default value (10000 Years) is used
+     !-
+     WRITE(time_str,'(a)') '10000Y'
+     CALL getin('TIME_LENGTH', time_str)
+     write(numout,*) 'Number of years for carbon spinup : ',time_str
+     ! transform into itau
+     CALL tlen2itau(time_str, dt_forcesoil*one_day, date0, itau_len)
+     write(numout,*) 'Number of time steps to do: ',itau_len
+     !-
+     ! read soil carbon inputs, water and temperature stresses on OM decomposition 
+     ! into the forcing file - We read an average year.
+     !-
+     ALLOCATE(soilcarbon_input_g(nbp_glo,ncarb,nvm,nparan*nbyear))
+     ALLOCATE(control_temp_g(nbp_glo,nlevs,nparan*nbyear))
+     ALLOCATE(control_moist_g(nbp_glo,nlevs,nparan*nbyear))
+     !-
+     ier = NF90_INQ_VARID (Cforcing_id,'soilcarbon_input',v_id)
+     ier = NF90_GET_VAR   (Cforcing_id,v_id,soilcarbon_input_g)
+     ier = NF90_INQ_VARID (Cforcing_id,   'control_moist',v_id)
+     ier = NF90_GET_VAR   (Cforcing_id,v_id,control_moist_g)
+     ier = NF90_INQ_VARID (Cforcing_id,    'control_temp',v_id)
+     ier = NF90_GET_VAR   (Cforcing_id,v_id,control_temp_g)
+     !-
+     ier = NF90_CLOSE (Cforcing_id)
+     !-
+  ENDIF
+  CALL bcast(nparan)
+  CALL bcast(nbyear)
+  CALL bcast(dt_forcesoil)
+  CALL bcast(iim_g)
+  CALL bcast(jjm_g)
+  CALL bcast(nbp_glo)
+  CALL bcast(itau_dep)
+  CALL bcast(itau_len)
+  !
+  ! We must initialize data_para :
+     !
+     !
+  CALL init_orchidee_data_para_driver(nbp_glo,indices_g)
+
+  kjpindex=nbp_loc
+  jjm=jj_nb
+  iim=iim_g
+  IF (debug) WRITE(numout,*) "Local grid : ",kjpindex,iim,jjm
+
+  !---
+  !--- Create the index table
+  !---
+  !--- This job returns a LOCAL kindex.
+  !---
+  ALLOCATE (indices(kjpindex),stat=ier)
+  !
+  !! scattering to all processes in parallel mode
+  !
+  CALL scatter(indices_g,indices)
+  indices(1:kjpindex)=indices(1:kjpindex)-(jj_begin-1)*iim_g
+  IF (debug) WRITE(numout,*) mpi_rank,"indices locaux = ",indices(1:kjpindex)
+  !-
+  ! Allocation of the variables for a processor
+  !-
+  ALLOCATE(clay(kjpindex))
+  ALLOCATE(soilcarbon_input(kjpindex,ncarb,nvm,nparan*nbyear))
+  ALLOCATE(control_temp(kjpindex,nlevs,nparan*nbyear))
+  ALLOCATE(control_moist(kjpindex,nlevs,nparan*nbyear))
+  ALLOCATE(carbon(kjpindex,ncarb,nvm))
+  ALLOCATE(resp_hetero_soil(kjpindex,nvm))
+  ALLOCATE(matrixA(kjpindex,nvm,nbpools,nbpools))
+  DO i = 1,nbpools
+     matrixA(:,:,i,i) = un
+  ENDDO
+  iatt = 0
+
+  !-
+  ! Initialization of the variables for a processor
+  !-
+  CALL Scatter(clay_g,clay)
+  CALL Scatter(soilcarbon_input_g,soilcarbon_input)
+  CALL Scatter(control_temp_g,control_temp)
+  CALL Scatter(control_moist_g,control_moist)
+  CALL Scatter(carbon_g,carbon)  
+
+!-
+! Configuration of the parameters
+!-
+
+  !Config Key   = FRAC_CARB_AP
+  !Config Desc  = frac carb coefficients from active pool: depends on clay content
+  !Config if    = OK_STOMATE 
+  !Config Def   = 0.004
+  !Config Help  = fraction of the active pool going to the passive pool
+  !Config Units = [-]
+  CALL getin_p('FRAC_CARB_AP',frac_carb_ap)  
+  !
+  !Config Key   = FRAC_CARB_SA
+  !Config Desc  = frac_carb_coefficients from slow pool
+  !Config if    = OK_STOMATE 
+  !Config Def   = 0.42
+  !Config Help  = fraction of the slow pool going to the active pool
+  !Config Units = [-] 
+  CALL getin_p('FRAC_CARB_SA',frac_carb_sa)
+  !
+  !Config Key   = FRAC_CARB_SP
+  !Config Desc  = frac_carb_coefficients from slow pool
+  !Config if    = OK_STOMATE 
+  !Config Def   = 0.03
+  !Config Help  = fraction of the slow pool going to the passive pool
+  !Config Units = [-] 
+  CALL getin_p('FRAC_CARB_SP',frac_carb_sp)
+  !
+  !Config Key   = FRAC_CARB_PA
+  !Config Desc  = frac_carb_coefficients from passive pool
+  !Config if    = OK_STOMATE 
+  !Config Def   = 0.45
+  !Config Help  = fraction of the passive pool going to the passive pool
+  !Config Units = [-] 
+  CALL getin_p('FRAC_CARB_PA',frac_carb_pa)
+  !
+  !Config Key   = FRAC_CARB_PS
+  !Config Desc  = frac_carb_coefficients from passive pool
+  !Config if    = OK_STOMATE 
+  !Config Def   = 0.0
+  !Config Help  = fraction of the passive pool going to the passive pool
+  !Config Units = [-]
+  CALL getin_p('FRAC_CARB_PS',frac_carb_ps)
+  !
+  !Config Key   = ACTIVE_TO_PASS_CLAY_FRAC
+  !Config Desc  = 
+  !Config if    = OK_STOMATE 
+  !Config Def   =  .68  
+  !Config Help  =
+  !Config Units = [-]
+  CALL getin_p('ACTIVE_TO_PASS_CLAY_FRAC',active_to_pass_clay_frac)
+  !
+  !Config Key   = CARBON_TAU_IACTIVE
+  !Config Desc  = residence times in carbon pools
+  !Config if    = OK_STOMATE 
+  !Config Def   = 0.149
+  !Config Help  =
+  !Config Units = [days] 
+  CALL getin_p('CARBON_TAU_IACTIVE',carbon_tau_iactive)
+  !
+  !Config Key   = CARBON_TAU_ISLOW
+  !Config Desc  = residence times in carbon pools
+  !Config if    = OK_STOMATE 
+  !Config Def   = 5.48
+  !Config Help  =
+  !Config Units = [days]
+  CALL getin_p('CARBON_TAU_ISLOW',carbon_tau_islow)
+  !
+  !Config Key   = CARBON_TAU_IPASSIVE
+  !Config Desc  = residence times in carbon pools
+  !Config if    = OK_STOMATE 
+  !Config Def   = 241.
+  !Config Help  =
+  !Config Units = [days]
+  CALL getin_p('CARBON_TAU_IPASSIVE',carbon_tau_ipassive)
+  !
+  !Config Key   = FLUX_TOT_COEFF
+  !Config Desc  =
+  !Config if    = OK_STOMATE 
+  !Config Def   = 1.2, 1.4,.75
+  !Config Help  =
+  !Config Units = [days]
+  CALL getin_p('FLUX_TOT_COEFF',flux_tot_coeff)
+
+  !!-
+  !! 2. Computational step
+  !! Loop over time - Call of soilcarbon routine at each time step 
+  !! Updated soil carbon stocks are stored into carbon variable
+  !! We only keep the last value of carbon variable (no time dimension).
+  !!-
+  iyear=1
+
+  ! Initialize the dummy variable
+  ALLOCATE(dummy_veget_max(kjpindex,nvm))
+  dummy_veget_max(:,:) = un
+
+  DO i=1,itau_len
+     iatt = iatt+1
+     IF (iatt > nparan*nbyear) THEN
+        IF (debug) WRITE(numout,*) iyear
+        iatt = 1
+        iyear=iyear+1
+     ENDIF
+     CALL soilcarbon &
+          &    (kjpindex, dt_forcesoil, clay, &
+          &     soilcarbon_input(:,:,:,iatt), &
+          &     control_temp(:,:,iatt), control_moist(:,:,iatt), &
+          &     carbon, resp_hetero_soil, &
+          &     matrixA, dummy_veget_max)
+  ENDDO
+  WRITE(numout,*) "End of soilcarbon LOOP."
+
+  !
+  !! Gathering of variables towards main processor in parallel mode
+  !
+  CALL Gather(carbon,carbon_g)
+  !!-
+  !! 3. write new carbon stocks into the ouput restart file
+  !!-
+  IF (is_root_prc) THEN
+     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 &
+             &    (rest_id_sto, var_name, nbp_glo, ncarb , 1, itau_dep, &
+             &     carbon_g(:,:,m), 'scatter', nbp_glo, indices_g)
+     ENDDO
+     !-
+     CALL getin_dump
+     CALL restclo
+  ENDIF
+#ifdef CPP_PARA
+  CALL MPI_FINALIZE(ier)
+#endif
+  WRITE(numout,*) "End of forcesoil."
+  !--------------------
+END PROGRAM forcesoil
Index: branches/publications/ORCHIDEE_CAN_NHA/src_driver/getprec.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_driver/getprec.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_driver/getprec.f90	(revision 7236)
@@ -0,0 +1,57 @@
+!< $HeadURL$ 
+!< $Date$
+!< $Author$
+!< $Revision$
+!-
+PROGRAM getprec
+!---------------------------------------------------------------------
+!- This program verifies that that the number representation
+!- between the different components of the model are compatible
+!---------------------------------------------------------------------
+  USE defprec
+!-
+  IMPLICIT NONE
+!-
+  INTEGER :: i
+  REAL    :: r
+!-
+  INTEGER :: range_int,range_real,precision_real
+!---------------------------------------------------------------------
+  range_int  = RANGE(i)
+  range_real = RANGE(r)
+  precision_real = PRECISION(r)
+!-
+  WRITE(*,*) 'The following ranges and precisions are standard'
+  WRITE(*,*) 'on this computer with your compiler options :'
+  WRITE(*,*) ' INTEGER range     :',range_int
+  WRITE(*,*) ' REAL    range     :',range_real
+  WRITE(*,*) ' REAL    precision :',precision_real
+!-
+  WRITE(*,*) 'The corresponding kinds are :'
+  WRITE(*,*) ' KIND for integer  :', &
+ & SELECTED_INT_KIND(range_int)
+  WRITE(*,*) ' KIND for real     :', &
+ & SELECTED_REAL_KIND(precision_real,range_real)
+!-
+  WRITE(*,*) 'We test if this corresponds to what is used'
+  WRITE(*,*) 'in various parts of the code :'
+!-
+! Real :
+!-
+  IF (SELECTED_REAL_KIND(precision_real,range_real) /= r_std) THEN
+    WRITE(*,*) ' REAL : ERROR, the wrong kind is specified.'
+    WRITE(*,*) ' Use the value above.'
+  ELSE
+    WRITE(*,*) ' REAL    : OK'
+  ENDIF
+!-
+! Integer :
+!-
+  IF (SELECTED_INT_KIND(range_int) /= i_std) THEN
+    WRITE(*,*) ' INTEGER : ERROR, the wrong kind is specified.'
+    WRITE(*,*) ' Use the value above.'
+  ELSE
+    WRITE(*,*) ' INTEGER : OK'
+  ENDIF
+!------------------
+END PROGRAM getprec
Index: branches/publications/ORCHIDEE_CAN_NHA/src_driver/readdim2.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_driver/readdim2.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_driver/readdim2.f90	(revision 7236)
@@ -0,0 +1,2359 @@
+!
+MODULE readdim2
+!---------------------------------------------------------------------
+!< $HeadURL$ 
+!< $Date$
+!< $Author$
+!< $Revision$
+!- IPSL (2006)
+!-  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!-
+   USE ioipsl_para
+   USE weather
+   USE TIMER
+   USE constantes
+   USE solar
+   USE grid
+   USE mod_orchidee_para
+!-
+   IMPLICIT NONE
+!-
+   PRIVATE
+   PUBLIC  :: forcing_read, forcing_info, forcing_grid
+!-
+   INTEGER, SAVE                            :: iim_full, jjm_full, llm_full, ttm_full
+   INTEGER, SAVE                            :: iim_zoom, jjm_zoom
+   INTEGER, SAVE                            :: iim_g_begin,jjm_g_begin,iim_g_end,jjm_g_end
+   REAL, SAVE, ALLOCATABLE, DIMENSION(:,:)  :: data_full, lon_full, lat_full
+   REAL, SAVE, ALLOCATABLE, DIMENSION(:)    :: lev_full
+   INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: itau, i_index, j_index,j_index_g
+   INTEGER, SAVE                            :: i_test, j_test
+   LOGICAL, SAVE                            :: allow_weathergen, interpol, daily_interpol
+   LOGICAL, SAVE, PUBLIC                    :: weathergen, is_watchout
+   REAL, SAVE                               :: merid_res, zonal_res
+   LOGICAL, SAVE                            :: have_zaxis=.FALSE.
+!-
+!- Heigh controls and data 
+!- 
+   LOGICAL, SAVE                            :: zfixed, zsigma, zhybrid, zlevels, zheight 
+   LOGICAL, SAVE                            :: zsamelev_uv 
+   REAL, SAVE                               :: zlev_fixed, zlevuv_fixed 
+   REAL, SAVE                               :: zhybrid_a, zhybrid_b 
+   REAL, SAVE                               :: zhybriduv_a, zhybriduv_b 
+
+CONTAINS
+!-
+!=====================================================================
+!-
+  SUBROUTINE forcing_info(filename, iim, jjm, llm, tm, date0, dt_force,&
+       & force_id)
+
+    !---------------------------------------------------------------------
+    !
+    !- This subroutine will get all the info from the forcing file and
+    !- prepare for the zoom if needed.
+    !- It returns to the caller the sizes of the data it will receive at
+    !- the forcing_read call. This is important so that the caller can
+    !- allocate the right space.
+    !-
+    !- filename   : name of the file to be opened
+    !- iim        : size in x of the forcing data
+    !- jjm        : size in y of the forcing data
+    !- llm        : number of levels in the forcing data (not yet used)
+    !- tm         : Time dimension of the forcing
+    !- date0      : The date at which the forcing file starts (julian days)
+    !- dt_force   : time-step of the forcing file in seconds
+    !- force_id   : ID of the forcing file
+    !-
+    !- ARGUMENTS
+    !-
+    IMPLICIT NONE
+    !-
+    CHARACTER(LEN=*) :: filename
+    INTEGER          :: iim, jjm, llm, tm
+    REAL             :: date0, dt_force
+    INTEGER, INTENT(OUT) :: force_id
+    !- LOCAL
+    CHARACTER(LEN=20) :: calendar_str
+    REAL :: juld_1, juld_2
+    LOGICAL :: debug = .FALSE.
+    REAL, ALLOCATABLE, DIMENSION(:,:) :: fcontfrac
+    REAL, ALLOCATABLE, DIMENSION(:,:) :: qair
+    LOGICAL :: contfrac_exists=.FALSE.
+    INTEGER :: NbPoint
+    INTEGER :: i_test,j_test
+    INTEGER :: i,j,ind,ttm_part
+    INTEGER, ALLOCATABLE, DIMENSION(:)  :: index_l
+    REAL, ALLOCATABLE, DIMENSION(:,:)  :: lon, lat
+    REAL, ALLOCATABLE, DIMENSION(:)    :: lev, levuv
+
+    !-
+    CALL flininfo(filename,  iim_full, jjm_full, llm_full, ttm_full, force_id)
+    !-
+    IF ( debug ) WRITE(numout,*) 'forcing_info : Details from forcing file :', &
+         iim_full, jjm_full, llm_full, ttm_full
+    !-
+    IF ( llm_full < 1 ) THEN
+       have_zaxis = .FALSE.
+    ELSE
+       have_zaxis = .TRUE.
+    ENDIF
+    WRITE(numout,*) 'have_zaxis : ', llm_full, have_zaxis
+    !-
+    ttm_part = 2
+    ALLOCATE(itau(ttm_part))
+    ALLOCATE(data_full(iim_full, jjm_full),lon_full(iim_full, jjm_full),&
+         & lat_full(iim_full, jjm_full))
+    ALLOCATE(lev_full(llm_full))
+    ALLOCATE(fcontfrac(iim_full,jjm_full))
+    !-
+    lev_full(:) = zero
+    !-
+    dt_force=zero
+    CALL flinopen &
+         &  (filename, .FALSE., iim_full, jjm_full, llm_full, lon_full, lat_full, &
+         &   lev_full, ttm_part, itau, date0, dt_force, force_id)
+    IF ( dt_force == zero ) THEN
+       dt_force = itau(2) - itau(1) 
+       itau(:) = itau(:) / dt_force
+    ENDIF
+    !  WRITE(numout,*) "forcing_info : Forcing time step out of flinopen : ",dt_force
+    !-
+    !- What are the alowed options for the temportal interpolation
+    !-
+    !Config Key   = ALLOW_WEATHERGEN
+    !Config Desc  = Allow weather generator to create data
+    !Config If    = [-]
+    !Config Def   = n
+    !Config Help  = This flag allows the forcing-reader to generate
+    !Config         synthetic data if the data in the file is too sparse
+    !Config         and the temporal resolution would not be enough to
+    !Config         run the model.
+    !Config Units = [FLAG]
+    !-
+    allow_weathergen = .FALSE.
+    CALL getin_p('ALLOW_WEATHERGEN',allow_weathergen)
+    !-
+    !- The calendar was set by the forcing file. If no "calendar" attribute was
+    !- found then it is assumed to be gregorian, 
+    !MM => FALSE !! it is NOT assumed anything !
+    !- else it is what ever is written in this attribute.
+    !-
+    CALL ioget_calendar(calendar_str)
+    i=INDEX(calendar_str,ACHAR(0))
+    IF ( i > 0 ) THEN
+       calendar_str(i:20)=' '
+    ENDIF
+    !  WRITE(numout,*) "forcing_info : Calendar used : ",calendar_str
+    IF ( calendar_str == 'XXXX' ) THEN
+       WRITE(numout,*) "forcing_info : The calendar was not found in the forcing file."
+       IF (allow_weathergen) THEN
+          ! Then change the calendar
+          CALL ioconf_calendar("noleap") 
+       ELSE
+          WRITE(numout,*) "forcing_info : We will force it to gregorian by default."
+          CALL ioconf_calendar("gregorian") !! = 365.2425 ; "noleap" = 365.0; "360d"; "julian"=365.25
+       ENDIF
+    ENDIF
+    WRITE(numout,*) "readdim2 : Calendar used by the model : ",calendar_str
+    IF (ttm_full .GE. 2) THEN
+       juld_1 = itau2date(itau(1), date0, dt_force)
+       juld_2 = itau2date(itau(2), date0, dt_force)
+    ELSE
+       juld_1 = 0
+       juld_2 = 0
+       CALL ipslerr_p ( 3, 'forcing_info','What is that only one time step in the forcing file ?', &
+            &         ' That can not be right.','verify forcing file.')
+       STOP
+    ENDIF
+    !-
+    !- Initialize one_year / one_day
+    CALL ioget_calendar (one_year, one_day)
+    !-
+    !- What is the distance between the two first states. From this we will deduce what is
+    !- to be done.
+    weathergen = .FALSE.
+    interpol = .FALSE.
+    daily_interpol = .FALSE.
+    is_watchout = .FALSE.
+    !-
+    IF ( ABS(ABS(juld_2-juld_1)-30.) .LE. 2.) THEN
+       IF ( allow_weathergen ) THEN
+          weathergen = .TRUE.
+          WRITE(numout,*) 'Using weather generator.' 
+       ELSE
+          CALL ipslerr_p ( 3, 'forcing_info', &
+               &         'This seems to be a monthly file.', &
+               &         'We should use a weather generator with this file.', &
+               &         'This should be allowed in the run.def')
+       ENDIF
+    ELSEIF (( ABS(juld_1-juld_2) .LE. 1./4.) .OR. ( ABS(juld_1-juld_2) .EQ. 1.)) THEN
+       interpol = .TRUE.
+       WRITE(numout,*) 'We will interpolate between the forcing data time steps.' 
+       IF ( ABS(juld_1-juld_2) .EQ. 1.) THEN
+          daily_interpol = .TRUE.
+       ENDIF
+    ELSE
+       ! Using the weather generator with data other than monthly ones probably
+       ! needs some thinking.
+       WRITE(numout,*) 'The time step is not suitable:',ABS(juld_1-juld_2),' days.'
+       CALL ipslerr_p ( 3, 'forcing_info','The time step is not suitable.', &
+            &         '','We cannot do anything with these forcing data.')
+    ENDIF
+    !-
+    !- redefine the forcing time step if the weather generator is activated
+    !-
+    IF ( weathergen ) THEN
+       !Config Key   = DT_WEATHGEN
+       !Config Desc  = Calling frequency of weather generator
+       !Config If    = ALLOW_WEATHERGEN
+       !Config Def   = 1800.
+       !Config Help  = Determines how often the weather generator
+       !Config         is called (time step in s). Should be equal
+       !Config         to or larger than Sechiba's time step (say,
+       !Config         up to 6 times Sechiba's time step or so).
+       !Config Units = [seconds]
+       dt_force = 1800.
+       CALL getin_p('DT_WEATHGEN',dt_force)
+    ENDIF
+    !-
+    !- Define the zoom
+    !-
+    !Config Key   = LIMIT_WEST
+    !Config Desc  = Western limit of region
+    !Config If    = [-]
+    !Config Def   = -180.
+    !Config Help  = Western limit of the region we are 
+    !Config         interested in. Between -180 and +180 degrees
+    !Config         The model will use the smalest regions from
+    !Config         region specified here and the one of the forcing file.
+    !Config Units = [Degrees] 
+    !- 
+    limit_west = -180.
+    CALL getin_p('LIMIT_WEST',limit_west)
+    !-
+    !Config Key   = LIMIT_EAST
+    !Config Desc  = Eastern limit of region
+    !Config If    = [-]
+    !Config Def   = 180.
+    !Config Help  = Eastern limit of the region we are
+    !Config         interested in. Between -180 and +180 degrees
+    !Config         The model will use the smalest regions from
+    !Config         region specified here and the one of the forcing file.
+    !Config Units = [Degrees] 
+    !-
+    limit_east = 180.
+    CALL getin_p('LIMIT_EAST',limit_east)
+    !-
+    !Config Key   = LIMIT_NORTH
+    !Config Desc  = Northern limit of region
+    !Config If    = [-]
+    !Config Def   = 90.
+    !Config Help  = Northern limit of the region we are
+    !Config         interested in. Between +90 and -90 degrees
+    !Config         The model will use the smalest regions from
+    !Config         region specified here and the one of the forcing file.
+    !Config Units = [Degrees]
+    !-
+    limit_north = 90.
+    CALL getin_p('LIMIT_NORTH',limit_north)
+    !-
+    !Config Key   = LIMIT_SOUTH
+    !Config Desc  = Southern limit of region
+    !Config If    = [-]
+    !Config Def   = -90.
+    !Config Help  = Southern limit of the region we are
+    !Config         interested in. Between 90 and -90 degrees
+    !Config         The model will use the smalest regions from
+    !Config         region specified here and the one of the forcing file.
+    !Config Units = [Degrees]
+    !-
+    limit_south = -90.
+    CALL getin_p('LIMIT_SOUTH',limit_south)
+    !- 
+    !- Calculate domain size
+    !-
+    IF ( interpol ) THEN
+       !-
+       !- If we use temporal interpolation, then we cannot change the resolution (yet?)
+       !-
+       ALLOCATE(i_index(iim_full), j_index(jjm_full),j_index_g(jjm_full))
+       IF (is_root_prc) THEN
+
+          CALL domain_size (limit_west, limit_east, limit_north, limit_south,&
+               &         iim_full, jjm_full, lon_full, lat_full, iim_zoom, jjm_zoom,&
+               &         i_index, j_index_g)
+
+          j_index(:)=j_index_g(:)
+
+          ALLOCATE(qair(iim_full,jjm_full))
+          CALL flinget (force_id,'Qair',iim_full, jjm_full, 1, ttm_full,  1, 1, data_full)
+          CALL forcing_zoom(data_full, qair)
+
+          CALL flinquery_var(force_id, 'contfrac', contfrac_exists)
+          IF ( contfrac_exists ) THEN
+             WRITE(numout,*) "contfrac exist in the forcing file."
+             CALL flinget (force_id,'contfrac',iim_full, jjm_full, 1, ttm_full,  1, 1, data_full)
+             CALL forcing_zoom(data_full, fcontfrac)
+             WRITE(numout,*) "fcontfrac min/max :",MINVAL(fcontfrac(1:iim_zoom,1:jjm_zoom)),MAXVAL(fcontfrac(1:iim_zoom,1:jjm_zoom))
+          ELSE
+             fcontfrac(:,:)=1.
+          ENDIF
+
+
+          DO i=1,iim_zoom
+             DO j=1,jjm_zoom
+                IF ( fcontfrac(i,j) <= EPSILON(1.) ) THEN
+                   qair(i,j) = 999999.
+                ENDIF
+             ENDDO
+          ENDDO
+
+          ALLOCATE(index_l(iim_zoom*jjm_zoom))
+          !- In this point is returning the global NbPoint with the global index
+          CALL forcing_landind(iim_zoom,jjm_zoom,qair,.TRUE.,NbPoint,index_l,i_test,j_test)
+          ! 
+          ! Work out the vertical layers to be used 
+          ! 
+          CALL forcing_vertical(force_id) 
+       ELSE
+          ALLOCATE(index_l(1))
+       ENDIF
+
+       ! Initiate global grid and parallelism
+       CALL bcast(iim_zoom)
+       CALL bcast(jjm_zoom)
+       CALL bcast(NbPoint)
+       CALL set_grid_glo(iim_zoom,jjm_zoom,NbPoint)
+       CALL allocate_grid_glo
+       !
+       !- global index index_g is the index_l of root proc 
+       IF (is_root_prc) index_g(:)=index_l(1:NbPoint)
+
+       DEALLOCATE(index_l)
+
+       ! 
+       ! Distribute to all processors the information on the forcing 
+       ! 
+       CALL bcast(index_g)
+       CALL Init_orchidee_data_para_driver(nbp_glo,index_g)
+       CALL init_ioipsl_para
+!     CALL Init_writeField_p
+
+       CALL bcast(jjm_zoom)
+       CALL bcast(i_index)
+       CALL bcast(j_index_g)
+       CALL bcast(zfixed) 
+       CALL bcast(zsigma) 
+       CALL bcast(zhybrid) 
+       CALL bcast(zlevels) 
+       CALL bcast(zheight) 
+       CALL bcast(zsamelev_uv) 
+       CALL bcast(zlev_fixed) 
+       CALL bcast(zlevuv_fixed) 
+       CALL bcast(zhybrid_a) 
+       CALL bcast(zhybrid_b) 
+       CALL bcast(zhybriduv_a)  
+       CALL bcast(zhybriduv_b) 
+       ind=0
+       DO j=1,jjm_zoom
+          IF ( (j >= jj_begin) .AND. (j <= jj_end) ) THEN
+             ind=ind+1
+             j_index(ind)=j_index_g(j)
+          ENDIF
+       ENDDO
+
+       jjm_zoom=jj_nb
+       iim_zoom=iim_g
+
+       !-
+       !- If we use the weather generator, then we read zonal and meridional resolutions
+       !- This should be unified one day...
+       !-
+    ELSEIF ( weathergen ) THEN
+       !-
+       !Config Key   = MERID_RES
+       !Config Desc  = North-South Resolution
+       !Config Def   = 2.
+       !Config If    = ALLOW_WEATHERGEN
+       !Config Help  = North-South Resolution of the region we are
+       !Config         interested in. 
+       !Config Units = [Degrees]
+       !-
+       merid_res = 2.
+       CALL getin_p('MERID_RES',merid_res)
+       !-
+       !Config Key   = ZONAL_RES
+       !Config Desc  = East-West Resolution
+       !Config Def   = 2.
+       !Config If    = ALLOW_WEATHERGEN
+       !Config Help  = East-West Resolution of the region we are
+       !Config         interested in. In degrees
+       !Config Units = [Degrees] 
+       !-
+       zonal_res = 2.
+       CALL getin_p('ZONAL_RES',zonal_res)
+       !-
+       !- Number of time steps is meaningless in this case
+       !-
+       !    ttm_full = HUGE( ttm_full )
+       !MM Number (realistic) of time steps for half hour dt
+       ttm_full = NINT(one_year * 86400. / dt_force)
+       !-
+       IF (is_root_prc) THEN
+
+          !- In this point is returning the global NbPoint with the global index
+          CALL weathgen_domain_size (limit_west,limit_east,limit_north,limit_south, &
+               zonal_res,merid_res,iim_zoom,jjm_zoom)
+          ALLOCATE(index_l(iim_zoom*jjm_zoom))
+       ENDIF
+       CALL bcast(iim_zoom)
+       CALL bcast(jjm_zoom)
+
+       ALLOCATE(lon(iim_zoom,jjm_zoom))
+       ALLOCATE(lat(iim_zoom,jjm_zoom))
+       ALLOCATE(lev(llm_full),levuv(llm_full))
+       
+       ! We need lon and lat now for weathgen_init
+       CALL forcing_grid (iim_zoom,jjm_zoom,llm_full,lon,lat,init_f=.TRUE.)
+       CALL forcing_vertical(-1) 
+
+       IF (is_root_prc) THEN
+          CALL weathgen_init &
+               &        (filename,dt_force,force_id,iim_zoom,jjm_zoom, &
+               &         zonal_res,merid_res,lon,lat,index_l,NbPoint)
+!!$,&
+!!$               &         i_index,j_index_g)
+       ELSE
+          ALLOCATE(index_l(1))
+          index_l(1)=1
+       ENDIF
+
+       CALL bcast(NbPoint)
+       CALL set_grid_glo(iim_zoom,jjm_zoom,NbPoint)
+       CALL allocate_grid_glo
+
+       !
+       !- global index index_g is the index_l of root proc 
+       IF (is_root_prc) index_g(:)=index_l(1:NbPoint)
+
+       DEALLOCATE(index_l)
+
+     CALL bcast(index_g)
+     CALL Init_orchidee_data_para_driver(nbp_glo,index_g)
+     CALL init_ioipsl_para
+!     CALL Init_writeField_p
+     CALL bcast(jjm_zoom)
+!!$       CALL bcast(i_index)
+!!$       CALL bcast(j_index_g)
+
+!!$       ind=0
+!!$       DO j=1,jjm_zoom
+!!$          IF ( (j >= jj_begin) .AND. (j <= jj_end) ) THEN
+!!$             ind=ind+1
+!!$             j_index(ind)=j_index_g(j)
+!!$          ENDIF
+!!$       ENDDO
+
+       jjm_zoom=jj_nb
+       iim_zoom=iim_g
+       !
+       CALL weathgen_read_file(force_id,iim_zoom,jjm_zoom)
+
+       !-
+    ELSE
+       !-
+       STOP 'ERROR: Neither interpolation nor weather generator is specified.'
+       !-
+    ENDIF
+    !-
+    !- Transfer the right information to the caller
+    !-
+    iim = iim_zoom
+    jjm = jjm_zoom
+    llm = 1
+    tm = ttm_full
+    !-
+    IF ( debug ) WRITE(numout,*) 'forcing_info : end : ', iim,jjm, llm,tm
+    !-
+  END SUBROUTINE forcing_info
+!-
+!-
+!=====================================================================
+SUBROUTINE forcing_read &
+  & (filename, rest_id, lrstread, lrstwrite, &
+  &  itauin, istp, itau_split, split, nb_spread, netrad_cons, date0,   &
+  &  dt_force, iim, jjm, lon, lat, zlev, zlevuv, ttm, &
+  &  swdown, sinang, precip, snowf, tair, u, v, qair, pb, lwdown, &
+  &  fcontfrac, fneighbours, fresolution, &
+  &  SWnet, Eair, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag, ccanopy, &
+  &  kindex, nbindex, force_id)
+!---------------------------------------------------------------------
+!- filename   : name of the file to be opened
+!- rest_id    : ID of restart file
+!- lrstread   : read restart file?
+!- lrstwrite  : write restart file?
+!- itauin     : time step for which we need the data
+!- istp       : time step for restart file
+!- itau_split : Where are we within the splitting
+!-              of the time-steps of the forcing files
+!-              (it decides IF we READ or not)
+!- split      : The number of time steps we do
+!-              between two time-steps of the forcing
+!- nb_spread  : Over how many time steps do we spread the precipitation
+!- netrad_cons: flag that decides if net radiation should be conserved.
+!- date0      : The date at which the forcing file starts (julian days)
+!- dt_force   : time-step of the forcing file in seconds
+!- iim        : Size of the grid in x
+!- jjm        : size of the grid in y
+!- lon        : Longitudes
+!- lat        : Latitudes
+!- zlev       : First Levels if it exists (ie if watchout file)
+!- zlevuv     : First Levels of the wind (equal precedent, if it exists)
+!- ttm        : number of time steps in all in the forcing file
+!- swdown     : Downward solar radiation (W/m^2)
+!- sinang
+!- precip     : Precipitation (Rainfall) (kg/m^2s)
+!- snowf      : Snowfall (kg/m^2s)
+!- tair       : 1st level (2m ? in off-line) air temperature (K)
+!- u and v    : 1st level (2m/10m ? in off-line) (in theory !) wind speed (m/s)
+!- qair       : 1st level (2m ? in off-line) humidity (kg/kg)
+!- pb         : Surface pressure (Pa)
+!- lwdown     : Downward long wave radiation (W/m^2)
+!- fcontfrac  : Continental fraction (no unit)
+!- fneighbours: land neighbours
+!- fresolution: resolution in x and y dimensions for each points
+!-
+!- From a WATCHOUT file :
+!- SWnet      : Net surface short-wave flux
+!- Eair       : Air potential energy
+!- petAcoef   : Coeficients A from the PBL resolution for T
+!- peqAcoef   : Coeficients A from the PBL resolution for q
+!- petBcoef   : Coeficients B from the PBL resolution for T
+!- peqBcoef   : Coeficients B from the PBL resolution for q
+!- cdrag      : Surface drag
+!- ccanopy    : CO2 concentration in the canopy
+!-
+!- kindex     : Index of all land-points in the data
+!-              (used for the gathering)
+!- nbindex    : Number of land points
+!- force_id   : FLINCOM file id.
+!-              It is used to close the file at the end of the run.
+!-
+!---------------------------------------------------------------------
+   IMPLICIT NONE
+!-
+   CHARACTER(LEN=*) :: filename
+   INTEGER, INTENT(IN) :: force_id
+   INTEGER, INTENT(INOUT) :: nbindex
+   INTEGER :: rest_id
+   LOGICAL :: lrstread, lrstwrite
+   INTEGER :: itauin, istp, itau_split, split, nb_spread
+   LOGICAL :: netrad_cons
+   REAL    :: date0, dt_force
+   INTEGER :: iim, jjm, ttm
+   REAL,DIMENSION(iim,jjm) :: lon, lat, zlev, zlevuv, &
+  & swdown, sinang, precip, snowf, tair, u, v, qair, pb, lwdown, &
+  & fcontfrac
+   REAL,DIMENSION(iim,jjm,2) :: fresolution
+   INTEGER,DIMENSION(iim,jjm,8) :: fneighbours
+   ! for watchout files
+   REAL,DIMENSION(iim,jjm) :: &
+  &  SWnet, Eair, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag, ccanopy
+   INTEGER,DIMENSION(iim*jjm), INTENT(INOUT) :: kindex
+!-
+   INTEGER :: ik,i,j
+!
+   IF ( interpol ) THEN
+!-
+     CALL forcing_read_interpol &
+         (filename, itauin, itau_split, split, nb_spread, netrad_cons, date0,   &
+          dt_force, iim, jjm, lon, lat, zlev, zlevuv, ttm, &
+          swdown, sinang, precip, snowf, tair, u, v, qair, pb, lwdown, &
+          fcontfrac, fneighbours, fresolution, &
+          SWnet, Eair, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag, ccanopy, &
+          kindex, nbindex, force_id)
+!-
+   ELSEIF ( weathergen ) THEN
+!-
+      IF (lrstread) THEN
+         fcontfrac(:,:) = 1.0
+         WRITE(numout,*) 'contfrac : ', MINVAL(fcontfrac), MAXVAL(fcontfrac)
+      ENDIF
+
+      IF ( (itauin == 0).AND.(itau_split == 0) ) THEN
+         CALL weathgen_main (istp, istp, filename, force_id, iim, jjm, 1, &
+              rest_id, lrstread, lrstwrite, &
+              limit_west, limit_east, limit_north, limit_south, &
+              zonal_res, merid_res, lon, lat, date0, dt_force, &
+              kindex, nbindex, &
+              swdown, precip, snowf, tair, u, v, qair, pb, lwdown)
+      ELSE
+         CALL weathgen_main (itauin, istp, filename, force_id, iim, jjm, 1, &
+              rest_id, lrstread, lrstwrite, &
+              limit_west, limit_east, limit_north, limit_south, &
+              zonal_res, merid_res, lon, lat, date0, dt_force, &
+              kindex, nbindex, &
+              swdown, precip, snowf, tair, u, v, qair, pb, lwdown)
+      ENDIF
+!-
+      IF ( (itauin == 0).AND.(itau_split == 0) ) THEN
+         !---
+         !--- Allocate grid stuff
+         !---
+         CALL init_grid ( nbindex )
+         !---
+         !--- Compute
+         !---
+         CALL grid_stuff(nbp_glo, iim_g, jjm_g, lon_g, lat_g, kindex)
+         !CALL grid_stuff (nbindex, iim, jjm, lon, lat, kindex)
+         DO ik=1,nbindex
+         
+            j = ((kindex(ik)-1)/iim) + 1
+            i = (kindex(ik) - (j-1)*iim)
+            !-
+            !- Store variable to help describe the grid
+            !- once the points are gathered.
+            !-
+            fneighbours(i,j,:) = neighbours(ik,:)
+            !
+            fresolution(i,j,:) = resolution(ik,:)
+         ENDDO
+      ENDIF
+   ELSE
+!-
+     STOP 'ERROR: Neither interpolation nor weather generator is specified.'
+!-
+   ENDIF
+!-
+   !WRITE(*,*) 'tair is: ', tair
+   !WRITE(*,*) 'val_exp is: ', val_exp
+
+! IF (.NOT. is_watchout) THEN
+!   DO i=1,iim 
+!       DO j=1,jjm 
+! !      We have to compute Potential air energy
+!          IF(tair(i,j) < val_exp) THEN
+!              eair(:,:) = cp_air*tair(:,:)+cte_grav*zlev(:,:)
+!          END IF
+!       ENDDO
+!    ENDDO
+! END IF
+
+
+   IF (.NOT. is_watchout) THEN
+      ! We have to compute Potential air energy
+      WHERE(tair(:,:) < val_exp) 
+         eair(:,:) = cp_air*tair(:,:)+cte_grav*zlev(:,:)
+      ENDWHERE
+   ENDIF
+!-
+!
+!-------------------------
+END SUBROUTINE forcing_read
+!=====================================================================
+!-
+!-
+!=====================================================================
+SUBROUTINE forcing_read_interpol &
+  & (filename, itauin, itau_split, split, nb_spread, netrad_cons, date0,   &
+  &  dt_force, iim, jjm, lon, lat, zlev, zlevuv, ttm, swdown, sinang, rainf, snowf, tair, &
+  &  u, v, qair, pb, lwdown, &
+  &  fcontfrac, fneighbours, fresolution, &
+  &  SWnet, Eair, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag, ccanopy, &
+  &  kindex, nbindex, force_id)
+!---------------------------------------------------------------------
+!- filename   : name of the file to be opened
+!- itauin     : time step for which we need the data
+!- itau_split : Where are we within the splitting
+!-              of the time-steps of the forcing files
+!-              (it decides IF we READ or not)
+!- split      : The number of time steps we do
+!-              between two time-steps of the forcing
+!- nb_spread  : Over how many time steps do we spread the precipitation
+!- netrad_cons: flag that decides if net radiation should be conserved.
+!- date0      : The date at which the forcing file starts (julian days)
+!- dt_force   : time-step of the forcing file in seconds
+!- iim        : Size of the grid in x
+!- jjm        : size of the grid in y
+!- lon        : Longitudes
+!- lat        : Latitudes
+!- zlev       : First Levels if it exists (ie if watchout file)
+!- zlevuv     : First Levels of the wind (equal precedent, if it exists)
+!- ttm        : number of time steps in all in the forcing file
+!- swdown     : Downward solar radiation (W/m^2)
+!- sinang
+!- rainf      : Rainfall (kg/m^2s)
+!- snowf      : Snowfall (kg/m^2s)
+!- tair       : 2m air temperature (K)
+!- u and v    : 2m (in theory !) wind speed (m/s)
+!- qair       : 2m humidity (kg/kg)
+!- pb         : Surface pressure (Pa)
+!- lwdown     : Downward long wave radiation (W/m^2)
+!- fcontfrac  : Continental fraction (no unit)
+!- fneighbours: land neighbours
+!- fresolution: resolution in x and y dimensions for each points
+!-
+!- From a WATCHOUT file :
+!- SWnet      : Net surface short-wave flux
+!- Eair       : Air potential energy
+!- petAcoef   : Coeficients A from the PBL resolution for T
+!- peqAcoef   : Coeficients A from the PBL resolution for q
+!- petBcoef   : Coeficients B from the PBL resolution for T
+!- peqBcoef   : Coeficients B from the PBL resolution for q
+!- cdrag      : Surface drag
+!- ccanopy    : CO2 concentration in the canopy
+!- 
+!- kindex     : Index of all land-points in the data
+!-              (used for the gathering)
+!- nbindex    : Number of land points
+!- force_id   : FLINCOM file id.
+!-              It is used to close the file at the end of the run.
+!---------------------------------------------------------------------
+   IMPLICIT NONE
+!-
+   INTEGER,PARAMETER :: lm=1
+!-
+!- Input variables
+!-
+   CHARACTER(LEN=*) :: filename
+   INTEGER :: itauin, itau_split, split, nb_spread
+   LOGICAL :: netrad_cons
+   REAL    :: date0, dt_force
+   INTEGER :: iim, jjm, ttm
+   REAL,DIMENSION(:,:),INTENT(IN) :: lon, lat   !- LOCAL data array (size=iim,jjm)
+   INTEGER, INTENT(IN) :: force_id
+!-
+!- Output variables
+!-
+   REAL,DIMENSION(:,:),INTENT(OUT) :: zlev, zlevuv, &  !- LOCAL data array (size=iim,jjm)
+  &  swdown, sinang, rainf, snowf, tair, u, v, qair, pb, lwdown, &
+  &  fcontfrac
+   REAL,DIMENSION(:,:,:),INTENT(OUT) :: fresolution    !- LOCAL data array (size=iim,jjm,2)
+   INTEGER,DIMENSION(:,:,:),INTENT(OUT) :: fneighbours !- LOCAL data array (size=iim,jjm,8)
+   ! for watchout files
+   REAL,DIMENSION(:,:),INTENT(OUT) :: &
+  &  SWnet, Eair, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag, ccanopy
+   INTEGER,DIMENSION(:),INTENT(INOUT) :: kindex    !- LOCAL index of the map
+   INTEGER, INTENT(INOUT) :: nbindex
+!-
+!- Local variables
+!-
+   INTEGER, SAVE :: last_read=0
+   INTEGER, SAVE :: itau_read, itau_read_nm1=0, itau_read_n=0
+   REAL,SAVE,ALLOCATABLE,DIMENSION(:,:) :: &
+  &  zlev_nm1, zlevuv_nm1, swdown_nm1, rainf_nm1, snowf_nm1, tair_nm1, u_nm1, v_nm1, qair_nm1, & 
+  &  pb_nm1, lwdown_nm1, & 
+  &  zlev_n, zlevuv_n, swdown_n, rainf_n, snowf_n, tair_n, u_n, v_n, qair_n, &
+  &  pb_n, lwdown_n, mean_sinang
+
+   REAL,SAVE,ALLOCATABLE,DIMENSION(:,:) :: &
+  &  startday_n, startday_nm1, daylength_n, daylength_nm1, tmax_n, tmax_nm1, tmin_nm1, tmin_nm2, tmin_n,   &
+  &  qsatta, qsattmin_n, qsattmin_nm1, qmin_n, qmin_nm1, qmax_n, qmax_nm1, qsa
+   REAL,SAVE    :: hour
+
+!  just for grid stuff if the forcing file is a watchout file
+   REAL, ALLOCATABLE, DIMENSION(:,:) :: tmpdata
+   ! variables to be read in watchout files
+   REAL,SAVE,ALLOCATABLE,DIMENSION(:,:) :: &
+  &  SWnet_nm1, Eair_nm1, petAcoef_nm1, peqAcoef_nm1, petBcoef_nm1, peqBcoef_nm1, cdrag_nm1, ccanopy_nm1, &
+  &  SWnet_n, Eair_n, petAcoef_n, peqAcoef_n, petBcoef_n, peqBcoef_n, cdrag_n, ccanopy_n
+   REAL, SAVE :: julian_for ! Date of the forcing to be read
+   REAL :: julian, ss, rw
+!jur, 
+   REAL, SAVE :: julian0    ! First day of this year
+   INTEGER :: yy, mm, dd, is, i, j, ik
+!  if Wind_N and Wind_E are in the file (and not just Wind)
+   LOGICAL, SAVE :: wind_N_exists=.FALSE.
+   LOGICAL       :: wind_E_exists=.FALSE.
+   LOGICAL, SAVE :: contfrac_exists=.FALSE.
+   LOGICAL, SAVE :: neighbours_exists=.FALSE.
+   LOGICAL, SAVE :: initialized = .FALSE.
+   LOGICAL :: check=.FALSE.
+!  to bypass FPE problem on integer convertion with missing_value heigher than precision
+   INTEGER, PARAMETER                         :: undef_int = 999999999
+!---------------------------------------------------------------------
+   IF (check) THEN
+     WRITE(numout,*) &
+    &  " FORCING READ : itau_read, itau_split : ",itauin,itau_split
+   ENDIF
+!-
+!!$   itau_read = itauin
+   itau_read = MOD((itauin-1),ttm)+1
+!-
+!- This part initializes the reading of the forcing. As you can see
+!- we only go through here if both time steps are zero.
+!- 
+   IF ( (itau_read == 0).AND.(itau_split == 0) ) THEN
+!-
+!- Tests on forcing file type
+     CALL flinquery_var(force_id, 'Wind_N', wind_N_exists)
+     IF ( wind_N_exists ) THEN
+        CALL flinquery_var(force_id, 'Wind_E', wind_E_exists)
+        IF ( .NOT. wind_E_exists ) THEN
+           CALL ipslerr_p(3,'forcing_read_interpol', &
+   &             'Variable Wind_E does not exist in forcing file', &
+   &             'But variable Wind_N exists.','Please, rename Wind_N to Wind;') 
+        ENDIF
+     ENDIF
+     CALL flinquery_var(force_id, 'levels', is_watchout)
+     IF ( is_watchout ) THEN
+        WRITE(numout,*) "Read a Watchout File."
+     ENDIF
+     CALL flinquery_var(force_id, 'contfrac', contfrac_exists)
+!-
+     IF (check) WRITE(numout,*) 'ALLOCATE all the memory needed'
+!-
+     ALLOCATE &
+    &  (swdown_nm1(iim,jjm), rainf_nm1(iim,jjm), snowf_nm1(iim,jjm), &
+    &   tair_nm1(iim,jjm), u_nm1(iim,jjm), v_nm1(iim,jjm), qair_nm1(iim,jjm), &
+    &   pb_nm1(iim,jjm), lwdown_nm1(iim,jjm))
+     ALLOCATE &
+    &  (swdown_n(iim,jjm), rainf_n(iim,jjm), snowf_n(iim,jjm), &
+    &   tair_n(iim,jjm), u_n(iim,jjm), v_n(iim,jjm), qair_n(iim,jjm), &
+    &   pb_n(iim,jjm), lwdown_n(iim,jjm))
+
+     IF(daily_interpol) THEN
+        ALLOCATE &
+       &  (startday_n(iim,jjm), startday_nm1(iim,jjm), daylength_n(iim,jjm), &
+       &   daylength_nm1(iim,jjm), tmax_n(iim,jjm), tmax_nm1(iim,jjm), tmin_n(iim,jjm), &
+       &   tmin_nm1(iim,jjm), tmin_nm2(iim,jjm), qsatta(iim,jjm), qsattmin_n(iim,jjm), qsattmin_nm1(iim,jjm), &
+       &   qmin_n(iim,jjm), qmin_nm1(iim,jjm), qmax_n(iim,jjm), qmax_nm1(iim,jjm), qsa(iim,jjm) )
+     ENDIF
+
+
+     ALLOCATE &
+    &  (zlev_nm1(iim,jjm), zlev_n(iim,jjm), zlevuv_nm1(iim,jjm), zlevuv_n(iim,jjm), &
+    &   SWnet_nm1(iim,jjm), Eair_nm1(iim,jjm), cdrag_nm1(iim,jjm), ccanopy_nm1(iim,jjm), &
+    &   petAcoef_nm1(iim,jjm), peqAcoef_nm1(iim,jjm), petBcoef_nm1(iim,jjm), peqBcoef_nm1(iim,jjm), &
+    &   SWnet_n(iim,jjm), Eair_n(iim,jjm), cdrag_n(iim,jjm), ccanopy_n(iim,jjm), &
+    &   petAcoef_n(iim,jjm), peqAcoef_n(iim,jjm), petBcoef_n(iim,jjm), peqBcoef_n(iim,jjm))
+     ALLOCATE &
+    &  (mean_sinang(iim,jjm))
+!-
+     IF (check) WRITE(numout,*) 'Memory ALLOCATED'
+!-
+!- We need for the driver surface air temperature and humidity before the
+!- the loop starts. Thus we read it here.
+!-     
+     CALL forcing_just_read (iim, jjm, zlev, zlevuv, ttm, 1, 1, &
+          &  swdown, rainf, snowf, tair, &
+          &  u, v, qair, pb, lwdown, &
+          &  SWnet, Eair, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag, ccanopy, &
+          &  force_id, wind_N_exists, check)
+
+!----
+
+!-- First in case it's not a watchout file
+     IF ( .NOT. is_watchout ) THEN
+        IF ( contfrac_exists ) THEN
+           WRITE(numout,*) "contfrac exist in the forcing file."
+           CALL flinget (force_id,'contfrac',iim_full, jjm_full, llm_full, ttm,  1, 1, data_full)
+           CALL forcing_zoom(data_full, fcontfrac)
+           WRITE(numout,*) "fcontfrac min/max :",MINVAL(fcontfrac(1:iim_zoom,jjm_zoom)),MAXVAL(fcontfrac(1:iim_zoom,jjm_zoom))
+           !
+           ! We need to make sure that when we gather the points we pick all
+           ! the points where contfrac is above 0. Thus we prepare tair for
+           ! subroutine forcing_landind
+           !
+           DO i=1,iim
+              DO j=1,jjm
+                 IF ( j==1 .AND. i<ii_begin) fcontfrac(i,j)=0.     ! bande de recouvrement du scatter2D 
+                 IF ( j==jjm .AND. i>ii_end) fcontfrac(i,j)=0.     ! => on mets les données qu'on veut pas du noeud à missing_value
+                 IF ( fcontfrac(i,j) <= EPSILON(1.) ) THEN
+                    tair(i,j) = 999999.
+                 ENDIF
+              ENDDO
+           ENDDO
+        ELSE
+           fcontfrac(:,:) = 1.0
+        ENDIF
+        !---
+        !--- Create the index table
+        !---
+        !--- This job return a LOCAL kindex
+        CALL forcing_landind(iim, jjm, tair, check, nbindex, kindex, i_test, j_test)
+#ifdef CPP_PARA
+        ! We keep previous function forcing_landind, only to get a valid (i_test,j_test) 
+        ! Force nbindex points for parallel computation
+        nbindex=nbp_loc
+        CALL scatter(index_g,kindex(1:nbindex))
+        kindex(1:nbindex)=kindex(1:nbindex)-(jj_begin-1)*iim_g
+#endif
+        ik=MAX(nbindex/2,1)
+        j_test = (((kindex(ik)-1)/iim) + 1)
+        i_test = (kindex(ik) - (j_test-1)*iim)
+        IF (check) THEN
+           WRITE(numout,*) 'New test point is : ', i_test, j_test
+        ENDIF
+        !---
+        !--- Allocate grid stuff
+        !---
+        CALL init_grid ( nbindex )
+        !---
+        !--- All grid variables
+        !---
+        CALL grid_stuff(nbp_glo, iim_g, jjm_g, lon_g, lat_g, kindex)
+        DO ik=1,nbindex
+           !
+           j = ((kindex(ik)-1)/iim) + 1
+           i = (kindex(ik) - (j-1)*iim)
+           !-
+           !- Store variable to help describe the grid
+           !- once the points are gathered.
+              !-
+           fneighbours(i,j,:) = neighbours(ik,:)
+           !
+           fresolution(i,j,:) = resolution(ik,:)
+        ENDDO
+     ELSE
+!-- Second, in case it is a watchout file
+        ALLOCATE (tmpdata(iim,jjm))
+        tmpdata(:,:) = 0.0
+!--
+        IF ( .NOT. contfrac_exists ) THEN
+           CALL ipslerr_p (3,'forcing_read_interpol', &
+ &          'Could get contfrac variable in a watchout file :',TRIM(filename), &
+ &          '(Problem with file ?)')
+        ENDIF
+        CALL flinget (force_id,'contfrac',iim_full, jjm_full, llm_full, ttm,  1, 1, data_full)
+        CALL forcing_zoom(data_full, fcontfrac)
+        !
+        ! We need to make sure that when we gather the points we pick all
+        ! the points where contfrac is above 0. Thus we prepare tair for
+        ! subroutine forcing_landind
+        !
+        DO i=1,iim
+           DO j=1,jjm
+	      IF ( j==1 .AND. i<ii_begin) fcontfrac(i,j)=0.
+	      IF ( j==jjm .AND. i>ii_end) fcontfrac(i,j)=0.
+              IF ( fcontfrac(i,j) <= EPSILON(1.) ) THEN
+                 tair(i,j) = 999999.
+              ENDIF
+           ENDDO
+        ENDDO
+        !---
+        !--- Create the index table
+        !---
+        !--- This job return a LOCAL kindex
+        CALL forcing_landind(iim, jjm, tair, check, nbindex, kindex, i_test, j_test)
+#ifdef CPP_PARA
+        ! We keep previous function forcing_landind, only to get a valid (i_test,j_test) 
+        ! Force nbindex points for parallel computation
+        nbindex=nbp_loc
+        CALL scatter(index_g,kindex)
+        kindex(:)=kindex(:)-offset
+!        kindex(:)=kindex(:)-(jj_begin-1)*iim_g
+#endif
+        ik=MAX(nbindex/2,1)
+        j_test = (((kindex(ik)-1)/iim) + 1)
+        i_test = (kindex(ik) - (j_test-1)*iim)
+        IF (check) THEN
+           WRITE(numout,*) 'New test point is : ', i_test, j_test
+        ENDIF
+        !---
+        !--- Allocate grid stuff
+        !---
+        CALL init_grid ( nbindex )
+        neighbours(:,:) = -1
+        resolution(:,:) = 0.
+        min_resol(:) = 1.e6
+        max_resol(:) = -1.
+        !---
+        !--- All grid variables
+        !---
+        !-
+        !- Get variables to help describe the grid
+        CALL flinquery_var(force_id, 'neighboursNN', neighbours_exists)
+        IF ( .NOT. neighbours_exists ) THEN
+           CALL ipslerr_p (3,'forcing_read_interpol', &
+ &          'Could get neighbours in a watchout file :',TRIM(filename), &
+ &          '(Problem with file ?)')
+        ELSE
+           WRITE(numout,*) "Watchout file contains neighbours and resolutions."
+        ENDIF
+        !
+        fneighbours(:,:,:) = undef_int
+        !
+        !- once the points are gathered.
+        CALL flinget (force_id,'neighboursNN',iim_full, jjm_full, llm_full, ttm,  1, 1, data_full)
+        CALL forcing_zoom(data_full, tmpdata)
+        WHERE(tmpdata(:,:) < undef_int)
+           fneighbours(:,:,1) = NINT(tmpdata(:,:))
+        ENDWHERE
+        !
+        CALL flinget (force_id,'neighboursNE',iim_full, jjm_full, llm_full, ttm,  1, 1, data_full)
+        CALL forcing_zoom(data_full, tmpdata)
+        WHERE(tmpdata(:,:) < undef_int)
+           fneighbours(:,:,2) = NINT(tmpdata(:,:))
+        ENDWHERE
+        !
+        CALL flinget (force_id,'neighboursEE',iim_full, jjm_full, llm_full, ttm,  1, 1, data_full)
+        CALL forcing_zoom(data_full, tmpdata)
+        WHERE(tmpdata(:,:) < undef_int)
+           fneighbours(:,:,3) = NINT(tmpdata(:,:))
+        ENDWHERE
+        !
+        CALL flinget (force_id,'neighboursSE',iim_full, jjm_full, llm_full, ttm,  1, 1, data_full)
+        CALL forcing_zoom(data_full, tmpdata)
+        WHERE(tmpdata(:,:) < undef_int)
+           fneighbours(:,:,4) = NINT(tmpdata(:,:))
+        ENDWHERE
+        !
+        CALL flinget (force_id,'neighboursSS',iim_full, jjm_full, llm_full, ttm,  1, 1, data_full)
+        CALL forcing_zoom(data_full, tmpdata)
+        WHERE(tmpdata(:,:) < undef_int)
+           fneighbours(:,:,5) = NINT(tmpdata(:,:))
+        ENDWHERE
+        !
+        CALL flinget (force_id,'neighboursSW',iim_full, jjm_full, llm_full, ttm,  1, 1, data_full)
+        CALL forcing_zoom(data_full, tmpdata)
+        WHERE(tmpdata(:,:) < undef_int)
+           fneighbours(:,:,6) = NINT(tmpdata(:,:))
+        ENDWHERE
+        !
+        CALL flinget (force_id,'neighboursWW',iim_full, jjm_full, llm_full, ttm,  1, 1, data_full)
+        CALL forcing_zoom(data_full, tmpdata)
+        WHERE(tmpdata(:,:) < undef_int)
+           fneighbours(:,:,7) = NINT(tmpdata(:,:))
+        ENDWHERE
+        !
+        CALL flinget (force_id,'neighboursNW',iim_full, jjm_full, llm_full, ttm,  1, 1, data_full)
+        CALL forcing_zoom(data_full, tmpdata)
+        WHERE(tmpdata(:,:) < undef_int)
+           fneighbours(:,:,8) = NINT(tmpdata(:,:))
+        ENDWHERE
+        !
+        ! now, resolution of the grid
+        CALL flinget (force_id,'resolutionX',iim_full, jjm_full, llm_full, ttm,  1, 1, data_full)
+        CALL forcing_zoom(data_full, tmpdata)
+        fresolution(:,:,1) = tmpdata(:,:)
+        !
+        CALL flinget (force_id,'resolutionY',iim_full, jjm_full, llm_full, ttm,  1, 1, data_full)
+        CALL forcing_zoom(data_full, tmpdata)
+        fresolution(:,:,2) = tmpdata(:,:)
+        !
+        DO ik=1,nbindex
+           !
+           j = ((kindex(ik)-1)/iim) + 1
+           i = (kindex(ik) - (j-1)*iim)
+           !-
+           !- Store variable to help describe the grid
+           !- once the points are gathered.
+           !-
+           neighbours(ik,:) = fneighbours(i,j,:)  
+           !
+           resolution(ik,:) = fresolution(i,j,:)
+           !
+        
+        ENDDO
+        CALL gather(neighbours,neighbours_g)
+        CALL gather(resolution,resolution_g)
+        min_resol(1) = MINVAL(resolution(:,1))
+        min_resol(2) = MAXVAL(resolution(:,2))
+        max_resol(1) = MAXVAL(resolution(:,1))
+        max_resol(2) = MAXVAL(resolution(:,2))
+        !
+        area(:) = resolution(:,1)*resolution(:,2)
+        CALL gather(area,area_g)
+!--
+        DEALLOCATE (tmpdata)
+     ENDIF
+     WRITE(numout,*) 'contfrac : ', MINVAL(fcontfrac), MAXVAL(fcontfrac)
+!---
+   ENDIF
+!---
+   IF (check) THEN
+      WRITE(numout,*) &
+           & 'The dates : ',itau_read,itau_split,itau_read_nm1,itau_read_n
+   ENDIF
+!---
+!--- Here we do the work in case only interpolation is needed.
+!---
+   IF ( initialized .AND. interpol ) THEN
+!---
+      IF ( daily_interpol ) THEN
+
+         IF (split > 1) THEN
+            IF ( itau_split <= (split/2.) ) THEN
+               rw = REAL(itau_split+split/2.)/split
+            ELSE 
+               rw = REAL(itau_split-split/2.)/split
+            ENDIF
+         ELSE
+            rw = 1.
+         ENDIF
+
+         IF ((last_read == 0) .OR. ( rw==(1./split)) ) THEN
+   !---
+   !-----   Start or Restart
+            IF (last_read == 0) THEN
+               ! Case of a restart or a shift in the forcing file.
+               IF (itau_read > 1) THEN
+                  itau_read_nm1=itau_read-1
+                  CALL forcing_just_read (iim, jjm, zlev_nm1, zlevuv_nm1, ttm, itau_read_nm1, itau_read_nm1, &
+                       &  swdown_nm1, rainf_nm1, snowf_nm1, tmin_nm1, &
+                       &  u_nm1, v_nm1, qair_nm1, pb_nm1, lwdown_nm1, &
+                       &  SWnet_nm1, Eair_nm1, petAcoef_nm1, peqAcoef_nm1, petBcoef_nm1, peqBcoef_nm1, cdrag_nm1, ccanopy_nm1, &
+                       &  force_id, wind_N_exists, check)
+                  CALL forcing_just_read_tmax (iim, jjm, ttm, itau_read_nm1, itau_read_nm1, tmax_nm1, force_id )
+               ! Case of a simple start.
+               ELSE 
+                  itau_read_nm1 = un
+                  WRITE(numout,*) "we will use the forcing of the first day to initialize "
+                  CALL forcing_just_read (iim, jjm, zlev_nm1, zlevuv_nm1, ttm, itau_read_nm1, itau_read_nm1, &
+                       &  swdown_nm1, rainf_nm1, snowf_nm1, tmin_nm1, &
+                       &  u_nm1, v_nm1, qair_nm1, pb_nm1, lwdown_nm1, &
+                       &  SWnet_nm1, Eair_nm1, petAcoef_nm1, peqAcoef_nm1, petBcoef_nm1, peqBcoef_nm1, cdrag_nm1, ccanopy_nm1, &
+                       &  force_id, wind_N_exists, check)
+                  CALL forcing_just_read_tmax (iim, jjm, ttm, itau_read_nm1, itau_read_nm1, tmax_nm1, force_id )
+               ENDIF
+               tmin_nm2(:,:)=tmin_nm1(:,:)
+               IF ( dt_force .GT. 3600. ) THEN 
+                  mean_sinang(:,:) = 0.0
+                  daylength_n(:,:) = 0.
+                  DO is=1,split
+                     !MM we compute mean SWdown between t and t+Dt then I take t+Dt/2. 
+                     julian = julian_for+((is-0.5)/split)*dt_force/one_day
+      !!$               julian = julian_for+(FLOAT(is)/split)*dt_force/one_day
+                     CALL solarang (julian, julian0, iim, jjm, lon*0, lat, sinang)
+                     mean_sinang(:,:) = mean_sinang(:,:)+sinang(:,:)
+                     WHERE( sinang(:,:) > 0. ) 
+                        daylength_n(:,:)=daylength_n(:,:)+1./split*24
+                     ENDWHERE
+                  ENDDO
+                  mean_sinang(:,:) = mean_sinang(:,:)/split
+                  daylength_nm1(:,:)=daylength_n(:,:)
+      !            WRITE(*,*) "mean_sinang =",MAXVAL(mean_sinang)
+               ENDIF
+            ELSE
+   !-----   Normal mode : copy old step
+               swdown_nm1(:,:) = swdown_n(:,:)
+               rainf_nm1(:,:) = rainf_n(:,:)
+               snowf_nm1(:,:)  = snowf_n(:,:) 
+               tair_nm1(:,:)   = tair_n(:,:)
+               u_nm1(:,:)      = u_n(:,:)
+               v_nm1(:,:)      = v_n(:,:)
+               qair_nm1(:,:)   = qair_n(:,:)
+               pb_nm1(:,:)     = pb_n(:,:)
+               lwdown_nm1(:,:) = lwdown_n(:,:)
+               tmin_nm2(:,:)   = tmin_nm1(:,:)
+               tmin_nm1(:,:)   = tmin_n(:,:)
+               tmax_nm1(:,:)   = tmax_n(:,:)
+
+               IF (is_watchout) THEN
+                  zlev_nm1(:,:)   = zlev_n(:,:)
+                  zlevuv_nm1(:,:) = zlevuv_n(:,:)
+                  ! Net surface short-wave flux
+                  SWnet_nm1(:,:) = SWnet_n(:,:)
+                  ! Air potential energy
+                  Eair_nm1(:,:)   = Eair_n(:,:)
+                  ! Coeficients A from the PBL resolution for T
+                  petAcoef_nm1(:,:) = petAcoef_n(:,:)
+                  ! Coeficients A from the PBL resolution for q
+                  peqAcoef_nm1(:,:) = peqAcoef_n(:,:)
+                  ! Coeficients B from the PBL resolution for T
+                  petBcoef_nm1(:,:) = petBcoef_n(:,:)
+                  ! Coeficients B from the PBL resolution for q
+                  peqBcoef_nm1(:,:) = peqBcoef_n(:,:)
+                  ! Surface drag
+                  cdrag_nm1(:,:) = cdrag_n(:,:)
+                  ! CO2 concentration in the canopy
+                  ccanopy_nm1(:,:) = ccanopy_n(:,:)
+               ENDIF
+               itau_read_nm1 = itau_read_n
+            ENDIF
+   !-----
+   !-----
+            IF(last_read==0)THEN
+               itau_read_n = itau_read
+            ELSE
+               itau_read_n = itau_read+1
+            ENDIF
+
+            IF (itau_read_n > ttm) THEN
+               WRITE(numout,*) 'WARNING --WARNING --WARNING --WARNING '
+               WRITE(numout,*) &
+                    &  'WARNING : We are going back to the start of the file'
+               itau_read_n =1
+            ENDIF
+            IF (check) THEN
+               WRITE(numout,*) &
+                    & 'The dates 2 : ',itau_read,itau_split,itau_read_nm1,itau_read_n
+            ENDIF
+           WRITE(numout,*) "YCHEN CHECK DT:", dt_force
+   !-----
+   !----- Get a reduced julian day !
+   !----- This is needed because we lack the precision on 32 bit machines.
+   !-----
+            IF ( dt_force .GT. 3600. ) THEN
+               julian_for = itau2date(itau_read-1, date0, dt_force)
+               CALL ju2ymds (julian_for, yy, mm, dd, ss)
+   
+               ! first day of this year
+               CALL ymds2ju (yy,1,1,0.0, julian0)
+   !-----
+               IF (check) THEN
+                  WRITE(numout,*) 'YCHEN Forcing for Julian day ',julian_for,'time step:',itau_read
+                  WRITE(numout,*) 'YCHEN Date for this day ',yy,' / ',mm,' / ',dd,"  ",ss
+               ENDIF
+            ENDIF
+   !-----
+            CALL forcing_just_read (iim, jjm, zlev_n, zlevuv_n, ttm, itau_read_n, itau_read_n, &
+                 &  swdown_n, rainf_n, snowf_n, tmin_n, &
+                 &  u_n, v_n, qair_n, pb_n, lwdown_n, &
+                 &  SWnet_n, Eair_n, petAcoef_n, peqAcoef_n, petBcoef_n, peqBcoef_n, cdrag_n, ccanopy_n, &
+                 &  force_id, wind_N_exists, check)
+            CALL forcing_just_read_tmax (iim, jjm, ttm, itau_read_n, itau_read_n, tmax_n, force_id )
+
+   !---
+            last_read = itau_read_n
+   !-----
+   !----- Compute mean solar angle for the comming period
+   !-----
+            IF (check) WRITE(numout,*) 'Going into  solarang', split, one_day
+   !-----
+
+   !-----
+         ENDIF
+   !---
+         IF ( rw == (split/2.+ 1./split )) THEN
+            IF ( dt_force .GT. 3600. ) THEN
+               mean_sinang(:,:) = 0.0
+               daylength_nm1(:,:)=daylength_n(:,:)
+               daylength_n(:,:) = 0.
+               DO is=1,split
+                  !MM we compute mean SWdown between t and t+Dt then I take t+Dt/2. 
+                  julian = julian_for+((is-0.5)/split)*dt_force/one_day
+   !!$               julian = julian_for+(FLOAT(is)/split)*dt_force/one_day
+                  CALL solarang (julian, julian0, iim, jjm, lon*0, lat, sinang)
+   !               WRITE(numout,*) "YCHEN call 1"
+                  mean_sinang(:,:) = mean_sinang(:,:)+sinang(:,:)
+                  WHERE( sinang(:,:) > 0. ) 
+                     daylength_n(:,:)=daylength_n(:,:)+1./split*24
+                  ENDWHERE
+               ENDDO
+               mean_sinang(:,:) = mean_sinang(:,:)/split
+   !            WRITE(*,*) "mean_sinang =",MAXVAL(mean_sinang)
+            ENDIF
+         ENDIF
+ 
+   !--- Do the interpolation
+         IF (check) WRITE(numout,*) 'Doing the interpolation between time steps'
+   !---
+
+         IF (check) WRITE(numout,*) 'Coeff of interpollation : ',rw
+   !---
+
+         pb(:,:) = (pb_n(:,:)-pb_nm1(:,:))*rw + pb_nm1(:,:)
+         u(:,:)  = (u_n(:,:)-u_nm1(:,:))*rw + u_nm1(:,:)
+         v(:,:)  = (v_n(:,:)-v_nm1(:,:))*rw + v_nm1(:,:)
+
+   !--- Take care of the height of the vertical levels 
+         zlev(:,:) = (zlev_n(:,:)-zlev_nm1(:,:))*rw + zlev_nm1(:,:) 
+         zlevuv(:,:) = (zlevuv_n(:,:)-zlevuv_nm1(:,:))*rw + zlevuv_nm1(:,:) 
+
+         hour=REAL(itau_split)/split*24
+         startday_n(:,:)=12.-daylength_n(:,:)/2.
+         startday_nm1(:,:)=12.-daylength_nm1(:,:)/2.
+
+         WHERE ( ( hour >= startday_n(:,:) ) .AND. ( hour > 12) .AND. ( hour <= 14) )
+            tair(:,:)=(tmax_nm1(:,:)-tmin_nm1(:,:))/2 * ( sin(pi/(14-startday_n(:,:))*(hour-0.5* &
+           &    (14.-startday_n(:,:))-startday_n(:,:))) )+ (tmax_nm1(:,:)+tmin_nm1(:,:))/2.
+         ELSEWHERE( ( hour >= startday_n(:,:) ) .AND. ( hour <= 12) )
+            tair(:,:)=(tmax_n(:,:)-tmin_n(:,:))/2 * ( sin(pi/(14-startday_n(:,:))*(hour-0.5* &
+           &    (14.-startday_n(:,:))-startday_n(:,:))) )+ (tmax_n(:,:)+tmin_n(:,:))/2.
+         ELSEWHERE ( hour < startday_n(:,:) )
+            tair(:,:)=(tmax_nm1(:,:)-tmin_n(:,:))/2.*sin(pi/(24.-14.+startday_nm1(:,:) )* &
+           &    (hour + 24.+0.5*(24.-14.+startday_nm1(:,:) )-14.))+(tmax_nm1(:,:)+tmin_n(:,:))/2.
+         ELSEWHERE
+            tair(:,:)=(tmax_nm1(:,:)-tmin_n(:,:))/2.*sin(pi/(24.-14.+startday_n(:,:))*(hour+0.5* &
+           &    (24.-14.+startday_n(:,:))-14.))+(tmax_nm1(:,:)+tmin_n(:,:))/2.
+         ENDWHERE
+
+         CALL weathgen_qsat_2d (iim,jjm,tmin_n,pb,qsattmin_n)
+         CALL weathgen_qsat_2d (iim,jjm,tmin_nm1,pb,qsattmin_nm1)
+         CALL weathgen_qsat_2d (iim,jjm,tair,pb,qsatta)
+
+         !---
+         qmin_nm1(:,:) = MIN(qair_nm1(:,:),0.99*qsattmin_nm1(:,:))
+         qmin_n(:,:) = MIN(qair_n(:,:),0.99*qsattmin_n(:,:))
+         qmax_nm1(:,:) = (qair_nm1(:,:)-qmin_nm1(:,:)) + qair_nm1(:,:)
+         qmax_n(:,:) = (qair_n(:,:)-qmin_n(:,:)) + qair_n(:,:)
+
+         qsa(:,:)  = 0.99*qsatta(:,:)
+
+
+         WHERE ( ( hour >= startday_n(:,:) ) .AND. ( hour > 12) .AND. ( hour <= 14) )
+            qair(:,:)=MIN(qsa(:,:),(qmax_nm1(:,:)-qmin_nm1(:,:))/2 * ( sin(pi/(14-startday_n(:,:))*(hour-0.5* &
+           &    (14.-startday_n(:,:))-startday_n(:,:))) )+ (qmax_nm1(:,:)+qmin_nm1(:,:))/2.)
+         ELSEWHERE( ( hour >= startday_n(:,:) ) .AND. ( hour <= 12) )
+            qair(:,:)=MIN(qsa(:,:),(qmax_n(:,:)-qmin_n(:,:))/2 * ( sin(pi/(14-startday_n(:,:))*(hour-0.5* &
+           &    (14.-startday_n(:,:))-startday_n(:,:))) )+ (qmax_n(:,:)+qmin_n(:,:))/2.)
+         ELSEWHERE ( hour < startday_n(:,:) )
+            qair(:,:)=MIN(qsa(:,:),(qmax_nm1(:,:)-qmin_n(:,:))/2.*sin(pi/(24.-14.+startday_nm1(:,:) )* &
+           &    (hour + 24.+0.5*(24.-14.+startday_nm1(:,:) )-14.))+(qmax_nm1(:,:)+qmin_n(:,:))/2.)
+         ELSEWHERE
+            qair(:,:)=MIN(qsa(:,:),(qmax_nm1(:,:)-qmin_n(:,:))/2.*sin(pi/(24.-14.+startday_n(:,:))*(hour+0.5* &
+           &    (24.-14.+startday_n(:,:))-14.))+(qmax_nm1(:,:)+qmin_n(:,:))/2.)
+         ENDWHERE
+
+         IF (is_watchout) THEN
+            SWnet(:,:) = (SWnet_n(:,:)-SWnet_nm1(:,:))*rw + SWnet_nm1(:,:)
+            Eair(:,:) = (Eair_n(:,:)-Eair_nm1(:,:))*rw + Eair_nm1(:,:)
+            petAcoef(:,:) = (petAcoef_n(:,:)-petAcoef_nm1(:,:))*rw + petAcoef_nm1(:,:)
+            peqAcoef(:,:) = (peqAcoef_n(:,:)-peqAcoef_nm1(:,:))*rw + peqAcoef_nm1(:,:)
+            petBcoef(:,:) = (petBcoef_n(:,:)-petBcoef_nm1(:,:))*rw + petBcoef_nm1(:,:)
+            peqBcoef(:,:) = (peqBcoef_n(:,:)-peqBcoef_nm1(:,:))*rw + peqBcoef_nm1(:,:)
+            cdrag(:,:) = (cdrag_n(:,:)-cdrag_nm1(:,:))*rw + cdrag_nm1(:,:)
+            ccanopy(:,:) = (ccanopy_n(:,:)-ccanopy_nm1(:,:))*rw + ccanopy_nm1(:,:)
+         ENDIF
+   !---
+   !--- Here we need to allow for an option
+   !--- where radiative energy is conserved
+   !---
+         IF ( netrad_cons ) THEN
+            lwdown(:,:) = lwdown_n(:,:)
+         ELSE
+            lwdown(:,:) = (lwdown_n(:,:)-lwdown_nm1(:,:))*rw + lwdown_nm1(:,:)
+         ENDIF
+   !---
+   !--- For the solar radiation we decompose the mean value
+   !--- using the zenith angle of the sun if the time step in the forcing data is 
+   !---- more than an hour. Else we use the standard linera interpolation
+   !----
+         IF (check) WRITE(numout,*) 'Ready to deal with the solar radiation'
+   !----
+         IF ( dt_force .GT. 3600. ) THEN
+   !---
+            IF ( netrad_cons ) THEN
+               WRITE(numout,*) 'Solar radiation can not be conserved with a timestep of ', dt_force
+            ENDIF
+   !---
+            !MM we compute mean SWdown between t and t+Dt then I take t+Dt/2. 
+            julian = julian_for + (itau_split-0.5)/split*dt_force/one_day
+   !!$         julian = julian_for + rw*dt_force/one_day
+            IF (check) THEN
+               WRITE(numout,'(a,f20.10,2I3)') &
+                    &  'JULIAN BEFORE SOLARANG : ',julian,itau_split,split
+            ENDIF
+   !---
+            CALL solarang(julian, julian0, iim, jjm, lon*0, lat, sinang)
+    !        WRITE(numout,*) "YCHEN call 2"
+   !---
+            
+            WHERE ((mean_sinang(:,:) > 0.) .AND. (hour <= 12 ))
+               swdown(:,:) = swdown_n(:,:) *sinang(:,:)/mean_sinang(:,:)
+            ELSEWHERE ((mean_sinang(:,:) > 0.) .AND. (hour > 12 ))
+               swdown(:,:) = swdown_nm1(:,:) *sinang(:,:)/mean_sinang(:,:)
+            ELSEWHERE
+               swdown(:,:) = 0.0
+            END WHERE
+   !---
+            WHERE (swdown(:,:) > 2000. )
+               swdown(:,:) = 2000.
+            END WHERE
+   !---
+         ELSE
+   !---
+           
+ !           julian = julian_for + (itau_split-0.5)/split*dt_force/one_day   !add YCHEN  
+ !        CALL solarang(julian, julian0, iim, jjm, lon*0, lat, sinang)       !add YCHEN
+
+            IF ( netrad_cons ) THEN
+               swdown(:,:) = swdown_n(:,:)
+            ELSE
+               swdown(:,:) = (swdown_n(:,:)-swdown_nm1(:,:))*rw + swdown_nm1(:,:)
+            ENDIF
+   !---
+         ENDIF
+   !---
+         IF (check) THEN
+            WRITE(numout,*) '__ Forcing read at ',itau_split,' :',i_test, j_test
+            WRITE(numout,*) 'SWdown  : ',swdown_nm1(i_test, j_test), &
+                 &           ' < ', swdown(i_test, j_test), ' < ', swdown_n(i_test, j_test)
+            IF (is_watchout) THEN
+               WRITE(numout,*) 'SWnet  : ',swnet_nm1(i_test, j_test), &
+                    &           ' < ', swnet(i_test, j_test), ' < ', swnet_n(i_test, j_test)
+               WRITE(numout,*) 'levels  :',zlev_nm1(i_test, j_test), &
+                    &           ' < ', zlev(i_test, j_test), ' < ', zlev_n(i_test, j_test)
+               WRITE(numout,*) 'EAIR  :',Eair_nm1(i_test, j_test), &
+                    &           ' < ', eair(i_test, j_test), ' < ', Eair_n(i_test, j_test)
+            ENDIF
+            WRITE(numout,*) 'TAIR  :',tair_nm1(i_test, j_test), &
+                 &           ' < ', tair(i_test, j_test), ' < ', tair_n(i_test, j_test)
+            WRITE(numout,*) 'QAIR  :',qair_nm1(i_test, j_test), &
+                 &           ' < ', qair(i_test, j_test), ' < ', qair_n(i_test, j_test)
+            WRITE(numout,*) 'U  :',u_nm1(i_test, j_test), &
+                 &           ' < ', u(i_test, j_test), ' < ', u_n(i_test, j_test)
+            WRITE(numout,*) 'V  :',v_nm1(i_test, j_test), &
+                 &           ' < ', v(i_test, j_test), ' < ', v_n(i_test, j_test)
+         ENDIF
+   !---
+   !--- For precip we suppose that the rain
+   !--- is the sum over the next 6 hours
+   !---
+         WHERE ((itau_split <= nb_spread).AND.(hour<=12).AND.(tair(:,:)>=273.15)) 
+            rainf(:,:) = rainf_n(:,:) *(split/nb_spread)
+            snowf(:,:) = 0.0
+         ELSEWHERE ((itau_split <= nb_spread).AND.(hour<=12).AND.(tair(:,:)<273.15)) 
+            snowf(:,:) = rainf_n(:,:) *(split/nb_spread)
+            rainf(:,:) = 0.0
+         ELSEWHERE ((itau_split <= nb_spread).AND.(hour>12).AND.(tair(:,:)>=273.15)) 
+            rainf(:,:) = rainf_nm1(:,:) *(split/nb_spread)
+            snowf(:,:) = 0.0
+         ELSEWHERE ((itau_split <= nb_spread).AND.(hour>12).AND.(tair(:,:)<273.15)) 
+            snowf(:,:) = rainf_nm1(:,:) *(split/nb_spread)
+            rainf(:,:) = 0.0
+         ELSEWHERE
+            snowf(:,:) = 0.0
+            rainf(:,:) = 0.0
+         ENDWHERE
+
+         IF (check) THEN
+            WRITE(numout,*) '__ Forcing read at ',itau_split,' :'
+            WRITE(numout,*) 'Rainf  : ',rainf_nm1(i_test, j_test), &
+                 &           ' < ', rainf(i_test, j_test), ' < ', rainf_n(i_test, j_test)
+            WRITE(numout,*) 'Snowf  : ',snowf_nm1(i_test, j_test), &
+                 &           ' < ', snowf(i_test, j_test), ' < ', snowf_n(i_test, j_test)
+         ENDIF
+   !---
+
+
+      ELSE
+
+         IF (itau_read /= last_read) THEN
+   !---
+   !-----   Start or Restart
+            IF (itau_read_n == 0) THEN
+               ! Case of a restart or a shift in the forcing file.
+               IF (itau_read > 1) THEN
+                  itau_read_nm1=itau_read-1
+                  CALL forcing_just_read (iim, jjm, zlev_nm1, zlevuv_nm1, ttm, itau_read_nm1, itau_read_nm1, &
+                       &  swdown_nm1, rainf_nm1, snowf_nm1, tair_nm1, &
+                       &  u_nm1, v_nm1, qair_nm1, pb_nm1, lwdown_nm1, &
+                       &  SWnet_nm1, Eair_nm1, petAcoef_nm1, peqAcoef_nm1, petBcoef_nm1, peqBcoef_nm1, cdrag_nm1, ccanopy_nm1, &
+                       &  force_id, wind_N_exists, check)
+               ! Case of a simple start.
+               ELSE IF (dt_force*ttm > one_day-1. ) THEN
+                  ! if the forcing file contains at least 24 hours, 
+                  ! we will use the last forcing step of the first day
+                  ! as initiale condition to prevent first shift off reading.
+                  itau_read_nm1 = NINT (one_day/dt_force)
+                  WRITE(numout,*) "the forcing file contains 24 hours :",dt_force*ttm,one_day-1.
+                  WRITE(numout,*) "we will use the last forcing step of the first day : itau_read_nm1 ",itau_read_nm1
+                  CALL forcing_just_read (iim, jjm, zlev_nm1, zlevuv_nm1, ttm, itau_read_nm1, itau_read_nm1, &
+                       &  swdown_nm1, rainf_nm1, snowf_nm1, tair_nm1, &
+                       &  u_nm1, v_nm1, qair_nm1, pb_nm1, lwdown_nm1, &
+                       &  SWnet_nm1, Eair_nm1, petAcoef_nm1, peqAcoef_nm1, petBcoef_nm1, peqBcoef_nm1, cdrag_nm1, ccanopy_nm1, &
+                       &  force_id, wind_N_exists, check)
+               ELSE
+                  ! if the forcing file contains less than 24 hours, 
+                  ! just say error !
+                  CALL ipslerr_p(3,'forcing_read_interpol', &
+      &             'The forcing file contains less than 24 hours !', &
+      &             'We can''t intialize interpolation with such a file.','') 
+               ENDIF
+            ELSE
+   !-----   Normal mode : copy old step
+               swdown_nm1(:,:) = swdown_n(:,:)
+               rainf_nm1(:,:) = rainf_n(:,:)
+               snowf_nm1(:,:)  = snowf_n(:,:) 
+               tair_nm1(:,:)   = tair_n(:,:)
+               u_nm1(:,:)      = u_n(:,:)
+               v_nm1(:,:)      = v_n(:,:)
+               qair_nm1(:,:)   = qair_n(:,:)
+               pb_nm1(:,:)     = pb_n(:,:)
+               lwdown_nm1(:,:) = lwdown_n(:,:)
+               IF (is_watchout) THEN
+                  zlev_nm1(:,:)   = zlev_n(:,:)
+                  ! Net surface short-wave flux
+                  SWnet_nm1(:,:) = SWnet_n(:,:)
+                  ! Air potential energy
+                  Eair_nm1(:,:)   = Eair_n(:,:)
+                  ! Coeficients A from the PBL resolution for T
+                  petAcoef_nm1(:,:) = petAcoef_n(:,:)
+                  ! Coeficients A from the PBL resolution for q
+                  peqAcoef_nm1(:,:) = peqAcoef_n(:,:)
+                  ! Coeficients B from the PBL resolution for T
+                  petBcoef_nm1(:,:) = petBcoef_n(:,:)
+                  ! Coeficients B from the PBL resolution for q
+                  peqBcoef_nm1(:,:) = peqBcoef_n(:,:)
+                  ! Surface drag
+                  cdrag_nm1(:,:) = cdrag_n(:,:)
+                  ! CO2 concentration in the canopy
+                  ccanopy_nm1(:,:) = ccanopy_n(:,:)
+               ENDIF
+               itau_read_nm1 = itau_read_n
+            ENDIF
+   !-----
+            itau_read_n = itau_read
+            IF (itau_read_n > ttm) THEN
+               WRITE(numout,*) 'WARNING --WARNING --WARNING --WARNING '
+               WRITE(numout,*) &
+                    &  'WARNING : We are going back to the start of the file'
+               itau_read_n =1
+            ENDIF
+            IF (check) THEN
+               WRITE(numout,*) &
+                    & 'The dates 2 : ',itau_read,itau_split,itau_read_nm1,itau_read_n
+            ENDIF
+   !-----
+   !----- Get a reduced julian day !
+   !----- This is needed because we lack the precision on 32 bit machines.
+   !-----
+
+!-----------There is no need to exclude the dt less than 3600 for accessing the julian_for 
+!           so this IF condition is comment out.              26042014 by YCHEN
+!------------IF ( dt_force .GT. 3600. ) THEN   
+               julian_for = itau2date(itau_read-1, date0, dt_force)
+               CALL ju2ymds (julian_for, yy, mm, dd, ss)
+   
+               ! first day of this year
+               CALL ymds2ju (yy,1,1,0.0, julian0)
+   !-----
+               IF (check) THEN
+                  WRITE(numout,*) 'YCHEN Forcing for Julian day ',julian_for,'time step:,', itau_read
+                  WRITE(numout,*) 'YCHEN Date yy/mm/dd ss',yy,' / ',mm,' / ',dd,"  ",ss
+              ENDIF
+!------------ENDIF 
+   !-----
+            CALL forcing_just_read (iim, jjm, zlev_n, zlevuv_n, ttm, itau_read_n, itau_read_n, &
+                 &  swdown_n, rainf_n, snowf_n, tair_n, &
+                 &  u_n, v_n, qair_n, pb_n, lwdown_n, &
+                 &  SWnet_n, Eair_n, petAcoef_n, peqAcoef_n, petBcoef_n, peqBcoef_n, cdrag_n, ccanopy_n, &
+                 &  force_id, wind_N_exists, check)
+   !---
+            last_read = itau_read_n
+   !-----
+   !----- Compute mean solar angle for the comming period
+   !-----
+            IF (check) WRITE(numout,*) 'Going into  solarang', split, one_day
+   !-----
+            IF ( dt_force .GT. 3600. ) THEN   !IF loop comment out by YCHEN 
+               mean_sinang(:,:) = 0.0
+               DO is=1,split
+                  !MM we compute mean SWdown between t and t+Dt then I take t+Dt/2. 
+                  julian = julian_for+((is-0.5)/split)*dt_force/one_day
+   !!$               julian = julian_for+(FLOAT(is)/split)*dt_force/one_day
+                  CALL solarang (julian, julian0, iim, jjm, lon, lat, sinang)
+                            ! WRITE(numout,*) "YCHEN call 3"
+                  mean_sinang(:,:) = mean_sinang(:,:)+sinang(:,:)
+               ENDDO
+               mean_sinang(:,:) = mean_sinang(:,:)/split
+   !            WRITE(*,*) "mean_sinang =",MAXVAL(mean_sinang)
+            ENDIF   !IF loop comment out by YCHEN 
+   !-----
+         ENDIF
+   !---
+   !--- Do the interpolation
+         IF (check) WRITE(numout,*) 'Doing the interpolation between time steps'
+   !---
+         IF (split > 1) THEN
+            rw = REAL(itau_split)/split
+         ELSE
+            rw = 1.
+         ENDIF
+         IF (check) WRITE(numout,*) 'Coeff of interpollation : ',rw
+   !---
+         qair(:,:) = (qair_n(:,:)-qair_nm1(:,:))*rw + qair_nm1(:,:)
+         tair(:,:) = (tair_n(:,:)-tair_nm1(:,:))*rw + tair_nm1(:,:)
+         pb(:,:) = (pb_n(:,:)-pb_nm1(:,:))*rw + pb_nm1(:,:)
+         u(:,:)  = (u_n(:,:)-u_nm1(:,:))*rw + u_nm1(:,:)
+         v(:,:)  = (v_n(:,:)-v_nm1(:,:))*rw + v_nm1(:,:)
+         IF (is_watchout) THEN
+            zlev(:,:) = (zlev_n(:,:)-zlev_nm1(:,:))*rw + zlev_nm1(:,:)
+            zlevuv(:,:) = zlev(:,:)
+            SWnet(:,:) = (SWnet_n(:,:)-SWnet_nm1(:,:))*rw + SWnet_nm1(:,:)
+            Eair(:,:) = (Eair_n(:,:)-Eair_nm1(:,:))*rw + Eair_nm1(:,:)
+            petAcoef(:,:) = (petAcoef_n(:,:)-petAcoef_nm1(:,:))*rw + petAcoef_nm1(:,:)
+            peqAcoef(:,:) = (peqAcoef_n(:,:)-peqAcoef_nm1(:,:))*rw + peqAcoef_nm1(:,:)
+            petBcoef(:,:) = (petBcoef_n(:,:)-petBcoef_nm1(:,:))*rw + petBcoef_nm1(:,:)
+            peqBcoef(:,:) = (peqBcoef_n(:,:)-peqBcoef_nm1(:,:))*rw + peqBcoef_nm1(:,:)
+            cdrag(:,:) = (cdrag_n(:,:)-cdrag_nm1(:,:))*rw + cdrag_nm1(:,:)
+            ccanopy(:,:) = (ccanopy_n(:,:)-ccanopy_nm1(:,:))*rw + ccanopy_nm1(:,:)
+         ENDIF
+   !---
+   !--- Here we need to allow for an option
+   !--- where radiative energy is conserved
+   !---
+         IF ( netrad_cons ) THEN
+            lwdown(:,:) = lwdown_n(:,:)
+         ELSE
+            lwdown(:,:) = (lwdown_n(:,:)-lwdown_nm1(:,:))*rw + lwdown_nm1(:,:)
+         ENDIF
+   !---
+   !--- For the solar radiation we decompose the mean value
+   !--- using the zenith angle of the sun if the time step in the forcing data is 
+   !---- more than an hour. Else we use the standard linera interpolation
+   !----
+         IF (check) WRITE(numout,*) 'Ready to deal with the solar radiation'
+   !----
+         IF ( dt_force .GT. 3600. ) THEN
+   !---
+            IF ( netrad_cons ) THEN
+               WRITE(numout,*) 'Solar radiation can not be conserved with a timestep of ', dt_force
+            ENDIF
+   !---
+            !MM we compute mean SWdown between t and t+Dt then I take t+Dt/2. 
+            julian = julian_for + (itau_split-0.5)/split*dt_force/one_day
+   !!$         julian = julian_for + rw*dt_force/one_day
+            IF (check) THEN
+               WRITE(numout,'(a,f20.10,2I3)') &
+                    &  'JULIAN BEFORE SOLARANG : ',julian,itau_split,split
+            ENDIF
+   !---
+            CALL solarang(julian, julian0, iim, jjm, lon, lat, sinang)
+                        
+   !---
+            WHERE (mean_sinang(:,:) > 0.)
+               swdown(:,:) = swdown_n(:,:) *sinang(:,:)/mean_sinang(:,:)
+            ELSEWHERE
+               swdown(:,:) = 0.0
+            END WHERE
+   !---
+            WHERE (swdown(:,:) > 2000. )
+               swdown(:,:) = 2000.
+            END WHERE
+   !---
+         ELSE
+ !           WRITE(numout,*) "YCHEN readdim2 call julian_for without interpolation "
+ !-----------This call is added by YCHEN for accessing the solar anlge without interpolation scheme-----------
+             CALL solarang(julian_for, julian0, iim, jjm, lon, lat, sinang)
+ !           WRITE(numout, '(a20,I10)') "YCHEN time steps:", itau_read
+ !           WRITE(numout, *) "YCHEN julian_for",julian_for,"sinang:", sinang 
+ !----------------------------------------------------------------------------------------------------------
+            IF ( netrad_cons ) THEN
+               swdown(:,:) = swdown_n(:,:)
+            ELSE
+               swdown(:,:) = (swdown_n(:,:)-swdown_nm1(:,:))*rw + swdown_nm1(:,:)
+            ENDIF
+   !---
+         ENDIF
+   !---
+         IF (check) THEN
+            WRITE(numout,*) '__ Forcing read at ',itau_split,' :',i_test, j_test
+            WRITE(numout,*) 'SWdown  : ',swdown_nm1(i_test, j_test), &
+                 &           ' < ', swdown(i_test, j_test), ' < ', swdown_n(i_test, j_test)
+            IF (is_watchout) THEN
+               WRITE(numout,*) 'SWnet  : ',swnet_nm1(i_test, j_test), &
+                    &           ' < ', swnet(i_test, j_test), ' < ', swnet_n(i_test, j_test)
+               WRITE(numout,*) 'levels  :',zlev_nm1(i_test, j_test), &
+                    &           ' < ', zlev(i_test, j_test), ' < ', zlev_n(i_test, j_test)
+               WRITE(numout,*) 'EAIR  :',Eair_nm1(i_test, j_test), &
+                    &           ' < ', eair(i_test, j_test), ' < ', Eair_n(i_test, j_test)
+            ENDIF
+            WRITE(numout,*) 'TAIR  :',tair_nm1(i_test, j_test), &
+                 &           ' < ', tair(i_test, j_test), ' < ', tair_n(i_test, j_test)
+            WRITE(numout,*) 'QAIR  :',qair_nm1(i_test, j_test), &
+                 &           ' < ', qair(i_test, j_test), ' < ', qair_n(i_test, j_test)
+            WRITE(numout,*) 'U  :',u_nm1(i_test, j_test), &
+                 &           ' < ', u(i_test, j_test), ' < ', u_n(i_test, j_test)
+            WRITE(numout,*) 'V  :',v_nm1(i_test, j_test), &
+                 &           ' < ', v(i_test, j_test), ' < ', v_n(i_test, j_test)
+         ENDIF
+   !---
+   !--- For precip we suppose that the rain
+   !--- is the sum over the next 6 hours
+   !---
+         IF (itau_split <= nb_spread) THEN
+            rainf(:,:) = rainf_n(:,:)*(split/nb_spread)
+            snowf(:,:) = snowf_n(:,:)*(split/nb_spread)
+         ELSE
+            rainf(:,:) = 0.0
+            snowf(:,:) = 0.0
+         ENDIF
+         IF (check) THEN
+            WRITE(numout,*) '__ Forcing read at ',itau_split,' :'
+            WRITE(numout,*) 'Rainf  : ',rainf_nm1(i_test, j_test), &
+                 &           ' < ', rainf(i_test, j_test), ' < ', rainf_n(i_test, j_test)
+            WRITE(numout,*) 'Snowf  : ',snowf_nm1(i_test, j_test), &
+                 &           ' < ', snowf(i_test, j_test), ' < ', snowf_n(i_test, j_test)
+         ENDIF
+   !---
+      ENDIF ! (daily_interpol)
+   ENDIF
+!---
+!--- Here we might put the call to the weather generator ... one day.
+!--- Pour le moment, le branchement entre interpolation et generateur de temps 
+!--- est fait au-dessus.
+!---
+!-   IF ( initialized .AND. weathergen ) THEN
+!-      ....
+!-   ENDIF
+!---
+!--- At this point the code should be initialized. If not we have a problem !
+!---
+   IF ( (itau_read == 0).AND.(itau_split == 0) ) THEN
+!---
+      initialized = .TRUE.
+!---
+   ELSE
+      IF ( .NOT. initialized ) THEN
+         WRITE(numout,*) 'Why is the code forcing_read not initialized ?'
+         WRITE(numout,*) 'Have you called it with both time-steps set to zero ?'
+         STOP
+      ENDIF
+   ENDIF
+!
+!-------------------------
+END SUBROUTINE forcing_read_interpol
+!=====================================================================
+!-
+!=====================================================================
+SUBROUTINE forcing_just_read &
+  & (iim, jjm, zlev, zlev_uv, ttm, itb, ite, &
+  &  swdown, rainf, snowf, tair, &
+  &  u, v, qair, pb, lwdown, &
+  &  SWnet, Eair, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag, ccanopy, &
+  &  force_id, wind_N_exists, check)
+!---------------------------------------------------------------------
+!- iim        : Size of the grid in x
+!- jjm        : size of the grid in y
+!- zlev       : height of the varibales T and Q 
+!- zlev_uv    : height of the varibales U and V 
+!- ttm        : number of time steps in all in the forcing file
+!- itb, ite   : index of respectively begin and end of read for each variable
+!- swdown     : Downward solar radiation (W/m^2)
+!- rainf      : Rainfall (kg/m^2s)
+!- snowf      : Snowfall (kg/m^2s)
+!- tair       : 2m air temperature (K)
+!- u and v    : 2m (in theory !) wind speed (m/s)
+!- qair       : 2m humidity (kg/kg)
+!- pb         : Surface pressure (Pa)
+!- lwdown     : Downward long wave radiation (W/m^2)
+!-
+!- From a WATCHOUT file :
+!- SWnet      : Net surface short-wave flux
+!- Eair       : Air potential energy
+!- petAcoef   : Coeficients A from the PBL resolution for T
+!- peqAcoef   : Coeficients A from the PBL resolution for q
+!- petBcoef   : Coeficients B from the PBL resolution for T
+!- peqBcoef   : Coeficients B from the PBL resolution for q
+!- cdrag      : Surface drag
+!- ccanopy    : CO2 concentration in the canopy
+!- force_id   : FLINCOM file id.
+!-              It is used to close the file at the end of the run.
+!- wind_N_exists : if Wind_N and Wind_E are in the file (and not just Wind)
+!- check      : Prompt for reading
+!---------------------------------------------------------------------
+   IMPLICIT NONE
+!-
+   INTEGER, INTENT(in) :: iim, jjm, ttm
+   INTEGER, INTENT(in) :: itb, ite
+   REAL, DIMENSION(iim,jjm), INTENT(out) ::  zlev, zlev_uv, &
+  &  swdown, rainf, snowf, tair, u, v, qair, pb, lwdown
+   ! for watchout files
+   REAL, DIMENSION(iim,jjm), INTENT(out) :: &
+  &  SWnet, Eair, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag, ccanopy
+   INTEGER, INTENT(in) :: force_id
+!  if Wind_N and Wind_E are in the file (and not just Wind)
+   LOGICAL, INTENT(in) :: wind_N_exists
+   LOGICAL :: check
+   INTEGER :: i, j 
+   REAL :: rau 
+
+!-
+!---------------------------------------------------------------------
+   IF ( daily_interpol ) THEN
+      CALL flinget (force_id,'Tmin'  , iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, tair)
+      CALL flinget (force_id,'precip' , iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, rainf)
+   ELSE
+      CALL flinget (force_id,'Tair'  , iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, tair)
+      CALL flinget (force_id,'Snowf' , iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, snowf)
+      CALL flinget (force_id,'Rainf' , iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, rainf)
+   ENDIF
+
+
+   CALL flinget (force_id,'SWdown', iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+   CALL forcing_zoom(data_full, swdown)
+   CALL flinget (force_id,'LWdown', iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+   CALL forcing_zoom(data_full, lwdown)
+
+!SZ FLUXNET input file correction
+!  rainf=rainf*1800.
+!MM Rainf and not Snowf ?
+   CALL flinget (force_id,'PSurf' , iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+   CALL forcing_zoom(data_full, pb)
+   CALL flinget (force_id,'Qair'  , iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+   CALL forcing_zoom(data_full, qair)
+!---
+   IF ( wind_N_exists ) THEN
+      CALL flinget (force_id,'Wind_N', iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, u)
+      CALL flinget (force_id,'Wind_E', iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, v)
+   ELSE
+      CALL flinget (force_id,'Wind',   iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, u)
+      v=0.0
+   ENDIF
+
+!- 
+!- Deal with the height of the atmospheric forcing varibles 
+!- 
+!---- 
+   IF ( zheight ) THEN 
+      zlev(:,:) = zlev_fixed 
+   ELSE IF ( zsigma .OR. zhybrid ) THEN 
+      DO i=1,iim 
+         DO j=1,jjm 
+            IF ( tair(i,j) < val_exp ) THEN 
+               rau = pb(i,j)/(cte_molr*tair(i,j)) 
+ 	  	 
+               zlev(i,j) =  (pb(i,j) - (zhybrid_a + zhybrid_b*pb(i,j)))/(rau * cte_grav) 
+            ELSE 
+               zlev(i,j) = 0.0 
+            ENDIF
+         ENDDO
+      ENDDO
+   ELSE IF ( zlevels ) THEN 
+      CALL flinget (force_id,'Levels', iim_full, jjm_full, llm_full, ttm, itb, ite, data_full) 
+      CALL forcing_zoom(data_full, zlev) 
+   ELSE 
+      CALL ipslerr(3, 'forcing_just_read','No case for the vertical levels was specified.', & 
+           &         'We cannot determine the height for T and Q.','stop readdim2') 
+   ENDIF
+   
+   IF ( zsamelev_uv ) THEN 
+      zlev_uv(:,:) = zlev(:,:) 
+   ELSE 
+      IF ( zheight ) THEN 
+         zlev_uv(:,:) = zlevuv_fixed 
+      ELSE IF ( zsigma .OR. zhybrid ) THEN 
+         DO i=1,iim 
+            DO j=1,jjm 
+               IF ( tair(i,j) < val_exp ) THEN 
+                  rau = pb(i,j)/(cte_molr*tair(i,j)) 
+                  
+                  zlev_uv(i,j) =  (pb(i,j) - (zhybriduv_a + zhybriduv_b*pb(i,j)))/(rau * cte_grav) 
+               ELSE 
+                  zlev_uv(i,j) = 0.0 
+               ENDIF
+            ENDDO
+         ENDDO
+      ELSE IF ( zlevels ) THEN 
+         CALL flinget (force_id,'Levels_uv', iim_full, jjm_full, llm_full, ttm, itb, ite, data_full) 
+         CALL forcing_zoom(data_full, zlev_uv) 
+      ELSE 
+         CALL ipslerr(3, 'forcing_just_read','No case for the vertical levels was specified.', & 
+              &         'We cannot determine the height for U and V.','stop readdim2') 
+      ENDIF
+   ENDIF
+   !----
+   IF ( is_watchout ) THEN
+      CALL flinget (force_id,'levels', iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, zlev)
+      ! 
+      ! If we are in WATHCOUT it means T,Q are at the same height as U,V 
+      ! 
+      zlev_uv(:,:) = zlev(:,:) 
+      ! Net surface short-wave flux
+      CALL flinget (force_id,'SWnet', iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, SWnet)
+      ! Air potential energy
+      CALL flinget (force_id,'Eair', iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, Eair)
+      ! Coeficients A from the PBL resolution for T
+      CALL flinget (force_id,'petAcoef', iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, petAcoef)
+      ! Coeficients A from the PBL resolution for q
+      CALL flinget (force_id,'peqAcoef', iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, peqAcoef)
+      ! Coeficients B from the PBL resolution for T
+      CALL flinget (force_id,'petBcoef', iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, petBcoef)
+      ! Coeficients B from the PBL resolution for q
+      CALL flinget (force_id,'peqBcoef', iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, peqBcoef)
+      ! Surface drag
+      CALL flinget (force_id,'cdrag', iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, cdrag)
+      ! CO2 concentration in the canopy
+      CALL flinget (force_id,'ccanopy', iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+      CALL forcing_zoom(data_full, ccanopy)
+   ENDIF
+!
+!----
+     IF (check) WRITE(numout,*) 'Variables have been extracted between ',itb,' and ',ite,' iterations of the forcing file.'
+!-------------------------
+END SUBROUTINE forcing_just_read
+!=====================================================================
+
+!-
+SUBROUTINE forcing_just_read_tmax &
+  & (iim, jjm, ttm, itb, ite, tmax, force_id )
+!---------------------------------------------------------------------
+!- iim        : Size of the grid in x
+!- jjm        : size of the grid in y
+!- ttm        : number of time steps in all in the forcing file
+!- itb, ite   : index of respectively begin and end of read for each variable
+!- tmax       : 2m air temperature (K)
+!- force_id   : FLINCOM file id.
+!-              It is used to close the file at the end of the run.
+!---------------------------------------------------------------------
+   IMPLICIT NONE
+!-
+   INTEGER, INTENT(in) :: iim, jjm, ttm
+   INTEGER, INTENT(in) :: itb, ite
+   REAL, DIMENSION(iim,jjm), INTENT(out) ::  tmax
+   INTEGER, INTENT(in) :: force_id
+!-
+!---------------------------------------------------------------------
+   CALL flinget (force_id,'Tmax'  , iim_full, jjm_full, llm_full, ttm, itb, ite, data_full)
+   CALL forcing_zoom(data_full, tmax)
+!-------------------------
+END SUBROUTINE forcing_just_read_tmax
+!=====================================================================
+
+!-
+SUBROUTINE forcing_landind(iim, jjm, tair, check, nbindex, kindex, i_test, j_test)
+!---
+!--- This subroutine finds the indices of the land points over which the land
+!--- surface scheme is going to run.
+!---
+  IMPLICIT NONE
+!-
+!- ARGUMENTS
+!-
+  INTEGER, INTENT(IN) :: iim, jjm
+  REAL, INTENT(IN)    :: tair(iim,jjm)
+  INTEGER, INTENT(OUT) :: i_test, j_test, nbindex
+  INTEGER, INTENT(OUT) :: kindex(iim*jjm)
+  LOGICAL :: check
+!-
+!- LOCAL
+  INTEGER :: i, j, ig
+!-
+!-
+  ig = 0
+  i_test = 0
+  j_test = 0
+!---
+  IF (MINVAL(tair(:,:)) < 100.) THEN
+!----- In this case the 2m temperature is in Celsius
+     DO j=1,jjm
+        DO i=1,iim
+           IF (tair(i,j) < 100.) THEN
+              ig = ig+1
+              kindex(ig) = (j-1)*iim+i
+              !
+              !  Here we find at random a land-point on which we can do
+              !  some printouts for test.
+              !
+              IF (ig .GT. (iim*jjm)/2 .AND. i_test .LT. 1) THEN
+                 i_test = i
+                 j_test = j
+                 IF (check) THEN
+                    WRITE(numout,*) 'The test point chosen for output is : ', i_test, j_test
+                 ENDIF
+              ENDIF
+           ENDIF
+        ENDDO
+     ENDDO
+  ELSE 
+!----- 2m temperature is in Kelvin
+     DO j=1,jjm
+        DO i=1,iim
+           IF (tair(i,j) < 500.) THEN
+              ig = ig+1
+              kindex(ig) = (j-1)*iim+i
+              !
+              !  Here we find at random a land-point on which we can do
+              !  some printouts for test.
+              !
+              IF (ig .GT. (iim*jjm)/2 .AND. i_test .LT. 1) THEN
+                 i_test = i
+                 j_test = j
+                 IF (check) THEN
+                    WRITE(numout,*) 'The test point chosen for output is : ', i_test, j_test
+                 ENDIF
+              ENDIF
+           ENDIF
+        ENDDO
+     ENDDO
+  ENDIF
+!---
+  nbindex = ig
+!---
+END SUBROUTINE forcing_landind
+!-
+!=====================================================================
+!-
+SUBROUTINE forcing_grid(iim,jjm,llm,lon,lat,init_f)
+!-
+!- This subroutine calculates the longitudes and latitudes of the model grid.
+!-   
+  IMPLICIT NONE
+!-
+  INTEGER, INTENT(in)                   :: iim, jjm, llm
+  LOGICAL, INTENT(in)                   :: init_f
+  REAL, DIMENSION(iim,jjm), INTENT(out) :: lon, lat
+!-
+  INTEGER :: i,j
+!-
+  LOGICAL :: debug = .FALSE.
+!-
+!- Should be unified one day
+!-
+  IF ( debug ) WRITE(numout,*) 'forcing_grid : options : ', weathergen, interpol
+!-
+  IF ( weathergen ) THEN
+     IF (init_f) THEN
+        DO i = 1, iim
+           lon(i,:) = limit_west + merid_res/2. + &
+                FLOAT(i-1)*(limit_east-limit_west)/FLOAT(iim)
+        ENDDO
+        !-
+        DO j = 1, jjm
+           lat(:,j) = limit_north - zonal_res/2. - &
+                FLOAT(j-1)*(limit_north-limit_south)/FLOAT(jjm)
+        ENDDO
+     ELSE
+        IF (is_root_prc) THEN
+           DO i = 1, iim_g
+              lon_g(i,:) = limit_west + merid_res/2. + &
+                   FLOAT(i-1)*(limit_east-limit_west)/FLOAT(iim_g)
+           ENDDO
+           !-
+           DO j = 1, jjm_g
+              lat_g(:,j) = limit_north - zonal_res/2. - &
+                   FLOAT(j-1)*(limit_north-limit_south)/FLOAT(jjm_g)
+           ENDDO
+        ENDIF
+        CALL bcast(lon_g)
+        CALL bcast(lat_g)
+        lon=lon_g(:,jj_para_begin(mpi_rank):jj_para_end(mpi_rank))
+        lat=lat_g(:,jj_para_begin(mpi_rank):jj_para_end(mpi_rank))
+     ENDIF
+!-
+  ELSEIF ( interpol ) THEN
+!-
+    CALL forcing_zoom(lon_full, lon)
+    IF ( debug ) WRITE(numout,*) 'forcing_grid : out of zoom on lon'
+    CALL forcing_zoom(lat_full, lat)
+    IF ( debug ) WRITE(numout,*) 'forcing_grid : out of zoom on lat'
+ 
+ ELSE 
+    
+    STOP 'Neither weather generator nor temporal interpolation is specified.' 
+    
+ ENDIF
+ 
+ IF ( debug ) WRITE(numout,*) 'forcing_grid : ended'
+ 
+END SUBROUTINE forcing_grid
+!-
+!=====================================================================
+!-
+SUBROUTINE forcing_zoom(x_f, x_z)
+!-
+!- This subroutine takes the slab of data over which we wish to run the model.
+!-   
+  IMPLICIT NONE
+!-
+  REAL, INTENT(IN) :: x_f(iim_full, jjm_full)
+  REAL, INTENT(OUT) :: x_z(iim_zoom, jjm_zoom)
+!-
+  INTEGER :: i,j
+!-
+  DO i=1,iim_zoom
+     DO j=1,jjm_zoom
+        x_z(i,j) = x_f(i_index(i),j_index(j))
+     ENDDO
+  ENDDO
+!-
+END SUBROUTINE forcing_zoom
+
+!-
+!=====================================================================
+!-
+
+SUBROUTINE forcing_vertical(force_id)
+!
+!- This subroutine explores the forcing file to decide what information is available
+!- on the vertical coordinate.
+!
+  INTEGER, INTENT(IN) :: force_id
+  !
+  LOGICAL :: var_exists, vara_exists, varb_exists, varuv_exists
+  LOGICAL :: foundvar
+  LOGICAL :: levlegacy
+
+  !
+  !- Set all the defaults
+  !
+  zfixed=.FALSE.
+  zsigma=.FALSE.
+  zhybrid=.FALSE.
+  zlevels=.FALSE.
+  zheight=.FALSE.
+  zsamelev_uv = .TRUE.
+  levlegacy = .FALSE.
+  !
+  foundvar = .FALSE.
+  !
+  !- We have a forcing file to explore so let us see if we find any of the conventions
+  !- which allow us to find the height of T,Q,U and V.
+  !
+  IF ( force_id > 0 ) THEN
+     !
+     ! Case for sigma levels
+     !
+     IF ( .NOT. foundvar ) THEN
+        CALL flinquery_var(force_id, 'Sigma', var_exists)
+        CALL flinquery_var(force_id, 'Sigma_uv', varuv_exists)
+        IF ( var_exists ) THEN
+           foundvar = .TRUE.
+           zsigma = .TRUE.
+           IF ( varuv_exists ) zsamelev_uv = .FALSE.
+        ENDIF
+     ENDIF
+     !
+     ! Case for Hybrid levels
+     !
+     IF ( .NOT. foundvar ) THEN
+        CALL flinquery_var(force_id, 'HybSigA', vara_exists)
+        IF ( vara_exists ) THEN
+           CALL flinquery_var(force_id, 'HybSigB', varb_exists)
+           IF ( varb_exists ) THEN
+              var_exists=.TRUE.
+           ELSE
+              CALL ipslerr ( 3, 'forcing_vertical','Missing the B coefficient for', &
+                   &         'Hybrid vertical levels for T and Q','stop readdim2')
+           ENDIF
+        ENDIF
+        CALL flinquery_var(force_id, 'HybSigA_uv', vara_exists)
+        IF ( vara_exists ) THEN
+           CALL flinquery_var(force_id, 'HybSigB_uv', varb_exists)
+           IF ( varb_exists ) THEN
+              varuv_exists=.TRUE.
+           ELSE
+              CALL ipslerr ( 3, 'forcing_vertical','Missing the B coefficient for', &
+                   &         'Hybrid vertical levels for U and V','stop readdim2')
+           ENDIF
+        ENDIF
+        IF ( var_exists ) THEN
+           foundvar = .TRUE.
+           zhybrid = .TRUE.
+           IF ( varuv_exists ) zsamelev_uv = .FALSE.
+        ENDIF
+     ENDIF
+     !
+     ! Case for levels (i.e. a 2d time varying field with the height in meters)
+     !
+     IF ( .NOT. foundvar ) THEN
+        CALL flinquery_var(force_id, 'Levels', var_exists)
+        CALL flinquery_var(force_id, 'Levels_uv', varuv_exists)
+        IF ( var_exists ) THEN
+           foundvar = .TRUE.
+           zlevels = .TRUE.
+           IF ( varuv_exists ) zsamelev_uv = .FALSE.
+        ENDIF
+     ENDIF
+     !
+     ! Case where a fixed height is provided in meters
+     !
+     IF ( .NOT. foundvar ) THEN
+        CALL flinquery_var(force_id, 'Height_Lev1', var_exists)
+        CALL flinquery_var(force_id, 'Height_Levuv', varuv_exists)
+       IF ( var_exists ) THEN
+           foundvar = .TRUE.
+           zheight = .TRUE.
+           IF ( varuv_exists ) zsamelev_uv = .FALSE.
+        ENDIF
+     ENDIF
+     !
+     ! Case where a fixed height is provided in meters in the lev variable
+     !
+     IF ( .NOT. foundvar ) THEN
+        CALL flinquery_var(force_id, 'lev', var_exists)
+        IF ( var_exists ) THEN
+           foundvar = .TRUE.
+           zheight = .TRUE.
+           levlegacy = .TRUE.
+        ENDIF
+     ENDIF
+     !
+  ENDIF
+  !
+  ! We found forcing variables so we need to extract the values if we are dealing with constant values (i.e. all
+  ! except the case zlevels
+  !
+  IF ( foundvar .AND. .NOT. zlevels ) THEN
+     !
+     IF ( zheight ) THEN
+        !
+        ! Constant height
+        !
+        IF ( levlegacy ) THEN
+           CALL flinget (force_id,'lev',1, 1, 1, 1,  1, 1, zlev_fixed)
+        ELSE
+           CALL flinget (force_id,'Height_Lev1',1, 1, 1, 1,  1, 1, zlev_fixed)
+           IF ( .NOT. zsamelev_uv ) THEN
+              CALL flinget (force_id,'Height_Levuv',1, 1, 1, 1,  1, 1, zlevuv_fixed)
+           ENDIF
+        ENDIF
+        WRITE(numout,*) "forcing_vertical : case ZLEV : Read from forcing file :", zlev_fixed, zlevuv_fixed
+        !
+     ELSE IF ( zsigma .OR. zhybrid ) THEN
+        !
+        ! Sigma or hybrid levels
+        !
+        IF ( zsigma ) THEN
+           CALL flinget (force_id,'Sigma',1, 1, 1, 1,  1, 1, zhybrid_b)
+           zhybrid_a = zero
+           IF ( .NOT. zsamelev_uv ) THEN
+              CALL flinget (force_id,'Sigma_uv',1, 1, 1, 1,  1, 1, zhybriduv_b)
+              zhybriduv_a = zero
+           ENDIF
+        ELSE
+           CALL flinget (force_id,'HybSigB',1, 1, 1, 1,  1, 1, zhybrid_b)
+           CALL flinget (force_id,'HybSigA',1, 1, 1, 1,  1, 1, zhybrid_a)
+           IF ( .NOT. zsamelev_uv ) THEN
+              CALL flinget (force_id,'HybSigB_uv',1, 1, 1, 1,  1, 1, zhybriduv_b)
+              CALL flinget (force_id,'HybSigA_uv',1, 1, 1, 1,  1, 1, zhybriduv_a)
+           ENDIF
+        ENDIF
+        WRITE(numout,*) "forcing_vertical : case Pressure coordinates : "
+        WRITE(numout,*) "Read from forcing file :", zhybrid_b, zhybrid_a, zhybriduv_b, zhybriduv_a
+     ELSE
+        !
+        ! Why are we here ???
+        !
+        CALL ipslerr ( 3, 'forcing_vertical','What is the option used to describe the height of', &
+             &         'the atmospheric forcing ?','Please check your forcing file.')
+     ENDIF
+  ENDIF
+  !
+  !- We have no forcing file to explore or we did not find anything. So revert back to the run.def and
+  !- read what has been specified by the user.
+  !
+  IF ( force_id < 0 .OR. .NOT. foundvar ) THEN
+     !
+     !-
+     !Config  Key  = HEIGHT_LEV1
+     !Config  Desc = Height at which T and Q are given
+     !Config  Def  = 2.0
+     !Config  Help = The atmospheric variables (temperature and specific
+     !Config         humidity) are measured at a specific level.
+     !Config         The height of this level is needed to compute
+     !Config         correctly the turbulent transfer coefficients.
+     !Config         Look at the description of the forcing
+     !Config         DATA for the correct value.
+     !-
+     zlev_fixed = 2.0
+     CALL getin('HEIGHT_LEV1', zlev_fixed)
+     !-
+     !Config  Key  = HEIGHT_LEVW
+     !Config  Desc = Height at which the wind is given
+     !Config  Def  = 10.0
+     !Config  Help = The height at which wind is needed to compute
+     !Config         correctly the turbulent transfer coefficients.
+     !-
+     zlevuv_fixed = 10.0
+     CALL getin('HEIGHT_LEVW', zlevuv_fixed)
+
+     zheight = .TRUE.
+
+     IF ( ABS(zlevuv_fixed-zlev_fixed) > EPSILON(zlev_fixed)) THEN
+        zsamelev_uv = .FALSE.
+     ENDIF
+
+     CALL ipslerr ( 2, 'forcing_vertical','The height of the atmospheric forcing variables', &
+          &         'was not found in the netCDF file.','Thus the values in run.def were used ... or their defaults.')
+  ENDIF
+
+END SUBROUTINE forcing_vertical
+
+!-
+!=====================================================================
+!-
+
+SUBROUTINE domain_size (limit_west, limit_east, limit_north, limit_south, &
+     &  iim_f, jjm_f, lon, lat, iim, jjm, iind, jind)
+  
+  IMPLICIT NONE
+  !
+  ! ARGUMENTS
+  !
+  REAL, INTENT(inout)  :: limit_west,limit_east,limit_north,limit_south
+  INTEGER, INTENT(in)  :: iim_f, jjm_f
+  REAL, INTENT(in)     :: lon(iim_f, jjm_f), lat(iim_f, jjm_f)
+  INTEGER, INTENT(out) :: iim,jjm
+  INTEGER, INTENT(out) :: iind(iim_f), jind(jjm_f)
+  !
+  ! LOCAL
+  !
+  INTEGER :: i, j
+  REAL :: lolo
+  LOGICAL :: over_dateline = .FALSE.
+  !
+  !
+  IF ( ( ABS(limit_east) .GT. 180. ) .OR. &
+       ( ABS(limit_west) .GT. 180. ) ) THEN
+     WRITE(numout,*) 'Limites Ouest, Est: ',limit_west,limit_east
+     CALL ipslerr_p (3,'domain_size', &
+ &        'Longitudes problem.','In run.def file :', &
+ &        'limit_east > 180. or limit_west > 180.')
+  ENDIF
+  !
+  IF ( limit_west .GT. limit_east ) over_dateline = .TRUE.
+  !
+  IF ( ( limit_south .LT. -90. ) .OR. &
+       ( limit_north .GT. 90. ) .OR. &
+       ( limit_south .GE. limit_north ) ) THEN
+     WRITE(numout,*) 'Limites Nord, Sud: ',limit_north,limit_south
+     CALL ipslerr_p (3,'domain_size', &
+ &        'Latitudes problem.','In run.def file :', &
+ &        'limit_south < -90. or limit_north > 90. or limit_south >= limit_north')
+  ENDIF
+  !
+  ! Here we assume that the grid of the forcing data is regular. Else we would have
+  ! to do more work to find the index table.
+  !
+  iim = 0
+  DO i=1,iim_f
+     !
+     lolo =  lon(i,1)
+     IF ( lon(i,1) .GT. 180. ) lolo =  lon(i,1) - 360.
+     IF ( lon(i,1) .LT. -180. ) lolo =  lon(i,1) + 360.
+     !
+     IF (lon(i,1) < limit_west) iim_g_begin = i+1
+     IF (lon(i,1) < limit_east) iim_g_end = i
+     !
+     IF ( over_dateline ) THEN
+        IF ( lolo .LE. limit_west .OR. lolo .GE. limit_east ) THEN
+           iim = iim + 1
+           iind(iim) = i
+        ENDIF
+     ELSE
+        IF ( lolo .GE. limit_west .AND. lolo .LE. limit_east ) THEN
+           iim = iim + 1
+           iind(iim) = i
+        ENDIF
+     ENDIF
+     !
+  ENDDO
+  !
+  jjm = 0
+  DO j=1,jjm_f
+     IF (lat(1,j) > limit_north) jjm_g_begin = j+1
+     IF (lat(1,j) > limit_south) jjm_g_end = j
+     !
+     IF ( lat(1,j) .GE. limit_south .AND. lat(1,j) .LE. limit_north) THEN
+        jjm = jjm + 1
+        jind(jjm) = j
+     ENDIF
+  ENDDO
+  !
+  WRITE(numout,*) 'Domain zoom size: iim, jjm = ', iim, jjm
+  END SUBROUTINE domain_size
+
+!------------------
+END MODULE readdim2
Index: branches/publications/ORCHIDEE_CAN_NHA/src_driver/teststomate.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_driver/teststomate.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_driver/teststomate.f90	(revision 7236)
@@ -0,0 +1,1290 @@
+! =================================================================================================================================
+! PROGRAM       : teststomate
+!
+! CONTACT	: orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      	: IPSL (2006). This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        This program runs the STOMATE submodel using specific initial conditions 
+!! and driving variables in order to obtain the state variables of STOMATE closed to the steady-state values  
+!! quicker than when using the 'full' ORCHIDEE. 
+!!                                        
+!! \n DESCRIPTION (functional, design, flags): 
+!! It integrates STOMATE for a given number of years using a specific forcing file.       
+!! The initial GPP from this forcing is scaled in agreement with the updated calculated LAI in STOMATE 
+!! Nothing is done for soil moisture which should actually evolve with the vegetation.            
+!! - 1. It first reads a set of parameters, allocates variables and initializes them.
+!! - 2. Then, a section on the set up of the STOMATE history file
+!! - 3. A first call to slowproc subroutine in order to initialize SECHIBA variables
+!! - 4. A loop over time in which slowproc is called at each time step
+!! - 5. A restart file is written
+!! 
+!! RECENT CHANGE(S) : None
+!!
+!! REFERENCE(S)     : None
+!!
+!! SVN              :   
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+PROGRAM teststomate
+
+  ! modules used;
+
+  USE netcdf
+  USE defprec
+  USE constantes
+  USE constantes_soil
+  USE pft_parameters
+  USE structures
+  USE stomate_data
+  USE ioipsl_para
+  USE mod_orchidee_para
+  use tools_para
+  USE grid
+  USE slowproc
+  USE stomate
+  USE intersurf, ONLY: stom_define_history, stom_ipcc_define_history, intsurf_time, l_first_intersurf, check_time, impose_param
+!  USE parallel
+
+  IMPLICIT NONE
+
+  !! 0. Variable and parameter declaration
+
+  INTEGER(i_std)                            :: kjpij,kjpindex                       !! # of total/land points
+  REAL(r_std)                               :: dtradia,dt_force                     !! time step of sechiba and stomate components 
+                                                                                    !! read into the forcing file [second] 
+ 
+  INTEGER(i_std),DIMENSION(:),ALLOCATABLE   :: indices                              !! index over land points
+  INTEGER(i_std),DIMENSION(:),ALLOCATABLE   :: indexveg
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: soiltile, veget_x                    !! texture and fraction of vegetation type 
+                                                                                    !! (accounts for LAI dynamic) 
+  REAL(r_std),DIMENSION(:),ALLOCATABLE      :: totfrac_nobio                        !! Total fraction of ice+lakes+cities etc. in 
+                                                                                    !! the mesh 
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: frac_nobio                           !! Fraction of ice, lakes, cities etc. in the 
+                                                                                    !! mesh 
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: veget_max_x                          !! Fraction of vegetation type
+  INTEGER(i_std), DIMENSION(:),ALLOCATABLE  :: njsc
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: lai_x                                !! Leaf Area Index as calculated in STOMATE 
+                                                                                    !! [m2/m2] 
+  REAL(r_std),DIMENSION(:),ALLOCATABLE      :: sinang_x                             !! Sine of the sun angle
+  REAL(r_std), DIMENSION(:,:),ALLOCATABLE   :: ind_x                                !! density of individuals
+                                                                                    !! @tex $(m^{-2})$ @endtex
+  REAL(r_std), DIMENSION(:,:,:,:,:), ALLOCATABLE  :: circ_class_biomass_x !! Stem diameter 
+                                                                                          !! @tex $(m)$ @endtex
+  REAL(r_std), DIMENSION(:,:,:), ALLOCATABLE     :: circ_class_n_x       !! Number of trees within each circumference
+                                                                                          !! class @tex $(m^{-2})$ @endtex
+
+  REAL(r_std), DIMENSION(:,:,:,:), ALLOCATABLE     :: biomass_x                     !! Total biomass
+
+
+  REAL(r_std), DIMENSION(:,:,:), ALLOCATABLE     :: lai_per_level_x       !! 
+  TYPE(laieff_type), ALLOCATABLE, DIMENSION (:,:,:)  :: laieff_fit_x   !! The parameters for fitting the effective
+                                                                     !! LAI function
+!$OMP THREADPRIVATE(laieff_fit)                      
+
+  REAL(r_std),DIMENSION (:,:,:), ALLOCATABLE:: frac_age_x                           !! Age efficacity from STOMATE for isoprene 
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: veget_force_x                        !! Fraction of vegetation of PFTs in each grid 
+                                                                                    !! cell (read in the forcinng file) [-] 
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: veget_max_force_x                    !! fraction of maximum vegetation of PFTs in 
+                                                                                    !! each grid cell (read in the forcinng file) 
+                                                                                    !! [-] 
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: lai_force_x                          !! Leaf Area Index as read in the forcing file 
+                                                                                    !! [m2/m2] 
+  REAL(r_std),DIMENSION(:),ALLOCATABLE      :: reinf_slope
+  REAL(r_std),DIMENSION(:),ALLOCATABLE      :: t2m,t2m_min,temp_sol                 !! 2 m air temperature, min. 2 m air temp. 
+                                                                                    !! during forcing time step and Surface 
+                                                                                    !! temperature [K] 
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: soiltemp,soilhum                     !!  Soil temperature and Relative soil moisture
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: humrel_x
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: transpir_x                           !! transpiration
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: transpir_mod_x                       !! transpiration divided by veget_max (per m2)
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: pot_transpir_mod_x                   !! potential transpiration divided by veget_max (per m2)
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: transpir_supply_x                    !! Water supply to the leaves for transpiration
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: vir_transpir_supply_x                !! Virtual supply of water for transpiration to deal
+                                                                                    !! with water stress when PFT1 becomes vegetated in LCC
+                                                                                    !! @tex $(mm dt^{-1})$ @endtex
+  REAL(r_std),DIMENSION(:),ALLOCATABLE      :: litterhum                            !! Litter humidity
+  REAL(r_std),DIMENSION(:),ALLOCATABLE      :: precip_rain,precip_snow              !! Rainfall, Snowfall
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: gpp_x                                !! GPP (gC/(m**2 of total ground)/time step)
+  REAL(r_std),DIMENSION(:),ALLOCATABLE      :: deadleaf_cover                       !! fraction of soil covered by dead leaves
+  REAL(r_std),DIMENSION(:,:,:),ALLOCATABLE  :: assim_param_x                        !! min/max/opt temperature for photosynthesis 
+                                                                                    !! and vcmax/vjmax parameters 
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: height_x                             !! height (m)
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: qsintmax_x                           !! Maximum water on vegetation for interception
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: co2_flux                             !! CO2 flux in gC/m**2 of ground/second
+  REAL(r_std),DIMENSION(:),ALLOCATABLE      :: fco2_lu                              !! Land Cover Change CO2 flux (gC/m**2 of 
+  REAL(r_std),DIMENSION(:),ALLOCATABLE      :: temp_growth                          !! Growth temperature - Is equal to t2m_month (Â°C)
+                                                                                    !! average ground/s)
+  REAL(r_std),DIMENSION(:,:,:),ALLOCATABLE  :: Isotrop_Tran_Tot_p_x                 !! Transmitted radiation per level (unitless)
+
+  INTEGER(i_std),DIMENSION(:),ALLOCATABLE   :: indices_g                            !! Vector of indeces of land points
+  REAL(r_std),DIMENSION(:),ALLOCATABLE      :: x_indices_g                          !! Vector of indeces of land points
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: x_neighbours_g                       !! Indeces of neighbours for each land point
+
+  INTEGER                                   :: ier,iret                             !! Return value of functions used to catch 
+                                                                                    !! errors 
+  INTEGER                                   :: ncfid                                !! Id of the restart file of SECHIBA used in 
+                                                                                    !! input 
+  CHARACTER(LEN=20),SAVE                    :: thecalendar='noleap'                 !! Type of calendar used
+  LOGICAL                                   :: a_er                                 !! Flag used to check errors when allocating
+  CHARACTER(LEN=80) :: &                                                            !! Name of the restart files used for
+ &  dri_restname_in,dri_restname_out, &                                             !! the driver in/out
+ &  sec_restname_in,sec_restname_out, &                                             !! the sechiba component in/out
+ &  sto_restname_in,sto_restname_out, &                                             !! the stomate component in/out
+ &  stom_histname, stom_ipcc_histname                                               !! Name of the history files for stomate 
+                                                                                    !! (standard and ippc format) 
+  INTEGER(i_std)                            :: iim,jjm,llm                          !! # of lon,lat and time-step in the restart 
+                                                                                    !! files 
+  REAL, ALLOCATABLE, DIMENSION(:,:)         :: lon, lat                             !! Arrays of Longitude and latitude (iim,jjm) 
+                                                                                    !! dimension for each processor 
+  REAL, ALLOCATABLE, DIMENSION(:)           :: lev                                  !! height level (required by the restini 
+                                                                                    !! interface) 
+  LOGICAL                                   :: rectilinear                          !! Is the grid rectilinear
+  REAL, ALLOCATABLE, DIMENSION(:)           :: lon_rect, lat_rect                   !! Vectors of Longitude and latitude (iim or 
+                                                                                    !! jjm) dimension used in case of a 
+                                                                                    !! rectilinear grid 
+  REAL(r_std)                               :: dt                                   !! Time step of sechiba component read in the 
+                                                                                    !! restart file [seconds] 
+  INTEGER(i_std)                            :: itau_dep,itau_fin,itau               !! First, last and current time step of SECHIBA 
+                                                                                    !! component 
+  INTEGER(i_std)                            :: itau_len,itau_step                   !! Total length of the simulation and length 
+                                                                                    !! between 2 calls of slowproc (expreseed in 
+                                                                                    !! time steps of SECHIBA component) 
+  REAL(r_std)                               :: date0                                !! Initial date
+  INTEGER(i_std)                            :: rest_id_sec,rest_id_sto              !! ID's of the restart files for the SECHIBA 
+                                                                                    !! and STOMATE components 
+  INTEGER(i_std)                            :: hist_id_sec,hist_id_sec2             !! ID's of the history files of SECHIBA 
+                                                                                    !! component (required by the interface of 
+                                                                                    !! slowproc but not used) 
+  INTEGER(i_std)                            :: hist_id_stom,hist_id_stom_IPCC       !! ID's of the history files of STOMATE 
+                                                                                    !! component 
+  CHARACTER(LEN=30)                         :: time_str                             !! String used for reading the length of 
+                                                                                    !! simulation in the .def file 
+  REAL(r_std)                               :: dt_slow_                             !! 
+  REAL                                      :: hist_days_stom,hist_days_stom_ipcc   !! Time frequency at which variables are 
+                                                                                    !! written in the history file for the STOMATE 
+                                                                                    !! component (standard and ipcc format) [day] 
+  REAL                                      :: hist_dt_stom,hist_dt_stom_ipcc       !! Time frequency at which variables are 
+                                                                                    !! written in the history file for the STOMATE 
+                                                                                    !! component (standard and ipcc format) 
+                                                                                    !! [second] 
+  REAL(r_std), ALLOCATABLE, DIMENSION(:)    :: hist_PFTaxis                         !! Vector with PFT indeces used as axis in the 
+                                                                                    !! history file 
+    REAL(r_std), DIMENSION(nshort)               :: hist_pool_s_axis   !! Deforestation axis
+    REAL(r_std), DIMENSION(nmedium)              :: hist_pool_m_axis   !! Deforestation axis
+    REAL(r_std), DIMENSION(nlong)                :: hist_pool_l_axis   !! Deforestation axis
+    REAL(r_std), DIMENSION(nshort+1)             :: hist_pool_ss_axis  !! Deforestation axis
+    REAL(r_std), DIMENSION(nmedium+1)            :: hist_pool_mm_axis  !! Deforestation axis
+    REAL(r_std), DIMENSION(nlong+1)              :: hist_pool_ll_axis  !! Deforestation axis
+!  REAL(r_std),DIMENSION(10)                 :: hist_pool_10axis                     !! Vector with 10-year indeces used as axis in 
+                                                                                    !! the history file (for land-use change) 
+!  REAL(r_std),DIMENSION(100)                :: hist_pool_100axis                    !! Vector with 100-year indeces used as axis in 
+                                                                                    !! the history file (for land-use change) 
+!  REAL(r_std),DIMENSION(11)                 :: hist_pool_11axis                     !! Vector with 11-year indeces used as axis in 
+                                                                                    !! the history file (for land-use change) 
+!  REAL(r_std),DIMENSION(101)                :: hist_pool_101axis                    !! Vector with 101-year indeces used as axis in 
+                                                                                    !! the history file (for land-use change) 
+  INTEGER                                   :: hist_PFTaxis_id,hist_IPCC_PFTaxis_id !! Id of the axis for PFT in the standard/IPCC 
+                                                                                    !! format 
+  INTEGER                                   :: hori_id 
+    INTEGER(i_std)                               :: hist_pool_s_axis_id
+    INTEGER(i_std)                               :: hist_pool_m_axis_id
+    INTEGER(i_std)                               :: hist_pool_l_axis_id
+    INTEGER(i_std)                               :: hist_pool_ss_axis_id
+    INTEGER(i_std)                               :: hist_pool_mm_axis_id
+    INTEGER(i_std)                               :: hist_pool_ll_axis_id
+    INTEGER(i_std)                               :: canx_id
+    INTEGER(i_std)                               :: canx_tot_stom_id
+!  INTEGER                                   :: hist_pool_10axis_id                  !! Id of the axis for 10-year vector
+!  INTEGER                                   :: hist_pool_100axis_id                 !! Id of the axis for the 100-year vector
+!  INTEGER                                   :: hist_pool_11axis_id                  !! Id of the axis for the 11-year vector
+!  INTEGER                                   :: hist_pool_101axis_id                 !! Id of the axis for the 101-year vector
+  INTEGER(i_std)                            :: i,j,iv                               !! used as counters
+  LOGICAL                                   :: ldrestart_read,ldrestart_write       !! Flags to activate reading/writing of the 
+                                                                                    !! restart file 
+  LOGICAL                                   :: l1d                                  !! Are vector elements 1-dimension size ?
+  INTEGER(i_std),PARAMETER                  :: nbvarmax=200                         !! Maximum number of variables assumed in the 
+                                                                                    !! restart file of SECHIBA component used as 
+                                                                                    !! input 
+  INTEGER(i_std)                            :: nbvar                                !! Number of variables present in the restart 
+                                                                                    !! file of SECHIBA component used as input 
+  CHARACTER(LEN=50),DIMENSION(nbvarmax)     :: varnames                             !! Name of the variables present in the restart 
+                                                                                    !! file of SECHIBA component used as input 
+  INTEGER(i_std)                            :: varnbdim                             !! Number of dimensions of a variable 
+                                                                                    !! varnames(i) 
+  INTEGER(i_std),PARAMETER                  :: varnbdim_max=20                      !! Maximum number of dimensions of a variable 
+                                                                                    !! varnames(i) 
+  INTEGER,DIMENSION(varnbdim_max)           :: vardims
+  CHARACTER(LEN=200)                        :: taboo_vars
+  REAL(r_std),DIMENSION(1)                  :: xtmp
+  INTEGER                                   :: nsfm,nsft
+  INTEGER                                   :: iisf,iiisf
+  INTEGER(i_std)                            :: max_totsize,totsize_1step
+  INTEGER(i_std)                            :: totsize_tmp  
+  INTEGER                                   :: vid
+  CHARACTER(LEN=100)                        :: forcing_name
+  REAL                                      :: x
+
+  REAL(r_std),DIMENSION(:,:),ALLOCATABLE    :: var_3d
+  REAL(r_std)                               :: var_1d(1)
+
+!-
+  REAL(r_std)                               :: time_sec,time_step_sec
+  REAL(r_std)                               :: time_dri,time_step_dri
+  REAL(r_std),DIMENSION(1)                  :: r1d
+  REAL(r_std)                               :: julian,djulian
+
+  INTEGER(i_std)                            :: ji,jv,l
+
+  LOGICAL :: debug
+
+  REAL(r_std), DIMENSION(:),ALLOCATABLE     :: z_levels_tot       !! A dummy array to label canopy levels
+  INTEGER(i_std)                            :: ilev,ivm           !! Index
+
+!---------------------------------------------------------------------
+
+  !-
+  ! 1. Reading parameters, Allocating variables and Initializations
+  !-
+
+  CALL Init_orchidee_para
+!ANNE  CALL init_para(.FALSE.)
+  CALL init_timer
+
+  IF (is_root_prc) THEN
+     !-
+     ! open STOMATE's forcing file to read some basic info
+     !-
+     forcing_name = 'stomate_forcing.nc'
+     CALL getin ('STOMATE_FORCING_NAME',forcing_name)
+     iret = NF90_OPEN (TRIM(forcing_name),NF90_NOWRITE,forcing_id)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'teststomate', &
+             &        'Could not open file : ', &
+             &          forcing_name,'(Do you have forget it ?)')
+     ENDIF
+     ier = NF90_GET_ATT (forcing_id,NF90_GLOBAL,'dtradia',dtradia)
+     ier = NF90_GET_ATT (forcing_id,NF90_GLOBAL,'dt_slow',dt_force)
+     ier = NF90_GET_ATT (forcing_id,NF90_GLOBAL,'nsft',x)
+     nsft = NINT(x)
+     ier = NF90_GET_ATT (forcing_id,NF90_GLOBAL,'kjpij',x)
+     kjpij = NINT(x)
+     ier = NF90_GET_ATT (forcing_id,NF90_GLOBAL,'kjpindex',x)
+     nbp_glo = NINT(x)
+  ENDIF
+
+  CALL bcast(dtradia)
+  CALL bcast(dt_force)
+  CALL bcast(nsft)
+  CALL bcast(nbp_glo)
+  !-
+  write(numout,*) 'ATTENTION',dtradia,dt_force
+  !-
+  ! read info about land points
+  !-
+  IF (is_root_prc) THEN
+     a_er=.FALSE.
+     ALLOCATE (indices_g(nbp_glo),stat=ier)
+     a_er = a_er .OR. (ier.NE.0)
+     IF (a_er) THEN
+        CALL ipslerr (3,'teststomate', &
+             &        'PROBLEM WITH ALLOCATION', &
+             &        'for local variables 1','')
+     ENDIF
+     !
+     ALLOCATE (x_indices_g(nbp_glo),stat=ier)
+     a_er = a_er .OR. (ier.NE.0)
+     IF (a_er) THEN
+        CALL ipslerr (3,'teststomate', &
+             &        'PROBLEM WITH ALLOCATION', &
+             &        'for global variables 1','')
+     ENDIF
+     ier = NF90_INQ_VARID (forcing_id,'index',vid)
+     IF (ier .NE. 0) THEN
+        CALL ipslerr (3,'teststomate', &
+             &        'PROBLEM WITH ALLOCATION', &
+             &        'for global variables 1','')
+     ENDIF
+     ier = NF90_GET_VAR   (forcing_id,vid,x_indices_g)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'teststomate', &
+             &        'PROBLEM WITH variable "index" in file ', &
+             &        forcing_name,'(check this file)')
+     ENDIF
+     indices_g(:) = NINT(x_indices_g(:))
+     DEALLOCATE (x_indices_g)
+  ELSE
+     ALLOCATE (indices_g(0))
+  ENDIF
+
+!---------------------------------------------------------------------
+!-
+! set debug to have more information
+!-
+  !Config Key   = DEBUG_INFO
+  !Config Desc  = Flag for debug information
+  !Config If    = [-]
+  !Config Def   = n
+  !Config Help  = This option allows to switch on the output of debug
+  !Config         information without recompiling the code.
+  !Config Units = [FLAG]
+!-
+  debug = .FALSE.
+  CALL getin_p('DEBUG_INFO',debug)
+  !
+  !Config Key   = LONGPRINT
+  !Config Desc  = ORCHIDEE will print more messages
+  !Config If    = [-]
+  !Config Def   = n
+  !Config Help  = This flag permits to print more debug messages in the run.
+  !Config Units = [FLAG]
+  !
+  long_print = .FALSE.
+  CALL getin_p('LONGPRINT',long_print)
+  !-
+  ! activate CO2, STOMATE, but not sechiba
+  !-
+  control%river_routing = .FALSE.
+  control%hydrol_cwrr = .FALSE.
+  control%ok_sechiba = .FALSE.
+  !
+  control%stomate_watchout = .TRUE.
+  control%ok_co2 = .TRUE.
+  control%ok_stomate = .TRUE.
+  control%forest_management = .FALSE.
+  !-
+  ! is DGVM activated?
+  !-
+  control%ok_dgvm = .FALSE.
+  CALL getin_p('STOMATE_OK_DGVM',control%ok_dgvm)
+  WRITE(numout,*) 'LPJ is activated: ',control%ok_dgvm
+
+!-
+! Configuration
+!-
+  ! 1. Number of PFTs defined by the user
+
+  !Config Key   = NVM
+  !Config Desc  = number of PFTs  
+  !Config If    = OK_SECHIBA or OK_STOMATE
+  !Config Def   = 13
+  !Config Help  = The number of vegetation types define by the user
+  !Config Units = [-]
+  !
+  CALL getin_p('NVM',nvm)
+  WRITE(numout,*)'the number of pfts is : ', nvm
+
+  ! 2. Should we read the parameters in the run.def file ?
+  
+  !Config Key   = IMPOSE_PARAM
+  !Config Desc  = Do you impose the values of the parameters?
+  !Config if    = OK_SECHIBA or OK_STOMATE
+  !Config Def   = y
+  !Config Help  = This flag can deactivate the reading of some parameters.
+  !Config         Useful if you want to use the standard values without commenting the run.def
+  !Config Units = [FLAG]
+  !
+  CALL getin_p('IMPOSE_PARAM',impose_param)
+
+  ! 3. Allocate and intialize the pft parameters
+
+  CALL pft_parameters_main(control)
+
+  ! 4. Activation sub-models of ORCHIDEE
+
+  CALL activate_sub_models(control)
+
+  ! 5. Vegetation configuration (impose_veg, land_use, lcchange...previously in slowproc)
+
+  CALL veget_config
+
+  ! 6. Read the parameters in the run.def file
+
+  IF (impose_param) THEN
+     CALL config_pft_parameters
+     CALL config_stomate_pft_parameters
+     CALL config_co2_parameters
+     CALL config_stomate_parameters
+  ENDIF
+  !-
+  IF (control%ok_dgvm) THEN
+     IF ( impose_param ) THEN
+        CALL config_dgvm_parameters
+     ENDIF
+  ENDIF
+!-
+  !-
+  ! restart files
+  !-
+  IF (is_root_prc) THEN
+     ! Sechiba's restart files
+     sec_restname_in = 'sechiba_start.nc'
+     CALL getin('SECHIBA_restart_in',sec_restname_in)
+     WRITE(numout,*) 'SECHIBA INPUT RESTART_FILE: ',TRIM(sec_restname_in)
+     IF ( TRIM(sec_restname_in) .EQ. 'NONE' ) THEN
+        STOP 'Need a restart file for Sechiba'
+     ENDIF
+     sec_restname_out = 'sechiba_rest_out.nc'
+     CALL getin('SECHIBA_rest_out',sec_restname_out)
+     WRITE(numout,*) 'SECHIBA OUTPUT RESTART_FILE: ',TRIM(sec_restname_out)
+     ! Stomate's restart files
+     sto_restname_in = 'stomate_start.nc'
+     CALL getin('STOMATE_RESTART_FILEIN',sto_restname_in)
+     WRITE(numout,*) 'STOMATE INPUT RESTART_FILE: ',TRIM(sto_restname_in)
+     sto_restname_out = 'stomate_rest_out.nc'
+     CALL getin('STOMATE_RESTART_FILEOUT',sto_restname_out)
+     WRITE(numout,*) 'STOMATE OUTPUT RESTART_FILE: ',TRIM(sto_restname_out)
+
+     !-
+     ! We need to know iim, jjm.
+     ! Get them from the restart files themselves.
+     !-
+     iret = NF90_OPEN (sec_restname_in,NF90_NOWRITE,ncfid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'teststomate', &
+             &        'Could not open file : ', &
+             &          sec_restname_in,'(Do you have forget it ?)')
+     ENDIF
+     iret = NF90_INQUIRE_DIMENSION (ncfid,1,len=iim_g)
+     iret = NF90_INQUIRE_DIMENSION (ncfid,2,len=jjm_g)
+     iret = NF90_INQ_VARID (ncfid, "time", iv)
+     iret = NF90_GET_ATT (ncfid, iv, 'calendar',thecalendar)
+     iret = NF90_CLOSE (ncfid)
+     i=INDEX(thecalendar,ACHAR(0))
+     IF ( i > 0 ) THEN
+        thecalendar(i:20)=' '
+     ENDIF
+  ENDIF
+  CALL bcast(iim_g)
+  CALL bcast(jjm_g)
+  CALL bcast(thecalendar)
+  !-
+  ! calendar
+  !-
+  CALL ioconf_calendar (thecalendar)
+  CALL ioget_calendar  (one_year,one_day)
+  !
+  ! Parallelization :
+  !
+!  CALL init_data_para(iim_g,jjm_g,nbp_glo,indices_g)
+  call init_orchidee_data_para_driver(nbp_glo, indices_g)
+  kjpindex=nbp_loc
+  jjm=jj_nb
+  iim=iim_g
+  kjpij=iim*jjm
+  IF (debug) WRITE(numout,*) "Local grid : ",kjpindex,iim,jjm
+  !-
+  !-
+  ! read info about grids
+  !-
+  !-
+  llm=1
+  ALLOCATE(lev(llm))
+  IF (is_root_prc) THEN
+     !-
+     ier = NF90_INQ_VARID (forcing_id,'lalo',vid)
+     ier = NF90_GET_VAR   (forcing_id,vid,lalo_g)
+     !-
+     ALLOCATE (x_neighbours_g(nbp_glo,8),stat=ier)
+     ier = NF90_INQ_VARID (forcing_id,'neighbours',vid)
+     ier = NF90_GET_VAR   (forcing_id,vid,x_neighbours_g)
+     neighbours_g(:,:) = NINT(x_neighbours_g(:,:))
+     DEALLOCATE (x_neighbours_g)
+     !-
+     ier = NF90_INQ_VARID (forcing_id,'resolution',vid)
+     ier = NF90_GET_VAR   (forcing_id,vid,resolution_g)
+     !-
+     ier = NF90_INQ_VARID (forcing_id,'contfrac',vid)
+     ier = NF90_GET_VAR   (forcing_id,vid,contfrac_g)
+
+     lon_g(:,:) = zero
+     lat_g(:,:) = zero
+     lev(1)   = zero
+     !-
+     CALL restini &
+          & (sec_restname_in, iim_g, jjm_g, lon_g, lat_g, llm, lev, &
+          &  sec_restname_out, itau_dep, date0, dt, rest_id_sec)
+     !-
+     IF ( dt .NE. dtradia ) THEN
+        WRITE(numout,*) 'dt',dt
+        WRITE(numout,*) 'dtradia',dtradia
+        CALL ipslerr (3,'teststomate', &
+             &        'PROBLEM with time steps.', &
+             &          sec_restname_in,'(dt .NE. dtradia)')
+     ENDIF
+     !-
+     CALL restini &
+          & (sto_restname_in, iim_g, jjm_g, lon_g, lat_g, llm, lev, &
+          &  sto_restname_out, itau_dep, date0, dt, rest_id_sto)
+     !-
+     IF ( dt .NE. dtradia ) THEN
+        WRITE(numout,*) 'dt',dt
+        WRITE(numout,*) 'dtradia',dtradia
+        CALL ipslerr (3,'teststomate', &
+             &        'PROBLEM with time steps.', &
+             &          sto_restname_in,'(dt .NE. dtradia)')
+     ENDIF
+  ENDIF
+  CALL bcast(rest_id_sec)
+  CALL bcast(rest_id_sto)
+  CALL bcast(itau_dep)
+  CALL bcast(date0)
+  CALL bcast(dt)
+  CALL bcast(lev)
+  !---
+  !--- Create the index table
+  !---
+  !--- This job return a LOCAL kindex
+  !---
+  ALLOCATE (indices(kjpindex),stat=ier)
+  IF (debug .AND. is_root_prc) WRITE(numout,*) "indices_g = ",indices_g(1:nbp_glo)
+  CALL scatter(indices_g,indices)
+  indices(1:kjpindex)=indices(1:kjpindex)-(jj_begin-1)*iim_g
+  IF (debug) WRITE(numout,*) "indices = ",indices(1:kjpindex)
+
+  !---
+  !--- initialize global grid
+  !---
+  CALL init_grid( kjpindex ) 
+  CALL grid_stuff (nbp_glo, iim_g, jjm_g, lon_g, lat_g, indices_g)
+
+  !---
+  !--- initialize local grid
+  !---
+  jlandindex = (((indices(1:kjpindex)-1)/iim) + 1)
+  if (debug) WRITE(numout,*) "jlandindex = ",jlandindex(1:kjpindex)
+  ilandindex = (indices(1:kjpindex) - (jlandindex(1:kjpindex)-1)*iim)
+  IF (debug) WRITE(numout,*) "ilandindex = ",ilandindex(1:kjpindex)
+  ALLOCATE(lon(iim,jjm))
+  ALLOCATE(lat(iim,jjm))
+  lon=zero
+  lat=zero
+  CALL scatter2D_mpi(lon_g,lon)
+  CALL scatter2D_mpi(lat_g,lat)
+
+  DO ji=1,kjpindex
+
+     j = jlandindex(ji)
+     i = ilandindex(ji)
+
+     !- Create the internal coordinate table
+!-
+     lalo(ji,1) = lat(i,j)
+     lalo(ji,2) = lon(i,j)
+  ENDDO
+  CALL scatter(neighbours_g,neighbours)
+  CALL scatter(resolution_g,resolution)
+  CALL scatter(contfrac_g,contfrac)
+  CALL scatter(area_g,area)
+  !-
+  !- Check if we have by any chance a rectilinear grid. This would allow us to 
+  !- simplify the output files.
+  !
+  rectilinear = .FALSE.
+  IF (is_root_prc) THEN
+     IF ( ALL(lon_g(:,:) == SPREAD(lon_g(:,1), 2, SIZE(lon_g,2))) .AND. &
+       & ALL(lat_g(:,:) == SPREAD(lat_g(1,:), 1, SIZE(lat_g,1))) ) THEN
+        rectilinear = .TRUE.
+     ENDIF
+  ENDIF
+  CALL bcast(rectilinear)
+  IF (rectilinear) THEN
+     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
+  !-
+  ! allocate arrays
+  !-
+  !
+  a_er = .FALSE.
+  ALLOCATE (hist_PFTaxis(nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (indexveg(kjpindex*nvm), stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (soiltile(kjpindex,nstm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (veget_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (totfrac_nobio(kjpindex),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (frac_nobio(kjpindex,nnobio),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (veget_max_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (lai_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+
+  ! the following are variables needed for the effective LAI calculation in stomate, but they do not
+  ! change any of the pools, so their values don't matter in teststomate
+  ALLOCATE (sinang_x(kjpindex),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  sinang_x=0.5_r_std 
+  ALLOCATE (circ_class_n_x(kjpindex,nvm,ncirc),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (circ_class_biomass_x(kjpindex,nvm,ncirc,nparts,nelements),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ! end effective LAI variables
+
+  ALLOCATE (ind_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (biomass_x(kjpindex,nvm,nparts,nelements),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (veget_force_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (veget_max_force_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (njsc(kjpindex),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (lai_force_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (reinf_slope(kjpindex),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (t2m(kjpindex),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (t2m_min(kjpindex),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (temp_sol(kjpindex),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (soiltemp(kjpindex,nbdl),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (soilhum(kjpindex,nbdl),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (humrel_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (transpir_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (transpir_mod_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (pot_transpir_mod_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (transpir_supply_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (vir_transpir_supply_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (litterhum(kjpindex),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (precip_rain(kjpindex),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (precip_snow(kjpindex),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (gpp_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (deadleaf_cover(kjpindex),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (assim_param_x(kjpindex,nvm,npco2),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (height_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (qsintmax_x(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (co2_flux(kjpindex,nvm),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (fco2_lu(kjpindex),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (temp_growth(kjpindex),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  ALLOCATE (frac_age_x(kjpindex,nvm,nleafages),stat=ier)
+  a_er = a_er .OR. (ier.NE.0)
+  IF (a_er) THEN
+     CALL ipslerr (3,'teststomate', &
+          &        'PROBLEM WITH ALLOCATION', &
+          &        'for local variables 1','')
+  ENDIF
+  !
+  ! prepare forcing
+  ! forcing file of STOMATE is read by block 
+  ! in order to minimize the reading frequency
+  ! Here is done the calculation of the number 
+  ! of time steps we load in memory 
+  !
+  max_totsize = 50
+  CALL getin_p ('STOMATE_FORCING_MEMSIZE',max_totsize)
+  max_totsize = max_totsize * 1000000
+
+  totsize_1step = SIZE(soiltile(:,3))*KIND(soiltile(:,3)) + &
+       SIZE(humrel_x)*KIND(humrel_x) + &
+       SIZE(litterhum)*KIND(litterhum) + &
+       SIZE(t2m)*KIND(t2m) + &
+       SIZE(t2m_min)*KIND(t2m_min) + &
+       SIZE(temp_sol)*KIND(temp_sol) + &
+       SIZE(soiltemp)*KIND(soiltemp) + &
+       SIZE(soilhum)*KIND(soilhum) + &
+       SIZE(precip_rain)*KIND(precip_rain) + &
+       SIZE(precip_snow)*KIND(precip_snow) + &
+       SIZE(gpp_x)*KIND(gpp_x) + &
+       SIZE(veget_force_x)*KIND(veget_force_x) + &
+       SIZE(veget_max_force_x)*KIND(veget_max_force_x) + &
+       SIZE(lai_force_x)*KIND(lai_force_x)
+  CALL reduce_sum(totsize_1step,totsize_tmp)
+  CALL bcast(totsize_tmp)
+  totsize_1step=totsize_tmp 
+
+  ! check for consistency of the total number of forcing steps
+  IF ( nsft .NE. INT(one_year/(dt_force/one_day)) ) THEN
+     CALL ipslerr_p (3,'teststomate', &
+          &        'stomate: error with total number of forcing steps', &
+          &        'nsft','teststomate computation different with forcing file value.')
+  ENDIF
+  ! number of forcing steps in memory
+  nsfm = MIN(nsft, &
+       &       MAX(1,NINT( REAL(max_totsize,r_std) &
+       &                  /REAL(totsize_1step,r_std))))
+  !-
+  WRITE(numout,*) 'Offline forcing of Stomate:'
+  WRITE(numout,*) '  Total number of forcing steps:',nsft
+  WRITE(numout,*) '  Number of forcing steps in memory:',nsfm
+  !-
+  ! init_forcing defined into stomate.f90
+  ! allocate and set to zero driving variables of STOMATE
+  ! ie variables that are read in the forcing file
+  !-
+  CALL init_forcing(kjpindex,nsfm,nsft)
+  !-
+  ! ensure that we read all new forcing states
+  iisf = nsfm
+  ! initialize the table that contains the indices
+  ! of the forcing states that will be in memory
+  isf(:) = (/ (i,i=1,nsfm) /)
+
+  nf_written(:) = .FALSE.
+  nf_written(isf(:)) = .TRUE.
+
+  !-
+  ! a time step for STOMATE corresponds to itau_step timesteps in SECHIBA
+  !-
+  itau_step = NINT(dt_force/dtradia)
+  IF (debug) WRITE(numout,*) "dtradia, dt_rest, dt_force, itau_step",dtradia, dt, dt_force, itau_step
+  !
+  CALL ioconf_startdate(date0)
+  CALL intsurf_time( itau_dep, date0, dtradia )
+  !-
+  ! Length of integration
+  !-
+  WRITE(time_str,'(a)') '1Y'
+  CALL getin_p ('TIME_LENGTH', time_str)
+  ! transform into itau
+  CALL tlen2itau(time_str, dt, date0, itau_len)
+  ! itau_len*dtradia must be a multiple of dt_force
+  itau_len = NINT( MAX(1.,FLOAT(NINT(itau_len*dtradia/dt_force))) &
+       &                *dt_force/dtradia)
+  !-
+  itau_fin = itau_dep+itau_len
+  !-
+  ! 2. set up STOMATE history file
+  !-
+  !Config Key   = STOMATE_OUTPUT_FILE
+  !Config Desc  = Name of file in which STOMATE's output is going to be written
+  !Config If    = 
+  !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.
+  !Config Units = FILE
+  !-
+  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 
+  !Config If    = 
+  !Config Def   = 10.
+  !Config Help  = Time step of the STOMATE history file
+  !Config Units = days [d]
+  !-
+  hist_days_stom = 10.
+  CALL getin_p ('STOMATE_HIST_DT', hist_days_stom)
+  IF ( hist_days_stom == -1. ) THEN
+     hist_dt_stom = -1.
+     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
+  !-
+  !- initialize
+  WRITE(numout,*) "before histbeg : ",date0,dt
+  IF ( rectilinear ) THEN
+#ifdef CPP_PARA
+     CALL histbeg(stom_histname, iim, lon_rect, jjm, lat_rect,  1, iim, 1, jjm, &
+          &     itau_dep, 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, &
+          &     itau_dep, date0, dt, hori_id, hist_id_stom)
+#endif
+  ELSE
+#ifdef CPP_PARA
+     CALL histbeg(stom_histname, iim, lon, jjm, lat,  1, iim, 1, jjm, &
+          &     itau_dep, 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, &
+          &     itau_dep, 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)
+
+!!$!- 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)
+
+
+          ! deforestation
+          !- define Pool_short axis
+          hist_pool_s_axis = (/ ( REAL(i,r_std), i=1,nshort ) /)
+          !- declare this axis
+          CALL histvert (hist_id_stom, 'P_S', 'Short lived pool', &
+               & '1', nshort, hist_pool_s_axis, hist_pool_s_axis_id)
+
+          !- define Pool_medium axis
+          hist_pool_m_axis = (/ ( REAL(i,r_std), i=1,nmedium ) /)
+          !- declare this axis
+          CALL histvert (hist_id_stom, 'P_M', 'Medium lived pool', &
+               & '1', nmedium, hist_pool_m_axis, hist_pool_m_axis_id)
+          
+          !- define Pool_long axis
+          hist_pool_l_axis = (/ ( REAL(i,r_std), i=1,nlong ) /)
+          !- declare this axis
+          CALL histvert (hist_id_stom, 'P_L', 'Long lived pool', &
+               & '1', nlong, hist_pool_l_axis, hist_pool_l_axis_id)
+          
+          !- define Pool_ss axis
+          hist_pool_ss_axis = (/ ( REAL(i,r_std), i=1,nshort+1 ) /)
+          !- declare this axis
+          CALL histvert (hist_id_stom, 'P_SS', 'short lived pool years + 1', &
+               & '1', nshort+1, hist_pool_ss_axis, hist_pool_ss_axis_id)
+
+          !- define Pool_mm axis
+          hist_pool_mm_axis = (/ ( REAL(i,r_std), i=1,nmedium+1 ) /)
+          !- declare this axis
+          CALL histvert (hist_id_stom, 'P_MM', 'medium lived pool years + 1', &
+               & '1', nmedium+1, hist_pool_mm_axis, hist_pool_mm_axis_id)
+          
+          !- define Pool_ll axis
+          hist_pool_ll_axis = (/ ( REAL(i,r_std), i=1,nlong+1 ) /)
+          !- declare this axis
+          CALL histvert (hist_id_stom, 'P_LL', 'long lived pool  years + 1', &
+               & '1', nlong+1, hist_pool_ll_axis, hist_pool_ll_axis_id)
+
+         ! For the number of canopy levels
+          CALL histvert(hist_id_stom, 'canlevel', 'Canopy levels', 'm', &
+               &    nlevels,  z_level, canx_id)
+
+         ! For the number of canopy levels including all those used in photosynthesis.
+          ! Notice we cannot use the real heights here, since they can change every day
+          ! as the canopy develops.
+          ALLOCATE(z_levels_tot(nlevels_tot))
+          DO ilev=1,nlevels_tot
+             z_levels_tot(ilev)=REAL(ilev,r_std)
+          ENDDO
+          CALL histvert(hist_id_stom, 'canleveltot', 'Total canopy levels', '-', &
+               &    nlevels_tot,  z_levels_tot, canx_tot_stom_id)
+          DEALLOCATE(z_levels_tot)
+
+  !- define STOMATE history file
+  CALL stom_define_history (hist_id_stom, nvm, control, iim, jjm, &
+            & dt, hist_dt_stom, hori_id, hist_PFTaxis_id, &
+            & hist_pool_s_axis_id, hist_pool_m_axis_id, & 
+            & hist_pool_l_axis_id, hist_pool_ss_axis_id, &
+            & hist_pool_mm_axis_id, hist_pool_ll_axis_id, canx_id,&
+            canx_tot_stom_id)
+
+  !- 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 to be written
+  !Config If    = 
+  !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.
+  !Config Units = FILE
+  !-
+  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 
+  !Config If    = 
+  !Config Def   = 0.
+  !Config Help  = Time step of the STOMATE IPCC history file
+  !Config Units = days [d]
+  !-
+  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_p (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, &
+             &     itau_dep, 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, &
+             &     itau_dep, 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, &
+             &     itau_dep, 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, &
+             &     itau_dep, 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
+  !
+  CALL histwrite_p(hist_id_stom, 'Areas',  itau_dep+itau_step, area, kjpindex, indices)
+  IF ( hist_id_stom_IPCC > 0 ) THEN
+     CALL histwrite_p(hist_id_stom_IPCC, 'Areas',  itau_dep+itau_step, area, kjpindex, indices)
+  ENDIF
+  !
+  hist_id_sec = -1
+  hist_id_sec2 = -1
+  !-
+  ! 3. first call of slowproc to initialize variables
+  !-
+  itau = itau_dep
+  !  
+  DO ji=1,kjpindex
+     DO jv=1,nvm
+        indexveg((jv-1)*kjpindex + ji) = indices(ji) + (jv-1)*kjpij
+     ENDDO
+  ENDDO
+  !-
+  !
+  !Config key   = HYDROL_CWRR
+  !Config Desc  = Allows to switch on the multilayer hydrology of CWRR
+  !Config If    = OK_SECHIBA
+  !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.
+  !Config Units = [FLAG]
+  CALL getin_p ("HYDROL_SOIL_DEPTH", dpu_max)
+  !
+  !MM Problem here with dpu which depends on soil type           
+  DO l = 1, nbdl-1
+     ! first 2.0 is dpu 
+     ! second 2.0 is average
+     diaglev(l) = dpu_max/(2**(nbdl-1) -1) * ( ( 2**(l-1) -1) + ( 2**(l) -1) ) / 2.0
+  ENDDO
+  diaglev(nbdl) = dpu_max
+  !
+!-
+! Read the parameters in the "*.def" files
+!-
+  !
+  !Config Key   = CLAYFRACTION_DEFAULT
+  !Config Desc  = 
+  !Config If    = OK_SECHIBA 
+  !Config Def   = 0.2 
+  !Config Help  = 
+  !Config Units = [-]
+  CALL getin_p('CLAYFRACTION_DEFAULT',clayfraction_default)
+  !
+  !Config Key   = MIN_VEGFRAC 
+  !Config Desc  = Minimal fraction of mesh a vegetation type can occupy 
+  !Config If    = OK_SECHIBA 
+  !Config Def   = 0.001 
+  !Config Help  = 
+  !Config Units = [-]
+  CALL getin_p('MIN_VEGFRAC',min_vegfrac)
+  !
+  !Config Key   = STEMPDIAG_BID 
+  !Config Desc  = only needed for an initial LAI if there is no restart file
+  !Config If    = OK_SECHIBA 
+  !Config Def   = 280.
+  !Config Help  = 
+  !Config Units = [K]
+  CALL getin_p('STEMPDIAG_BID',stempdiag_bid)
+  !
+!-
+  CALL ioget_expval(val_exp)
+  ldrestart_read = .TRUE.
+  ldrestart_write = .FALSE.
+  !-
+  ! read some variables we need from SECHIBA's restart file
+  !-
+  CALL slowproc_main &
+ &  (itau, kjpij, kjpindex, dt_force, date0, &
+ &   ldrestart_read, ldrestart_write, .FALSE., .TRUE., &
+ &   indices, indexveg, lalo, neighbours, resolution, contfrac, soiltile, reinf_slope, &
+ &   t2m, t2m_min, temp_sol, soiltemp, &
+ &   humrel_x, soilhum, litterhum, precip_rain, precip_snow, gpp_x, &
+ &   deadleaf_cover, assim_param_x, lai_x, frac_age_x, height_x, veget_x, &
+ &   frac_nobio, njsc, veget_max_x, totfrac_nobio, qsintmax_x, &
+ &   rest_id_sec, hist_id_sec, hist_id_sec2, rest_id_sto, hist_id_stom, hist_id_stom_IPCC, co2_flux, fco2_lu, &
+     sinang_x, circ_class_biomass_x, circ_class_n_x, transpir_x, transpir_mod_x, &
+     pot_transpir_mod_x, transpir_supply_x, biomass_x, ind_x, lai_per_level_x, laieff_fit_x, &
+     vir_transpir_supply_x,  temp_growth, Isotrop_Tran_Tot_p_x)
+
+  ! correct date
+
+
+  day_counter = one_day - dt_force
+  date=1
+  IF (debug) check_time=.TRUE.
+  CALL intsurf_time( itau_dep+itau_step, date0, dtradia )
+  l_first_intersurf=.FALSE.
+  !-
+  ! 4. Time loop
+  !â»
+  DO itau = itau_dep+itau_step,itau_fin,itau_step
+    !
+    CALL intsurf_time( itau, date0, dtradia )
+    !-
+    ! next forcing state
+    iisf = iisf+1
+    IF (debug) WRITE(numout,*) "itau,iisf : ",itau,iisf
+    !---
+    IF (iisf .GT. nsfm) THEN
+!-----
+!---- we have to read new forcing states from the file
+!-----
+!---- determine blocks of forcing states that are contiguous in memory
+!-----
+        CALL forcing_read(forcing_id,nsfm)
+
+!--------------------------
+
+!-----
+!---- determine which forcing states must be read next time
+!-----
+      isf(1) = isf(nsfm)+1
+      IF ( isf(1) .GT. nsft ) isf(1) = 1
+        DO iiisf = 2, nsfm
+           isf(iiisf) = isf(iiisf-1)+1
+           IF ( isf(iiisf) .GT. nsft ) isf(iiisf) = 1
+        ENDDO
+        nf_written(isf(:)) = .TRUE.
+!---- start again at first forcing state
+        iisf = 1
+     ENDIF
+     humrel_x(:,:) = humrel_daily_fm(:,:,iisf)
+     litterhum(:) = litterhum_daily_fm(:,iisf)
+     t2m(:) = t2m_daily_fm(:,iisf)
+     t2m_min(:) = t2m_min_daily_fm(:,iisf)
+     temp_sol(:) = tsurf_daily_fm(:,iisf)
+     soiltemp(:,:) = tsoil_daily_fm(:,:,iisf)
+     soilhum(:,:) = soilhum_daily_fm(:,:,iisf)
+     precip_rain(:) = precip_fm(:,iisf)
+     gpp_x(:,:) = gpp_daily_fm(:,:,iisf)
+     veget_force_x(:,:) = veget_fm(:,:,iisf)
+     veget_max_force_x(:,:) = veget_max_fm(:,:,iisf)
+     lai_force_x(:,:) = lai_fm(:,:,iisf)
+     WHERE ( t2m(:) .LT. ZeroCelsius )
+        precip_snow(:) = precip_rain(:)
+        precip_rain(:) = zero
+     ELSEWHERE
+        precip_snow(:) = zero
+     ENDWHERE
+!---
+!-- scale GPP to new lai and veget_max
+!---
+     WHERE ( lai_x(:,:) .EQ. zero ) gpp_x(:,:) = zero
+!-- scale GPP to new LAI
+     WHERE (lai_force_x(:,:) .GT. zero )
+        gpp_x(:,:) = gpp_x(:,:)*ATAN(2.*lai_x(:,:)) &
+ &                           /ATAN( 2.*MAX(lai_force_x(:,:),0.01))
+    ENDWHERE
+    !- scale GPP to new veget_max
+    WHERE (veget_max_force_x(:,:) .GT. zero )
+        gpp_x(:,:) = gpp_x(:,:)*veget_max_x(:,:)/veget_max_force_x(:,:)
+    ENDWHERE
+    !-
+    !- number crunching
+    !-
+     ldrestart_read = .FALSE.
+     ldrestart_write = .FALSE.
+     CALL slowproc_main &
+ &    (itau, kjpij, kjpindex, dt_force, date0, &
+ &     ldrestart_read, ldrestart_write, .FALSE., .TRUE., &
+ &     indices, indexveg, lalo, neighbours, resolution, contfrac, soiltile, reinf_slope, &
+ &     t2m, t2m_min, temp_sol, soiltemp, &
+ &     humrel_x, soilhum, litterhum, precip_rain, precip_snow, gpp_x, &
+ &     deadleaf_cover, assim_param_x, lai_x, frac_age_x, height_x, veget_x, &
+ &     frac_nobio, njsc, veget_max_x, totfrac_nobio, qsintmax_x, &
+ &     rest_id_sec, hist_id_sec, hist_id_sec2, rest_id_sto, hist_id_stom, hist_id_stom_IPCC, co2_flux, fco2_lu, &
+       sinang_x, circ_class_biomass_x, circ_class_n_x, transpir_x, transpir_mod_x, &
+       pot_transpir_mod_x, transpir_supply_x, biomass_x,ind_x, lai_per_level_x, laieff_fit_x, &
+       vir_transpir_supply_x, temp_growth, Isotrop_Tran_Tot_p_x)
+
+     day_counter = one_day - dt_force
+  ENDDO ! end of the time loop
+
+
+!-
+! 5. write restart files
+!-
+  IF (is_root_prc) THEN
+! first, read and write variables that are not managed otherwise
+     taboo_vars = &
+          &  '$lat$ $lon$ $lev$ $veget_year$ '// &
+          &  '$height$ $day_counter$ $veget$ $veget_max$ $frac_nobio$ '// &
+          &  '$lai$ $soiltile_frac$ $clay_frac$ '// &
+          &  '$nav_lon$ $nav_lat$ $nav_lev$ $time$ $time_steps$'
+!-
+     CALL ioget_vname(rest_id_sec, nbvar, varnames)
+!-
+     DO iv = 1, nbvar
+!-- check if the variable is to be written here
+        IF (INDEX( taboo_vars,'$'//TRIM(varnames(iv))//'$') .EQ. 0 ) THEN
+           IF (debug) WRITE(numout,*) "restart var : ",TRIM(varnames(iv)),itau_dep,itau_fin
+
+!---- get variable dimensions, especially 3rd dimension
+           CALL ioget_vdim &
+                &      (rest_id_sec, varnames(iv), varnbdim_max, varnbdim, vardims)
+           l1d = ALL(vardims(1:varnbdim) .EQ. 1)
+!---- read it
+           IF (l1d) THEN
+              CALL restget (rest_id_sec,TRIM(varnames(iv)), &
+                   1,1,1,itau_dep,.TRUE.,var_1d)
+           ELSE
+              ALLOCATE(var_3d(nbp_glo,vardims(3)),stat=ier)
+              IF (ier .NE. 0) STOP 'ALLOCATION PROBLEM'
+              CALL restget (rest_id_sec,TRIM(varnames(iv)), &
+                   nbp_glo,vardims(3),1,itau_dep,.TRUE.,var_3d, &
+                   "gather",nbp_glo,indices_g)
+           ENDIF
+!---- write it
+           IF (l1d) THEN
+              CALL restput (rest_id_sec,TRIM(varnames(iv)), &
+                   1,1,1,itau_fin,var_1d)
+           ELSE
+              CALL restput (rest_id_sec,TRIM(varnames(iv)), &
+                   nbp_glo,vardims(3),1,itau_fin,var_3d, &
+                   'scatter',nbp_glo,indices_g)
+              DEALLOCATE (var_3d)
+           ENDIF
+        ENDIF
+     ENDDO
+  ENDIF
+  CALL barrier_para()
+
+! call slowproc to write restart files
+  ldrestart_read = .FALSE.
+  ldrestart_write = .TRUE.
+!-
+  IF (debug) WRITE(numout,*) "Call slowproc for restart."
+  CALL slowproc_main &
+ &  (itau_fin, kjpij, kjpindex, dt_force, date0, &
+ &   ldrestart_read, ldrestart_write, .FALSE., .TRUE., &
+ &   indices, indexveg, lalo, neighbours, resolution, contfrac, soiltile, reinf_slope, &
+ &   t2m, t2m_min, temp_sol, soiltemp, &
+ &   humrel_x, soilhum, litterhum, precip_rain, precip_snow, gpp_x, &
+ &   deadleaf_cover, assim_param_x, lai_x, frac_age_x, height_x, veget_x, &
+ &   frac_nobio, njsc, veget_max_x, totfrac_nobio, qsintmax_x, &
+ &   rest_id_sec, hist_id_sec, hist_id_sec2, rest_id_sto, hist_id_stom, hist_id_stom_IPCC, co2_flux, fco2_lu, &
+     sinang_x, circ_class_biomass_x, circ_class_n_x, transpir_x, transpir_mod_x, &
+     pot_transpir_mod_x, transpir_supply_x, biomass_x,ind_x, lai_per_level_x, laieff_fit_x, &
+     vir_transpir_supply_x, temp_growth, Isotrop_Tran_Tot_p_x)
+
+
+!-
+! close files
+!-
+  IF (is_root_prc) THEN
+     CALL restclo
+     IF ( debug )  WRITE(numout,*) 'REST CLOSED'
+  ENDIF
+  CALL histclo
+
+  IF (is_root_prc) &
+       ier = NF90_CLOSE (forcing_id)
+
+  IF (is_root_prc) THEN
+     CALL getin_dump()
+  ENDIF
+#ifdef CPP_PARA
+  CALL MPI_FINALIZE(ier)
+#endif
+  WRITE(numout,*) "End of teststomate."
+
+!---------------
+END PROGRAM teststomate
+!
+!===
+!
Index: branches/publications/ORCHIDEE_CAN_NHA/src_driver/weather.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_driver/weather.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_driver/weather.f90	(revision 7236)
@@ -0,0 +1,4005 @@
+! =================================================================================================================================
+! MODULE       : weather
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        This module simulates weather.
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	:
+!!
+!! SVN          :
+!! $HeadURL: $
+!! $Date: $
+!! $Revision: $
+!! \n
+!_ ================================================================================================================================
+
+MODULE weather
+
+  USE netcdf
+!-
+  USE defprec
+  USE ioipsl_para
+  USE constantes
+  USE mod_orchidee_para
+
+  USE solar
+  USE grid, ONLY : year,month,day,sec
+!-
+  IMPLICIT NONE
+!-
+  PRIVATE
+  PUBLIC weathgen_main, weathgen_domain_size, weathgen_init, weathgen_read_file, weathgen_qsat_2d
+!
+! Only for root proc
+  INTEGER, SAVE                              :: iim_file, jjm_file, llm_file, ttm_file !(unitless)
+  INTEGER,DIMENSION(:,:),SAVE,ALLOCATABLE    :: ncorr !(unitless)
+  INTEGER,DIMENSION(:,:,:),SAVE,ALLOCATABLE  :: icorr,jcorr !(unitless)
+  INTEGER,SAVE                               :: i_cut, n_agg !(unitless)
+
+  REAL,DIMENSION(:,:),SAVE,ALLOCATABLE :: xinwet   !! climatological wet days + anomaly @tex $(days.month^{-1})$ @endtex
+  REAL,DIMENSION(:,:),SAVE,ALLOCATABLE :: xinprec  !! climatological precipition + anomaly @tex $(mm.day^{-1})$ @endtex
+  REAL,DIMENSION(:,:),SAVE,ALLOCATABLE :: xint     !! climatological temp + anomaly (C)
+  REAL,DIMENSION(:,:),SAVE,ALLOCATABLE :: xinq     !! climatological relative humidity + anomaly (0-1, unitless)
+  REAL,DIMENSION(:,:),SAVE,ALLOCATABLE :: xinwind  !! climatological wind speed + anomaly @tex $(m.s^{-1})$ @endtex
+  REAL,DIMENSION(:,:),SAVE,ALLOCATABLE :: xincld   !! climatological cloudiness + anomaly (0-1, unitless)
+  REAL,DIMENSION(:,:),SAVE,ALLOCATABLE :: xintrng  !! climatological temp range + anomaly (C)
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: xintopo  !! topography (m)
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: lat_land !! latitudes of land points (unitless)
+!-
+! daily values
+!-
+  REAL,SAVE :: julian_last
+  INTEGER,DIMENSION(:),SAVE,ALLOCATABLE :: iwet    !! flag for wet day / dry day (0-1, unitless)
+!-
+! today's values (m0 means "minus 0")
+!-
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: psurfm0  !! surface pressure today(Pa)
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: cloudm0  !! cloud fraction today (0-1, unitless)
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: tmaxm0   !! maximum daily temperature today (K)
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: tminm0   !! minimum daily temperature today (K)
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: qdm0     !! daily average specific humidity today (kg_h2o/kg_air)
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: udm0     !! daily average wind speed today  @tex $(m.s^{-1})$ @endtex
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: precipm0 !! daily precitation today @tex $(mm.day^{-1})$ @endtex
+!-
+! yesterday's values (m1 means "minus 1")
+!-
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: psurfm1  !! surface pressure yesterday (Pa)
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: cloudm1  !! cloud fraction yesterday (0-1, unitless)
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: tmaxm1   !! maximum daily temperature yesterday (K)
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: tminm1   !! minimum daily temperature yesterday (K)
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: qdm1     !! daily average specific humidity yesterday (kg_h2o/kg_air)
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: udm1     !! daily average wind speed  yesterday  @tex $(m.s^{-1})$ @endtex 
+  REAL,DIMENSION(:),SAVE,ALLOCATABLE   :: precipm1 !! daily precitation  yesterday @tex $(mm.day^{-1})$ @endtex 
+!-
+! other
+!-
+  INTEGER,SAVE                  :: ipprec        !! statistical (0) or prescribed (1) daily values
+
+  LOGICAL,SAVE                  :: precip_exact  !! respect monthly precipitation
+  INTEGER,DIMENSION(31,12),SAVE :: jour_precip
+
+
+  INTEGER,PARAMETER      :: seedsize_max = 300  !! max size of random seed
+  LOGICAL,SAVE           :: dump_weather
+  CHARACTER(LEN=20),SAVE :: dump_weather_file
+  LOGICAL,SAVE           :: gathered
+  INTEGER,SAVE           :: dump_id
+
+!
+  REAL,PARAMETER         :: zero_t=273.15   !! Absolute zero
+! 
+  REAL,PARAMETER :: pir = pi/180.
+  REAL,PARAMETER :: rair = 287.
+!-
+  INTEGER,PARAMETER :: nmon = 12  !! Number of months
+
+!
+  CHARACTER(LEN=3),DIMENSION(12) :: cal = &             !! Months of the year (unitless)
+ &  (/ 'JAN','FEB','MAR','APR','MAY','JUN', &
+ &     'JUL','AUG','SEP','OCT','NOV','DEC' /)
+  INTEGER,DIMENSION(12),SAVE :: ndaypm = &              !! Number of days per month (noleap year) (unitless)
+ &  (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /)
+  INTEGER,SAVE :: soldownid, rainfid, snowfid, lwradid, &
+ &                tairid, qairid,  psolid, uid, vid, &
+ &                time_id, timestp_id
+!-
+  INTEGER,SAVE :: n_rtp = nf90_real4      !! Parameters for NETCDF 
+!- 
+  INTEGER  :: ALLOC_ERR                   !! Flag for dynamic allocations 
+!-
+  CHARACTER(LEN=20),SAVE :: calendar_str   !! Calendar type
+!-
+  INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: kindex_w  !! Land points index
+  INTEGER, SAVE                            :: nbindex_w  !! Land points index
+!-
+  INTEGER, PARAMETER :: termcol = 100     !! Plot of projection file => grid, number of column on terminal
+!80
+  CONTAINS
+!-
+!===
+!-
+
+!! ================================================================================================================================
+!! SUBROUTINE   : daily
+!!
+!>\BRIEF          This routine generates daily weather conditions from monthly-mean
+!! climatic parameters.
+!!
+!! DESCRIPTION  :  Specifically, this routine generates daily values of 
+!!                 - daily total precipitation \n
+!!                 - daily maximum temperature \n
+!!                 - daily minimum temperature \n
+!!                 - daily average cloud cover \n
+!!                 - daily average relative humidity \n
+!!                 - daily average wind speed \n
+!!                 In order to generate daily weather conditions, the model uses
+!!                 a series of 'weather generator' approaches,
+!!                 which generate random combinations of weather conditions
+!!                 based upon the climatological conditions in general. \n
+!!                 This weather generator is based upon the so-called Richardson
+!!                 weather generator. \n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::psurf, ::cloud, ::tmax, ::tmin, ::qd, ::ud, ::precip 
+!!
+!! REFERENCE(S) :
+!! -  Geng, S., F.W.T. Penning de Vries, and L. Supit, 1985:  A simple
+!! method for generating rainfall data, Agricultural and Forest
+!! Meteorology, 36, 363-376.
+!! -  Richardson, C. W. and Wright, D. A., 1984: WGEN: A model for
+!! generating daily weather variables: U. S. Department of
+!! Agriculture, Agricultural Research Service. 
+!! - Richardson, C., 1981: Stochastic simulation of daily
+!! precipitation, temperature, and solar radiation. Water Resources
+!! Research 17, 182-190. 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE daily &
+ &  (npoi, imonth, iday, cloud, tmax, tmin, precip, qd, ud, psurf)
+
+!-
+! in & out: global variables
+!-
+
+! INTEGER,INTENT(INOUT):: iwet(npoi) !! wet day / dry day flag!*
+!-
+
+  !! 0. Parameters and variables declaration
+
+  REAL,PARAMETER :: rair = 287.     !! Molecular weight of one mole of dry air @tex $(g.mol{-1})$ @endtex
+  REAL,PARAMETER :: grav = 9.81     !! Acceleration of the gravity @tex $(m.s^{-2})$ @endtex
+  REAL,PARAMETER :: pi = 3.1415927  !! pi
+
+  !! 0.1 Input variables
+
+  INTEGER,INTENT(IN) :: npoi         !! total number of land points
+  INTEGER,INTENT(IN) :: imonth, iday
+
+  !! 0.2 Output variables
+
+  REAL,INTENT(OUT) :: psurf(npoi)   !! surface pressure (Pa)
+  REAL,INTENT(OUT) :: cloud(npoi)   !! cloud fraction (0-1, unitless)
+  REAL,INTENT(OUT) :: tmax(npoi)    !! maximum daily temperature (K)
+  REAL,INTENT(OUT) :: tmin(npoi)    !! minimum daily temperature (K)
+  REAL,INTENT(OUT) :: qd(npoi)      !! daily average specific humidity (kg_h2o/kg_air)
+  REAL,INTENT(OUT) :: ud(npoi)      !! daily average wind speed  @tex $(m.s^{-1})$ @endtex
+  REAL,INTENT(OUT) :: precip(npoi)  !! daily precitation @tex $(mm.day^{-1})$ @endtex
+
+  !! 0.4 Local variables
+
+  REAL :: td(npoi)                                 !! daily average temperature (K)
+  REAL,allocatable,save,dimension(:,:) ::  xstore  !! weather generator 'memory' matrix
+  REAL :: ee(3), r(3), rr(npoi,3)
+  REAL :: alpha(npoi), rndnum, pwd, pww
+  REAL :: beta(npoi)
+  REAL :: pwet(npoi)
+  REAL :: rwork
+  REAL :: omcloud, omqd, omtmax
+  REAL :: cloudm, cloudw, cloudd
+  REAL :: cloude(npoi), clouds(npoi)
+  REAL :: tmaxd, tmaxw, tmaxm
+  REAL :: tminm
+  REAL :: tmins(npoi), tmaxs(npoi)
+  REAL :: tmine(npoi), tmaxe(npoi)
+  REAL :: qdm(npoi),qdd(npoi),qde(npoi),qdw(npoi),qdup(npoi),qdlow(npoi)
+  INTEGER :: i,j,k
+  REAL :: amn,b1,b2,b3,eud,rn,rn1,rn2,rn3,rn4,s1,s2,s12,x1,y, z(npoi)
+  REAL :: aa(npoi),ab(npoi),tr1(npoi), tr2(npoi)
+  REAL :: tdm,trngm,tdum
+  REAL :: qsattd(npoi)
+  INTEGER :: it1w, it2w
+  REAL :: dt
+  REAL :: rainpwd(npoi)
+  INTEGER :: not_ok(npoi)
+  INTEGER :: count_not_ok,count_not_ok_g
+  LOGICAL,SAVE :: firstcall = .TRUE.
+  INTEGER,save :: npoi0
+  REAL :: xx
+  REAL, DIMENSION(3,3) :: a,b              !! define autocorrelation matrices for Richardson generator
+                                           !!
+                                           !! note that this matrix should be based upon a statistical
+                                           !! analysis of regional weather patterns
+                                           !!
+                                           !! for global simulations, we use 'nominal' values
+
+  LOGICAL :: Warning_aa_ab(npoi), Warning_iwet(npoi) !! Warnings
+!---------------------------------------------------------------------
+!-
+! initial setup for daily climate calculations
+!-
+  a(1,:) = (/ 0.600,  0.500,  0.005 /)
+  a(2,:) = (/ 0.010,  0.250,  0.005 /)
+  a(3,:) = (/ 0.020,  0.125,  0.250 /)
+!-
+  b(1,:) = (/ 0.500,  0.250, -0.250 /)
+  b(2,:) = (/ 0.000,  0.500,  0.250 /)
+  b(3,:) = (/ 0.000,  0.000,  0.500 /)
+!-
+! GK240100
+  IF (firstcall) THEN
+    firstcall = .FALSE.
+    ALLOC_ERR=-1
+    ALLOCATE(xstore(npoi,3), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of xstore : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    xstore(:,:) = zero
+    npoi0 = npoi
+  ELSE IF (npoi /= npoi0) THEN
+    WRITE(numout,*) 'Domain size old, new: ',npoi0,npoi
+    STOP 'WG Daily: Problem: Domain has changed since last call'
+  ENDIF
+!-
+! define working variables
+!-
+  rwork = (cte_grav/rair/0.0065)
+!-
+! 'omega' parameters used to calculate differences in expected
+! climatic parameters on wet and dry days
+!
+! following logic of weather generator used in the EPIC crop model
+!
+! omcloud -- cloud cover
+! omqd    -- humidity
+! omtmax  -- maximum temperature
+!-
+  omcloud = 0.90    ! originally 0.90
+  omqd    = 0.50    ! originally 0.50
+  omtmax  = 0.75    ! originally 0.75
+!-
+! calculate weighting factors used in interpolating climatological
+! monthly-mean input values to daily-mean values
+!-
+! this is a simple linear interpolation technique that takes into
+! account the length of each month
+!-
+  IF (ipprec == 0) THEN
+    IF (REAL(iday) < REAL(ndaypm(imonth)+1)/2.0) then
+      it1w = imonth-1
+      it2w = imonth
+      dt   = (REAL(iday)-0.5)/ndaypm(imonth)+0.5
+    ELSE
+      it1w = imonth
+      it2w = imonth+1
+      dt   = (REAL(iday)-0.5)/ndaypm(imonth)-0.5
+    ENDIF
+    if (it1w <  1)  it1w = 12
+    if (it2w > 12)  it2w = 1
+  ELSE
+     dt = -1.
+     it1w = -1
+     it2w = -1
+  ENDIF
+!-
+  IF (ipprec == 0) THEN
+!---
+!-- use weather generator to create daily statistics
+!---
+! (1) determine if today will rain or not
+!---
+!-- calculate monthly-average probability of rainy day
+!---
+    DO i=1,npoi
+      pwet(i) = xinwet(i,imonth)/ndaypm(imonth)
+    ENDDO
+!---
+    IF (.NOT.precip_exact) THEN
+!-----
+!---- (1.1) following Geng et al.
+!-----
+      IF (is_root_prc) THEN
+         CALL random_number (rndnum)
+      ENDIF
+      CALL bcast(rndnum)
+!-----
+      DO i=1,npoi
+        IF (xinprec(i,imonth) > 1.e-6) THEN
+!---------
+!-------- implement simple first-order Markov-chain precipitation
+!-------- generator logic based on Geng et al. (1986),
+!-------- Richardson and Wright (1984), and Richardson (1981)
+!---------
+!-------- basically, this allows for the probability of today being
+!-------- a wet day (a day with measureable precipitation)
+!-------- to be a function of what yesterday was (wet or dry)
+!---------
+!-------- the logic here is that it is more likely that a wet day
+!-------- will follow another wet day -- allowing
+!-------- for 'storm events' to persist
+!---------
+!-------- estimate the probability of a wet day after a dry day
+!---------
+          pwd = 0.75*pwet(i)
+!---------
+!-------- estimate the probability of a wet day after a wet day
+!---------
+          pww = 0.25+pwd
+!---------
+!-------- decide if today is a wet day or a dry day
+!-------- using a random number
+!---------
+!-------- call random_number(rndnum) ! done before
+!---------
+          IF (iwet(i) == 0) then
+            IF (rndnum <= pwd) iwet(i) = 1
+          ELSE
+            IF (rndnum > pww) iwet(i) = 0
+          ENDIF
+        ELSE
+          iwet(i) = 0
+        ENDIF
+      ENDDO
+    ELSE
+!-----
+!---- (1.2) preserving the monthly number of precip days
+!----       and monthly precip
+!-----
+      DO i=1,npoi
+        IF (ABS(xinwet(i,imonth)) < 32.) THEN
+          IF (xinprec(i,imonth) > 1.e-6) THEN
+            IF (   jour_precip(iday,imonth) &
+ &              <= NINT(MAX(1.,xinwet(i,imonth))) ) THEN
+              iwet(i) = 1
+            ELSE
+              iwet(i) = 0
+            ENDIF
+          ELSE
+           iwet(i) = 0
+          ENDIF
+        ENDIF
+      ENDDO
+    ENDIF
+!---
+!-- (2) determine today's precipitation amount
+!---
+    IF (.not.precip_exact) THEN
+       Warning_aa_ab(:)=.FALSE.
+       Warning_iwet(:)=.FALSE.
+!-----
+!---- (2.1) following Geng et al.
+!-----
+      aa(:) = zero
+      ab(:) = zero
+      tr2(:)= zero
+      tr1(:)= zero
+      beta(:) = un
+      DO i=1,npoi
+!-------
+!------ initialize daily precipitation to zero
+!-------
+        precip(i) = zero
+!-------
+        IF (xinprec(i,imonth) > 1.e-6) THEN
+!---------
+!-------- if it is going to rain today
+!---------
+          IF (iwet(i) == 1) THEN
+!-----------
+!---------- calculate average rainfall per wet day
+!-----------
+            rainpwd(i) = xinprec(i,imonth) &
+ &                      *ndaypm(imonth)/MAX(0.1,xinwet(i,imonth))
+!-----------
+!---------- randomly select a daily rainfall amount
+!---------- from a probability density function of rainfall
+!----------
+!---------- method i --
+!-----------
+!---------- use the following technique from Geng et al. and Richardson
+!---------- to distribute rainfall probabilities
+!-----------
+!---------- pick a random rainfall amount
+!---------- from a two-parameter gamma function distribution function
+!-----------
+!---------- estimate two parameters for gamma function
+!---------- (following Geng et al.)
+!-----------
+            beta(i) = MAX(1.0,-2.16+1.83*rainpwd(i))
+            alpha(i) = rainpwd(i)/beta(i)
+!-----------
+!---------- determine daily precipitation amount
+!---------- from gamma distribution function
+!---------- (following WGEN code of Richardson and Wright (1984))
+!-----------
+            IF (ABS(1.-alpha(i)) < 1.e-6) THEN
+              alpha(i) = 1.e-6*(alpha(i)/ABS(alpha(i)))
+            ENDIF
+            aa(i) = 1.0/alpha(i)
+            ab(i) = 1.0/(1.0-alpha(i))
+!-----------
+            IF ( (ABS(aa(i)) < 1.e-6) .OR. (ABS(ab(i)) < 1.e-6) ) THEN
+               Warning_aa_ab(:)=.TRUE.
+            ENDIF
+            tr1(i) = exp(-18.42/aa(i))
+            tr2(i) = exp(-18.42/ab(i))
+          ENDIF
+        ELSE
+          IF (iwet(i) == 1) THEN
+            Warning_iwet(i)=.TRUE.
+          ENDIF
+        ENDIF
+      ENDDO
+
+      DO i=1,npoi
+         IF ( Warning_aa_ab(i) ) THEN
+            WRITE(numout,*) ' ATTENTION, aa ou ab:'
+            WRITE(numout,*) ' aa, ab = ',aa(i),ab(i)
+            WRITE(numout,*) '   alpha, rainpwd, beta =', &
+ &                       alpha(i),rainpwd(i),beta(i)
+         ENDIF
+         IF ( Warning_iwet(i) ) THEN
+            WRITE(numout,*) ' ATTENTION, iwet = 1 alors que xinprec = 0)'
+            WRITE(numout,*) '   xinprec, iwet = ',xinprec(i,imonth),iwet(i)
+          ENDIF
+      ENDDO
+!-----
+      where ( iwet(:) == 1 )
+        not_ok(:) = 1
+      elsewhere
+        not_ok(:) = 0
+      endwhere
+!-----
+      count_not_ok_g=0
+      count_not_ok=SUM(not_ok(:))
+      CALL reduce_sum(count_not_ok,count_not_ok_g)
+      CALL bcast(count_not_ok_g)
+!-
+      z(:) = zero
+      DO WHILE (count_not_ok_g > 0)
+        IF (is_root_prc) THEN
+        CALL random_number (rn1)
+        CALL random_number (rn2)
+        ENDIF
+        CALL bcast(rn1)
+        CALL bcast(rn2)
+
+        DO i=1,npoi
+          IF ((iwet(i) == 1).AND.(not_ok(i) == 1)) then
+            IF ( (rn1-tr1(i)) <= zero ) THEN
+              s1 = zero
+            ELSE
+              s1 = rn1**aa(i)
+            ENDIF
+!-----------
+            IF ((rn2-tr2(i)) <= zero) THEN
+              s2 = zero
+            ELSE
+              s2 = rn2**ab(i)
+            ENDIF
+!-----------
+            s12 = s1+s2
+            IF ((s12-1.0) <= zero) THEN
+              z(i) = s1/s12
+              not_ok(i) = 0
+            ENDIF
+          ENDIF
+        ENDDO
+
+        count_not_ok_g=0
+        count_not_ok=SUM(not_ok(:))
+        CALL reduce_sum(count_not_ok,count_not_ok_g)
+        CALL bcast(count_not_ok_g)
+      ENDDO
+!-----
+      IF (is_root_prc) THEN
+         CALL random_number (rn3)
+      ENDIF
+      CALL bcast(rn3)
+!      WRITE(*,*) mpi_rank,"rn3=",rn3
+!-----
+      DO i=1,npoi
+        IF (iwet(i) == 1) then
+          precip(i) = -z(i)*log(rn3)*beta(i)
+        ENDIF
+      ENDDO
+!-----
+!---- method ii --
+!-----
+!---- here we use a one-parameter Weibull distribution function
+!---- following the analysis of Selker and Haith (1990)
+!-----
+!---- Selker, J.S. and D.A. Haith, 1990: Development and testing
+!---- of single- parameter precipitation distributions,
+!---- Water Resources Research, 11, 2733-2740.
+!-----
+!---- this technique seems to have a significant advantage over other
+!---- means of generating rainfall distribution functions
+!-----
+!---- by calibrating the Weibull function to U.S. precipitation records,
+!---- Selker and Haith were able to establish the following relationship
+!-----
+!---- the cumulative probability of rainfall intensity x is given as:
+!-----
+!---- f(x) = 1.0-exp(-(1.191 x / rainpwd)**0.75)
+!-----
+!---- where x       : rainfall intensity
+!----       rainpwd : rainfall per wet day
+!-----
+!---- using transformation method, take uniform deviate and convert
+!---- it to a random number weighted by the following Weibull function
+!-----
+!----    call random_number(rndnum)
+!-----
+!----    precip(i) = rainpwd / 1.191*(-log(1.0-rndnum))**1.333333
+!-----
+!---- bound daily precipitation to "REAListic" range
+!-----
+      DO i=1,npoi
+        IF (iwet(i) == 1) THEN
+!---------
+!-------- lower end is determined by definition of a 'wet day'
+!-------- (at least 0.25 mm of total precipitation)
+!---------
+!-------- upper end is to prevent ibis from blowing up
+!---------
+          precip(i) = MAX(precip(i),  0.25) ! min =   0.25 mm/day
+          precip(i) = MIN(precip(i),150.00) ! max = 150.00 mm/day
+        ENDIF
+      ENDDO
+    ELSE
+!-----
+!---- (2.2) preserving the monthly number of precip days
+!----       and monthly precip
+!-----
+      DO i=1,npoi
+!-------
+!------ Correction Nathalie. C'est abs(xinwet) < 32 qu'il faut tester
+!------ et non pas abs(xinprec(i,imonth)) < 32.
+!-------
+!------ IF ( (iwet(i) == 1).and.(abs(xinprec(i,imonth)) < 32.) ) THEN
+        IF ( (iwet(i) == 1).and.(abs(xinwet(i,imonth)) < 32.) ) THEN
+          precip(i) = xinprec(i,imonth)*REAL(ndaypm(imonth)) &
+ &                   /REAL(NINT(MAX(1.,xinwet(i,imonth))))
+        ELSE
+          precip(i) = zero
+        ENDIF
+      ENDDO
+    ENDIF
+!---
+!-- (3) estimate expected minimum and maximum temperatures
+!---
+    DO i=1,npoi
+!-----
+!---- first determine the expected maximum and minimum temperatures
+!---- (from climatological means) for this day of the year
+!-----
+!---- mean daily mean temperature (K)
+      tdm = xint(i,it1w)+dt*(xint(i,it2w)-xint(i,it1w))+zero_t
+!---- mean daily temperature range (K)
+      trngm = xintrng(i,it1w)+dt*(xintrng(i,it2w)-xintrng(i,it1w))
+!---- mean minimum and maximum temperatures
+      tmaxm = tdm+0.56*trngm
+      tminm = tdm-0.44*trngm
+!-----
+!---- modify maximum temperatures for wet and dry days
+!-----
+      IF (pwet(i) /= zero) THEN
+        tmaxd = tmaxm+pwet(i)*omtmax*trngm
+        tmaxw = tmaxd-        omtmax*trngm
+      ELSE
+        tmaxd = tmaxm
+        tmaxw = tmaxm
+      ENDIF
+!-----
+!---- set the 'expected' maximum and minimum temperatures for today
+!-----
+!---- note that the expected minimum temperatures are the same for
+!---- both wet and dry days
+!-----
+      if (iwet(i) == 0)  tmaxe(i) = tmaxd
+      if (iwet(i) == 1)  tmaxe(i) = tmaxw
+!-----
+      tmine(i) = tminm
+!-----
+!---- estimate variability in minimum and maximum temperatures
+!-----
+!---- tmaxs : standard deviation in maximum temperature (K)
+!---- tmins : standard deviation in minimum temperature (K)
+!-----
+!---- Regression is based on analysis of 2-m air temperature data
+!---- from the NCEP/NCAR reanalysis (1958-1997) for 294 land points
+!---- over central North America
+!---- (24N-52N, 130W-60W, 0.5-degree resolution):
+!---- Daily max and min temperatures were calculated for each
+!---- land point from daily mean temperature and temperature range.
+!---- Anomalies were calculated
+!---- by subtracting similar max and min temperatures calculated from
+!---- monthly mean temperature and range (interpolated to daily).
+!---- The 40 years of anomalies were then binned by month
+!---- and the standard deviation calculated for each month.
+!---- The 294 x 12 standard deviations were then regressed
+!---- against the 3528 long-term monthly mean temperatures.
+!-----
+!---- note: the values are bound to be greater than 1.0 K
+!----       (at the very least they must be bound
+!----        so they don't go below zero)
+!-----
+      tmaxs(i) = MAX(1.0,-0.0713*(tdm-zero_t)+4.89)
+      tmins(i) = MAX(1.0,-0.1280*(tdm-zero_t)+5.73)
+    ENDDO
+!---
+!-- (4) estimate expected cloud cover
+!---
+!---
+!-- the formulation of dry and wet cloud cover has been
+!-- derived from the weather generator used in the epic crop model
+!---
+    DO i=1,npoi
+!-----
+!---- cloudm : mean cloud cover for today
+!---- cloudd : dry day cloud cover
+!---- cloudw : dry day cloud cover
+!---- cloude : expected cloud cover today
+!-----
+!---- mean cloud cover (%)
+!-----
+      cloudm = xincld(i,it1w)+dt*(xincld(i,it2w)-xincld(i,it1w))
+!-----
+!---- convert from percent to fraction
+!-----
+      cloudm = cloudm/100.0
+!-----
+!---- adjust cloud cover depending on dry day / rainy day
+!---- following logic of the EPIC weather generator code
+!-----
+      IF (pwet(i) /= zero) THEN
+        cloudd = (cloudm-pwet(i)*omcloud)/(un-pwet(i)*omcloud)
+        cloudd = MIN(un,MAX(zero,cloudd))
+        cloudw = (cloudm-(un-pwet(i))*cloudd)/pwet(i)
+      ELSE
+        cloudd = cloudm
+        cloudw = cloudm
+      ENDIF
+      IF (iwet(i) == 0)  cloude(i) = cloudd
+      IF (iwet(i) == 1)  cloude(i) = cloudw
+!-----
+!---- estimate variability in cloud cover for wet and dry days
+!---- following numbers proposed by Richardson
+!-----
+!---- clouds : standard deviation of cloud fraction
+!-----
+      IF (iwet(i) == 0)  clouds(i) = 0.24*cloude(i)
+      IF (iwet(i) == 1)  clouds(i) = 0.48*cloude(i)
+    ENDDO
+!---
+! (5) determine today's temperatures and cloud cover using
+!     first-order serial autoregressive technique
+!---
+!-- use the Richardson (1981) weather generator approach to simulate the
+!-- daily values of minimum / maximum temperature and cloud cover
+!---
+!-- following the implementation of the Richardson WGEN weather
+!-- generator used in the EPIC crop model
+!---
+!-- this approach uses a multivariate generator, which assumes that the
+!-- perturbation of minimum / maximum temperature and cloud cover are
+!-- normally distributed and that the serial correlation of each
+!-- variable may be described by a first-order autoregressive model
+!---
+!-- generate standard deviates for weather generator
+!---
+    DO j=1,3
+      ee(j) = 9999.
+      DO WHILE (ee(j) > 2.5)
+        IF (is_root_prc) THEN
+           CALL random_number (rn1)
+           CALL random_number (rn2)
+        ENDIF
+        CALL bcast(rn1)
+        CALL bcast(rn2)
+        ee(j) = SQRT(-2.0*LOG(rn1))*COS(6.283185*rn2)
+      ENDDO
+    ENDDO
+!---
+!-- zero out vectors
+!---
+    r(1:3)  = zero
+    rr(1:npoi,1:3) = zero
+!---
+!-- update working vectors
+!---
+    do j=1,3
+      do k=1,3
+        r(j) = r(j)+b(j,k)*ee(j)
+      enddo
+    enddo
+!---
+    do j=1,3
+      do k=1,3
+        do i=1,npoi
+          rr(i,j) = rr(i,j)+a(j,k)*xstore(i,k)
+        enddo
+      enddo
+    enddo
+!---
+!-- solve for x() perturbation vector and save current vector
+!-- into the xim1() storage vector (saved for each point)
+!---
+    do j=1,3
+      do i=1,npoi
+        xstore(i,j) = r(j)+rr(i,j)
+      enddo
+    enddo
+!---
+!-- determine today's minimum and maximum temperature
+!--
+    do i=1,npoi
+      tmax(i) = tmaxe(i)+tmaxs(i)*xstore(i,1)
+      tmin(i) = tmine(i)+tmins(i)*xstore(i,2)
+!-----
+!---- if tmin > tmax, then switch the two around
+!-----
+      if (tmin(i) > tmax(i)) then
+        tdum    = tmax(i)
+        tmax(i) = tmin(i)
+        tmin(i) = tdum
+      ENDIF
+!---- daily average temperature
+      td(i) = 0.44*tmax(i)+0.56*tmin(i)
+!---- determine today's cloud cover
+      cloud(i) = cloude(i)+clouds(i)*xstore(i,3)
+!---- constrain cloud cover to be between 0 and 100%
+      cloud(i) = MAX(zero,MIN(un,cloud(i)))
+    enddo
+!---
+!-- (6) estimate today's surface atmospheric pressure
+!---
+    do i=1,npoi
+!-----
+!---- simply a function of the daily average temperature
+!---- and topographic height -- nothing fancy here
+!-----
+      psurf(i) = 101325.0*(td(i)/(td(i)+0.0065*xintopo(i)))**rwork
+    enddo
+!---
+!-- (7) estimate today's relative humidity
+!---
+    IF (is_root_prc) THEN
+       CALL random_number (rn)
+    ENDIF
+    CALL bcast(rn)
+!---
+    CALL weathgen_qsat (npoi,td,psurf,qsattd)
+!---
+    do i=1,npoi
+!-----
+!---- the formulation of dry and wet relative humidities has been
+!---- derived from the weather generator used in the epic crop model
+!-----
+!---- qdm : mean relative humidity
+!---- qdd : dry day relative humidity
+!---- qdw : rainy day relative humidity
+!---- qde : expected relative humidity (based on wet/dry decision)
+!-----
+!---- mean relative humidity (%)
+      qdm(i) = xinq(i,it1w)+dt*(xinq(i,it2w)-xinq(i,it1w))
+!---- convert from percent to fraction
+      qdm(i) = qdm(i)/100.0
+!-----
+!---- adjust humidity depending on dry day / rainy day
+!---- following logic of the EPIC weather generator code
+!-----
+      if (pwet(i) /= zero) then
+        qdd(i) = (qdm(i)-pwet(i)*omqd)/(un-pwet(i)*omqd)
+        if (qdd(i) < 0.2) then
+          qdd(i) = 0.2
+          if (qdd(i) > qdm(i)) qdm(i) = qdd(i)
+        ENDIF
+        qdd(i) = MIN(un,qdd(i))
+        qdw(i) = (qdm(i)-(un-pwet(i))*qdd(i))/pwet(i)
+      ELSE
+        qdd(i) = qdm(i)
+        qdw(i) = qdm(i)
+      ENDIF
+!-----
+      if (iwet(i) == 0)  qde(i) = qdd(i)
+      if (iwet(i) == 1)  qde(i) = qdw(i)
+!-----
+!---- estimate lower and upper bounds of humidity distribution function
+!---- following logic of the EPIC weather generator code
+!-----
+      xx = exp(qde(i))
+      qdup(i)  = qde(i)+(un-qde(i))*xx/euler
+      qdlow(i) = qde(i)*(un-1./xx)
+!-----
+!---- randomlly select humidity from triangular distribution function
+!---- following logic of the EPIC weather generator code
+!-----
+!---- call random_number(rn) ! GK done before
+!-----
+      y  = 2.0/(qdup(i)-qdlow(i))
+!-----
+      b3 = qde(i)-qdlow(i)
+      b2 = qdup(i)-qde(i)
+      b1 = rn/y
+!-----
+      x1 = y*b3/2.0
+!-----
+      if (rn > x1) then
+        qd(i) = qdup(i)-sqrt (b2*b2-2.0*b2*(b1-0.5*b3))
+      ELSE
+        qd(i) = qdlow(i)+sqrt (2.0*b1*b3)
+      ENDIF
+!-----
+!---- adjust daily humidity to conserve monthly mean values
+!-----
+!---- note that this adjustment sometimes gives rise to humidity
+!---- values greater than 1.0 -- which is corrected below
+!-----
+      amn = (qdup(i)+qde(i)+qdlow(i))/3.0
+      qd(i) = qd(i)*qde(i)/amn
+!-----
+!---- constrain daily average relative humidity
+!-----
+      qd(i) = MAX(0.30,MIN(qd(i),0.99))
+!-----
+!---- convert from relative humidity to specific humidity at
+!---- daily mean temperature
+!-----
+      qd(i) = qd(i)*qsattd(i)
+    enddo
+!---
+!-- (8) estimate today's daily average wind speed
+!---
+    IF (is_root_prc) THEN
+        CALL random_number (rn4)
+    ENDIF
+    CALL bcast(rn4)
+
+    DO i=1,npoi
+!-----
+!---- first estimate the expected daily average wind speed (from monthly
+!---- means)
+!-----
+      eud = xinwind(i,it1w)+dt*(xinwind(i,it2w)-xinwind(i,it1w))
+!-----
+!---- following logic of the EPIC weather generator
+!---- select random wind speed following this equation
+!-----
+!---- call random_number(rn4)
+!-----
+      ud(i) = 1.13989*eud*(-log(rn4))**0.30
+!---- constrain daily wind speeds to be between 2.5 and 10.0 m/sec
+      ud(i) = MAX(2.5,MIN(ud(i),10.0))
+    ENDDO
+  ELSE
+!---
+!-- use REAL daily climate data
+!---
+    DO i=1,npoi
+!-----
+!---- use basic daily climate data, converting units
+!-----
+!---- daily total precipitation
+      precip(i) = xinprec(i,imonth)
+!---- daily average temperatures
+      td(i) = xint(i,imonth)+zero_t
+      trngm = MIN(44.0,xintrng(i,imonth))
+!-----
+      tmax(i) = td(i)+0.56*trngm
+      tmin(i) = td(i)-0.44*trngm
+!---- daily average cloud cover
+      cloud(i) = xincld(i,imonth)*0.01
+!---- daily average specific humidity
+      qd(i) = xinq(i,imonth)
+!---- daily average wind speed
+      ud(i) = xinwind(i,imonth)
+!-----
+!---- compute surface atmospheric pressure
+!-----
+      psurf(i) = 101325.0*(td(i)/(td(i)+0.0065*xintopo(i)))**rwork
+    ENDDO
+  ENDIF
+!-------------------
+END SUBROUTINE daily
+!-
+!===
+!-
+
+!! ================================================================================================================================
+!! SUBROUTINE   : diurnal
+!!
+!>\BRIEF          This routine interpolates values from the!* 
+!! subroutine daily into instantaneous values for simulating a diurnal cycle.
+!!
+!! DESCRIPTION  :  
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):  ::fira, ::solad, ::ua, ::ta, ::qa, ::raina, ::snowa, ::rh.
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE diurnal &
+& (npoi, nband, time, jday, plens, startp, endp, latitude, &
+&  cloud, tmax, tmin, precip, qd, ud, psurf, &
+&  fira, solad, solai, ua, ta, qa, raina, snowa, rh)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+
+  !! 0. Parameter and variables declaration
+
+  !! 0.1 Input variables
+
+  INTEGER,INTENT(IN) :: npoi    !! number of grid points (unitless)
+  INTEGER,INTENT(IN) :: nband   !! number of visible bands (unitless)
+  REAL,INTENT(IN) :: time
+  INTEGER, INTENT(IN) :: jday
+  REAL,INTENT(IN) :: plens,startp,endp
+  REAL,INTENT(IN) :: latitude(npoi)   !! latitude in degrees
+  REAL,INTENT(IN) :: cloud(npoi)      !! cloud fraction (0-1, unitless)
+  REAL,INTENT(IN) :: tmax(npoi)       !! maximum daily temperature (K)
+  REAL,INTENT(IN) :: tmin(npoi)       !! maximum daily temperature (K)
+  REAL,INTENT(IN) :: precip(npoi)     !! daily precitation @tex $(mm.day^{-1})$ @endtex 
+  REAL,INTENT(IN) :: qd(npoi)         !! daily average specific humidity (kg_h2o/kg_air)
+  REAL,INTENT(IN) :: ud(npoi)         !! daily average wind speed @tex $(m.s^{-1})$ @endtex 
+  REAL,INTENT(IN) :: psurf(npoi)      !! surface pressure (Pa)
+
+  !! 0.2 Output variables
+
+  REAL,INTENT(OUT) :: fira(npoi)          !! incoming ir flux  @tex $(W.m^{-2})$ @endtex
+  REAL,INTENT(OUT) :: solad(npoi,nband)   !! direct downward solar flux @tex $(W.m^{-2})$ @endtex
+  REAL,INTENT(OUT) :: solai(npoi,nband)   !! diffuse downward solar flux @tex $(W.m^{-2})$ @endtex
+  REAL,INTENT(OUT) :: ua(npoi)            !! wind speed @tex $(m.s^{-1})$ @endtex 
+  REAL,INTENT(OUT) :: ta(npoi)            !! air temperature (K)
+  REAL,INTENT(OUT) :: qa(npoi)            !! specific humidity (kg_h2o/kg_air)
+  REAL,INTENT(OUT) :: raina(npoi)         !! rainfall rate @tex $(mm.day^{-1})$ @endtex 
+  REAL,INTENT(OUT) :: snowa(npoi)         !! snowfall rate @tex $(mm.day^{-1})$ @endtex 
+  REAL,INTENT(OUT) :: rh(npoi)            !! relative humidity (0-1, unitless)
+
+  !! 0.4 Local variables
+
+  REAL,SAVE      :: step
+  REAL :: xl,so,xllp,xee,xse
+  REAL :: xlam,dlamm,anm,ranm,ranv,anv,tls,rlam
+  REAL :: sd,cd,deltar,delta,Dis_ST,ddt
+!-
+  REAL :: coszen(npoi)                      !! cosine of solar zenith angle
+  REAL :: rtime
+  REAL :: sw,frac,gamma,qmin,qmax,qsa,emb,ea,ec,dtair,dtcloud,rn
+  REAL :: trans(npoi), fdiffuse(npoi), qsatta(npoi), qsattmin(npoi)
+  INTEGER :: i,ib
+  INTEGER,SAVE :: npoi0
+  LOGICAL,SAVE :: firstcall = .TRUE.
+
+!---------------------------------------------------------------------
+! GK240100
+  IF (firstcall) THEN
+    firstcall = .FALSE.
+    npoi0 = npoi
+  ELSE IF (npoi /= npoi0) THEN
+    WRITE(numout,*) 'Domain size old, new: ',npoi0,npoi
+    STOP 'WG Diurnal: Problem: Domain has changed since last call'
+  ENDIF
+
+! calculate time in hours
+  rtime = time/3600.0
+
+  CALL downward_solar_flux(npoi,latitude,calendar_str,REAL(jday),rtime,cloud,nband,solad,solai)
+!-
+! temperature calculations
+!-
+!---
+!-- assign hourly temperatures using tmax and tmin
+!-- following Environmental Biophysics, by Campbell and Norman, p.23
+!---
+!-- this function fits a fourier series to the diurnal temperature cycle
+!-- note that the maximum temperature occurs at 2:00 pm local solar time
+!---
+!-- note that the daily mean value of gamma is 0.44,
+!-- so td = 0.44*tmax+0.56*tmin,  instead of
+!--    td = 0.50*tmax+0.50*tmin
+!---
+  gamma = 0.44-0.46*SIN(    pi/12.0*rtime+0.9) &
+              +0.11*SIN(2.0*pi/12.0*rtime+0.9)
+  DO i=1,npoi
+    ta(i) = tmax(i)*gamma+tmin(i)*(1.0-gamma)
+  ENDDO
+!-
+! humidity calculations
+!-
+  CALL weathgen_qsat (npoi,tmin,psurf,qsattmin)
+  CALL weathgen_qsat (npoi,ta,psurf,qsatta)
+!-
+  DO i=1,npoi
+!---
+!-- adjust specific humidity against daily minimum temperatures
+!---
+!-- To do this, qa is written as an approximate sine function
+!-- (same as ta) to preserve the daily mean specific humidity,
+!-- while also preventing rh from exceeding 99% at night
+!---
+!-- Note that the daily mean RH is *not* preserved, and therefore the
+!-- output RH will be slightly different from what was read in.
+!---
+!-- first adjust so that maximum RH cannot exceed 99% at night
+!---
+    qmin = MIN(qd(i),0.99*qsattmin(i))
+    qmax = (qd(i)-0.56*qmin)/0.44
+!---
+!-- if needed, adjust again to 99% at other times of the day (in which
+!-- case the daily mean *specific* humidity is also not preserved)
+!---
+    qsa  = 0.99*qsatta(i)
+!---
+!-- calculate the hourly specific humidity, using the above adjustments
+!---
+    qa(i) = MIN(qsa,qmax*gamma+qmin*(1.0-gamma))
+!---
+!-- calculate the hourly relative humidity
+!--
+    rh(i) = 100.*qa(i)/qsatta(i)
+  ENDDO
+!-
+! wind speed calculations
+!-
+  IF (is_root_prc) THEN
+     CALL random_number (rn)
+  ENDIF
+  CALL bcast(rn)
+!-
+  DO i=1,npoi
+!---
+!-- following logic of the EPIC weather generator
+!-- select random wind speed following this equation
+!---
+!-- call random_number(rn) ! done before
+!---
+    ua(i) = 1.13989*ud(i)*(-log(rn))**0.30
+!---
+!-- fix wind speeds to always be above 2.5 m/sec and below 10.0 m/sec
+!---
+    ua(i) = MAX(2.5,MIN(10.0,ua(i)))
+  ENDDO
+!-
+! ir flux calculations
+!-
+  DO i=1,npoi
+!---
+!-- clear-sky emissivity as a function of water vapor pressure
+!-- and atmospheric temperature
+!---
+!-- calculate the ir emissivity of the clear sky
+!-- using equation from idso (1981) water resources res., 17, 295-304
+!---
+    emb = 0.01*(psurf(i)*qa(i)/(0.622+qa(i)))
+    ea  = 0.70+5.95e-5*emb*EXP(1500.0/ta(i))
+!---
+!-- assign the ir emissivity of clouds
+!-- (assume they are ~black in the ir)
+!---
+    ec = 0.950
+!---
+!-- assign the temperature difference of emissions (air+cloud) from
+!-- the surface air temperature
+!---
+    dtair   = zero
+    dtcloud = zero
+!---
+!-- total downward ir is equal to the sum of:
+!---
+!-- (1) clear sky contribution to downward ir radiation flux
+!-- (2) cloud contribution to downward ir radiation flux
+!---
+    fira(i) = (1.-cloud(i))*ea*c_stefan*(ta(i)-dtair)**4 &
+ &           +cloud(i)*ec*c_stefan*(ta(i)-dtcloud)**4
+  ENDDO
+!-
+! snow and rain calculations
+!-
+  DO i=1,npoi
+!---
+!-- reset snow and rain to zero
+!---
+    snowa(i) = zero
+    raina(i) = zero
+!---
+!-- if precipitation event then calculate
+!---
+    IF (time >= startp .and. time < endp) then
+!-----
+!---- for rain / snow partitioning, make it all rain if
+!---- ta > 2.5 C and all snow if ta <= 2.5 C
+!-----
+!---- reference:
+!-----
+!---- Auer, A. H., 1974: The rain versus snow threshold temperatures,
+!---- Weatherwise, 27, 67.
+!-----
+      IF (ta(i)-273.15 > 2.5) then
+        raina(i) = precip(i)/plens
+      ELSE
+        snowa(i) = precip(i)/plens
+      ENDIF
+    ENDIF
+  ENDDO
+!---------------------
+END SUBROUTINE diurnal
+!-
+!===
+!-
+
+!! ================================================================================================================================
+!! SUBROUTINE   : weathgen_main
+!!
+!>\BRIEF        This subroutine manages the calls to the different subroutines of the weather module. 
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::tair, ::pb, ::qair, ::swdown, ::rainf, ::snowf, ::u, ::v, ::lwdown
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE weathgen_main &
+& (itau, istp, filename, force_id, iim, jjm, nband, &
+&  rest_id, lrstread, lrstwrite, &
+&  limit_west, limit_east, limit_north, limit_south, &
+&  zonal_res, merid_res, lon, lat, date0, dt_force, &
+&  kindex, nbindex, &
+&  swdown, rainf, snowf, tair, u, v, qair, pb, lwdown)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+
+  !! 0. Variables and parameters declaration
+
+  !! 0.1 Input variables
+
+  INTEGER,INTENT(IN)                  :: itau,istp
+  CHARACTER(LEN=*),INTENT(IN)         :: filename
+  INTEGER,INTENT(IN)                  :: force_id
+  INTEGER,INTENT(IN)                  :: iim,jjm
+  INTEGER,INTENT(IN)                  :: nband
+  INTEGER,INTENT(IN)                  :: rest_id
+  LOGICAL,INTENT(IN)                  :: lrstread, lrstwrite
+  REAL,INTENT(IN)                     :: limit_west,limit_east
+  REAL,INTENT(IN)                     :: limit_north,limit_south
+  REAL,INTENT(IN)                     :: zonal_res,merid_res
+  REAL,INTENT(IN)                     :: date0,dt_force
+  REAL,DIMENSION(iim,jjm),INTENT(IN)  :: lon,lat  !! longitude, latitude
+
+  !! 0.2 Output variables 
+
+  REAL,DIMENSION(iim,jjm),INTENT(OUT) :: &
+ &  tair,pb,qair,swdown,rainf,snowf, u,v,lwdown
+
+  !! 0.3 Mofified variables
+
+  INTEGER,INTENT(INOUT)                    :: nbindex
+  INTEGER,DIMENSION(iim*jjm),INTENT(INOUT) :: kindex
+
+  !! 0.4 Local variables
+
+  REAL, ALLOCATABLE, DIMENSION(:,:) :: &
+ &  tair_g,pb_g,qair_g,swdown_g,rainf_g,snowf_g, u_g,v_g,lwdown_g
+  REAL,DIMENSION(nbindex) :: &
+ &  tairl,pbl,qairl,swdownl,rainfl,snowfl, ul,vl,lwdownl
+  INTEGER :: i,j,ij
+!---------------------------------------------------------------------
+  IF (lrstread) THEN
+    CALL weathgen_begin ( &
+     & dt_force,itau, date0, &
+     & rest_id,iim,jjm, &
+     & lon,lat,tair,pb,qair,kindex,nbindex)
+        RETURN
+  ELSE
+    CALL weathgen_get &
+ &   (itau, date0, dt_force, nbindex, nband, lat_land, &
+ &    swdownl, rainfl, snowfl, tairl, ul, vl, qairl, pbl, lwdownl)
+
+    tair(:,:)=val_exp
+    qair(:,:)=val_exp
+    pb(:,:)=val_exp
+    DO ij=1,nbindex
+       j = (((kindex(ij)-1)/iim) + 1)
+       i = (kindex(ij) - (j-1)*iim)
+       !
+       swdown(i,j)=swdownl(ij)
+       rainf(i,j)=rainfl(ij)
+       snowf(i,j)=snowfl(ij)
+       tair(i,j)=tairl(ij)
+       u(i,j)=ul(ij)
+       v(i,j)=vl(ij)
+       qair(i,j)=qairl(ij)
+       pb(i,j)=pbl(ij)
+       lwdown(i,j)=lwdownl(ij)
+    ENDDO
+!---
+    IF (dump_weather) THEN
+      ALLOCATE(tair_g(iim_g,jjm_g))
+      ALLOCATE(pb_g(iim_g,jjm_g))
+      ALLOCATE(qair_g(iim_g,jjm_g))
+      ALLOCATE(swdown_g(iim_g,jjm_g))
+      ALLOCATE(rainf_g(iim_g,jjm_g))
+      ALLOCATE(snowf_g(iim_g,jjm_g))
+      ALLOCATE(u_g(iim_g,jjm_g))
+      ALLOCATE(v_g(iim_g,jjm_g))
+      ALLOCATE(lwdown_g(iim_g,jjm_g))
+
+      CALL gather2D_mpi(tair, tair_g)
+      CALL gather2D_mpi(pb, pb_g)
+      CALL gather2D_mpi(qair, qair_g)
+      CALL gather2D_mpi(swdown, swdown_g)
+      CALL gather2D_mpi(rainf, rainf_g)
+      CALL gather2D_mpi(snowf, snowf_g)
+      CALL gather2D_mpi(u, u_g)
+      CALL gather2D_mpi(v, v_g)
+      CALL gather2D_mpi(lwdown, lwdown_g)
+      IF (is_root_prc) THEN
+         CALL weathgen_dump &
+ &           (itau, dt_force, iim_g, jjm_g, nbp_glo, index_g, lrstwrite, &
+ &            swdown_g, rainf_g, snowf_g, tair_g, u_g, v_g, qair_g, pb_g, lwdown_g)
+      ENDIF
+    ENDIF
+!---
+    IF (lrstwrite) THEN
+      CALL weathgen_restwrite (rest_id,istp,iim,jjm,nbindex,kindex)
+    ENDIF
+  ENDIF
+!---------------------------
+END SUBROUTINE weathgen_main
+!-
+!===
+!-
+
+!! ================================================================================================================================
+!! SUBROUTINE   : weathgen_init 
+!!
+!>\BRIEF         This subroutine initializes weather variables.
+!!
+!! DESCRIPTION  : None 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):  ::kindex, ::nbindex
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE weathgen_init &
+     & (filename,dt_force,force_id,iim,jjm, &
+     &  zonal_res,merid_res,lon,lat,kindex,nbindex)
+!!$,iind,jind)
+  !---------------------------------------------------------------------
+  IMPLICIT NONE
+  !-
+
+  !! 0. Variables and parameters declaration
+
+  REAL,PARAMETER  :: fcrit = .5       !! Minimum land fraction on original grid
+
+  !! 0.1 Input variables
+
+  CHARACTER(LEN=*),INTENT(IN)         :: filename
+  REAL,INTENT(IN)                     :: dt_force
+  INTEGER,INTENT(IN)                  :: iim, jjm
+  REAL,INTENT(IN)                     :: zonal_res,merid_res
+  REAL,DIMENSION(iim,jjm),INTENT(IN)  :: lon,lat
+
+  !! 0.2 Output variables  
+
+  INTEGER,INTENT(OUT)                 :: nbindex
+  INTEGER,DIMENSION(iim*jjm),INTENT(OUT)  :: kindex
+!!$  INTEGER,DIMENSION(iim),INTENT(OUT) :: iind
+!!$  INTEGER,DIMENSION(jjm),INTENT(OUT) :: jind
+
+  !! 0.3 Modified variables 
+
+  INTEGER,INTENT(INOUT)               :: force_id
+
+  !! 0.4 Local variables
+
+  REAL,DIMENSION(:),ALLOCATABLE         :: lon_file, lon_temp
+  REAL,DIMENSION(:,:),ALLOCATABLE       :: nav_lon, nav_lat
+  REAL,DIMENSION(:),ALLOCATABLE         :: lat_file, lat_temp
+  REAL,DIMENSION(:,:),ALLOCATABLE       :: lsm_file
+  REAL     :: xextent_file, yextent_file, xres_file, yres_file
+  INTEGER  :: i, j, plotstep
+  REAL,DIMENSION(iim,jjm)               :: mask
+  CHARACTER(LEN=1),DIMENSION(0:1)       :: maskchar
+  CHARACTER(LEN=30)                     :: var_name
+  REAL     :: x_cut
+  REAL,DIMENSION(iim) :: tmp_lon
+  REAL,DIMENSION(jjm) :: tmp_lat
+
+!_ ================================================================================================================================
+
+  !-
+  ! 0. messages, initialisations
+  !-
+  WRITE(numout,*) &
+       &  'weathgen_init: Minimum land fraction on original grid =',fcrit
+  CALL ioget_calendar(calendar_str)
+  !-
+  ! 1. on lit les longitudes et latitudes de la grille de depart
+  !    ainsi que le masque terre-ocean
+  !-
+  CALL flinclo(force_id)
+  CALL flininfo (filename,iim_file,jjm_file,llm_file,ttm_file,force_id)
+  !-
+  ALLOC_ERR=-1
+  ALLOCATE(nav_lon(iim_file,jjm_file), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+     WRITE(numout,*) "ERROR IN ALLOCATION of nav_lon : ",ALLOC_ERR
+     STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(nav_lat(iim_file,jjm_file), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+     WRITE(numout,*) "ERROR IN ALLOCATION of nav_lat : ",ALLOC_ERR
+     STOP 
+  ENDIF
+  !-
+  var_name='nav_lon'
+  CALL flinget (force_id,var_name,iim_file,jjm_file,0,0,1,1,nav_lon)
+  var_name='nav_lat'
+  CALL flinget (force_id,var_name,iim_file,jjm_file,0,0,1,1,nav_lat)
+  !-
+
+  ALLOC_ERR=-1
+  ALLOCATE(lon_file(iim_file), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+     WRITE(numout,*) "ERROR IN ALLOCATION of lon_file : ",ALLOC_ERR
+     STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(lat_file(jjm_file), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+     WRITE(numout,*) "ERROR IN ALLOCATION of lat_file : ",ALLOC_ERR
+     STOP 
+  ENDIF
+  !-
+  DO i=1,iim_file
+     lon_file(i) = nav_lon(i,1)
+  ENDDO
+  DO j=1,jjm_file
+     lat_file(j) = nav_lat(1,j)
+  ENDDO
+!-
+
+  ALLOC_ERR=-1
+  ALLOCATE(lsm_file(iim_file,jjm_file), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of lsm_file : ",ALLOC_ERR
+    STOP 
+  ENDIF
+!-
+  var_name='lsmera'
+  CALL flinget (force_id,var_name,iim_file,jjm_file,0,0,1,1,lsm_file)
+!-
+! 2. La resolution du modele ne doit pas etre superieure
+!    a celle de la grille de depart
+!-
+  xextent_file = lon_file(iim_file)-lon_file(1)
+  yextent_file = lat_file(1)-lat_file(jjm_file)
+  xres_file = xextent_file/REAL(iim_file-1)
+  yres_file = yextent_file/REAL(jjm_file-1)
+!-
+  IF (xres_file > zonal_res) THEN
+    WRITE(numout,*) 'Zonal resolution of model grid too fine.'
+    WRITE(numout,*) 'Resolution of original data (deg): ', xres_file
+    STOP
+  ENDIF
+!-
+  IF (yres_file > merid_res) THEN
+    WRITE(numout,*) 'Meridional resolution of model grid too fine.'
+    WRITE(numout,*) 'Resolution of original data (deg): ', yres_file
+    STOP
+  ENDIF
+!-
+! 3. On verifie la coherence des coordonnees de depart et d'arrivee.
+!    Sinon, il faut deplacer une partie du monde (rien que ca).
+!-
+  i_cut = 0
+!-
+
+  ALLOC_ERR=-1
+  ALLOCATE(lon_temp(iim_file), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of lon_temp : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(lat_temp(jjm_file), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of lat_temp : ",ALLOC_ERR
+    STOP 
+  ENDIF
+!-
+  IF (lon(iim,1) > lon_file(iim_file)) THEN
+!-- A l'Est de la region d'interet, il n'y a pas de donnees
+!-- le bout a l'Ouest de la region d'interet est deplace de 360 deg
+!-- vers l'Est
+    x_cut = lon(1,1)
+    DO i=1,iim_file
+      IF (lon_file(i) < x_cut) i_cut = i
+    ENDDO
+    IF ((i_cut < 1).OR.(i_cut >= iim_file)) THEN
+        STOP 'Cannot find longitude for domain shift'
+    ENDIF
+!---
+    lon_temp(1:iim_file-i_cut-1) = lon_file(i_cut:iim_file)
+    lon_temp(iim_file-i_cut:iim_file) = lon_file(1:i_cut+1)+360.
+    lon_file(:) = lon_temp(:)
+  ELSEIF (lon(1,1) < lon_file(1)) THEN
+!-- A l'Ouest de la region d'interet, il n'y a pas de donnees
+!-- le bout a l'Est de la region d'interet est deplace de 360 deg
+!-- vers l'Ouest
+    x_cut = lon(iim,1)
+    DO i=1,iim_file
+      IF (lon_file(i) < x_cut) i_cut = i
+    ENDDO
+    IF ( ( i_cut < 1 ) .OR. ( i_cut >= iim_file ) ) THEN
+        STOP 'Cannot find longitude for domain shift'
+    ENDIF
+!---
+    lon_temp(1:iim_file-i_cut-1) = lon_file(i_cut:iim_file) -360.
+    lon_temp(iim_file-i_cut:iim_file) = lon_file(1:i_cut+1)
+    lon_file(:) = lon_temp(:)
+  ENDIF
+!-
+  DEALLOCATE (lon_temp)
+  DEALLOCATE (lat_temp)
+!-
+  IF (    (lon(1,1) < lon_file(1)) &
+ &    .OR.(     (lon(iim,1) > lon_file(iim_file)) &
+ &         .AND.(lon(iim,1) > lon_file(1)+360.) ) ) THEN
+    WRITE(numout,*) lon(:,1)
+    WRITE(numout,*)
+    WRITE(numout,*) lon_file(:)
+    STOP 'weathgen_init: cannot find coherent x-coordinates'
+  ENDIF
+!-
+  IF (i_cut /= 0) THEN
+    CALL shift_field (iim_file,jjm_file,i_cut,lsm_file)
+  ENDIF
+!-
+! 4. Verification
+!-
+  WRITE(numout,*)
+  WRITE(numout,*) 'Input File: (Shifted) Global Land-Sea Mask'
+  WRITE(numout,*)
+  maskchar(0) = '-'
+  maskchar(1) = 'X'
+  plotstep = INT(REAL(iim_file-1)/termcol)+1
+  DO j=1,jjm_file,plotstep
+    DO i=1,iim_file,plotstep
+      WRITE(numout,'(a1)',ADVANCE='NO') maskchar(NINT(lsm_file(i,j)))
+    ENDDO
+    WRITE(numout,*)
+  ENDDO
+  WRITE(numout,*)
+!-
+! 5. Prepare interpolation from fine grid land points to model grid
+!-
+! 5.1 how many grid points of the original grid fall into one grid
+!     box of the model grid?
+!-
+  n_agg = NINT((zonal_res/xres_file*merid_res/yres_file )+1.)
+!-
+! au diable l'avarice !
+!-
+  n_agg = n_agg*2
+!-
+! 5.2 Allocate arrays where we store information about which
+!     (and how many) points on the original grid fall
+!     into which box on the model grid
+!-
+
+  ALLOC_ERR=-1
+  ALLOCATE(ncorr(iim,jjm), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of ncorr : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(icorr(iim,jjm,n_agg), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of icorr : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(jcorr(iim,jjm,n_agg), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of jcorr : ",ALLOC_ERR
+    STOP 
+  ENDIF
+!-
+! 6. Land-Ocean Mask on model grid
+!-
+  tmp_lon = lon(:,1)
+  tmp_lat = lat(1,:)
+
+  CALL mask_c_o &
+ &  (iim_file, jjm_file, lon_file, lat_file, lsm_file, fcrit, &
+ &   iim, jjm, zonal_res, merid_res, n_agg, tmp_lon, tmp_lat, &
+! &   iim, jjm, zonal_res, merid_res, n_agg, lon(:,1), lat(1,:), &
+ &   mask, ncorr, icorr, jcorr)
+!-
+  WRITE(numout,*) 'Land-Sea Mask on Model Grid'
+  WRITE(numout,*)
+  plotstep = INT(REAL(iim-1)/termcol)+1
+  DO j=1,jjm,plotstep
+    DO i=1,iim,plotstep
+      WRITE(numout,'(a1)',ADVANCE='NO') maskchar(NINT(mask(i,j)))
+!      WRITE(numout,'(a1,$)') maskchar(NINT(mask(i,j)))
+    ENDDO
+    WRITE(numout,*)
+  ENDDO
+  WRITE(numout,*)
+!-
+! 7. kindex table.
+!-
+  nbindex = 0
+  DO j=1,jjm
+    DO i=1,iim
+      IF (NINT(mask(i,j)) == 1) THEN
+        nbindex = nbindex+1
+        kindex(nbindex) = (j-1)*iim+i
+      ENDIF
+    ENDDO
+  ENDDO
+  nbindex_w = nbindex
+  ALLOC_ERR=-1
+  ALLOCATE(kindex_w(nbindex_w), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of kindex_w : ",ALLOC_ERR
+    STOP 
+  ENDIF
+  kindex_w(:)=kindex(1:nbindex)
+!-
+  IF ( nbindex == 0 ) THEN
+    WRITE(numout,*) 'Sorry, you are in the middle of the ocean. Check your coordinates.'
+    STOP 
+  ELSE
+    WRITE(numout,*) 'Number of continental points: ',nbindex
+  ENDIF
+
+!-
+! 10. clean up
+!-
+  DEALLOCATE (lon_file)
+  DEALLOCATE (lat_file)
+  DEALLOCATE (lsm_file)
+
+END SUBROUTINE weathgen_init
+
+!! ================================================================================================================================
+!! SUBROUTINE   : weathgen_read_file
+!!
+!>\BRIEF         This subroutine allocates variables and reads files.  
+!!
+!! DESCRIPTION  :  
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE weathgen_read_file &
+     & (force_id,iim,jjm)
+  !---------------------------------------------------------------------
+  IMPLICIT NONE
+  !-
+
+  !! 0. Variables and parameters declaration
+
+  REAL,PARAMETER  :: fcrit = .5
+
+  !! 0.1 Input variables 
+
+  INTEGER,INTENT(IN)                  :: force_id
+  INTEGER,INTENT(IN)                  :: iim, jjm
+
+  !! 0.4 Local variables
+
+  CHARACTER(LEN=30)               :: var_name
+
+  INTEGER,DIMENSION(iim*jjm)  :: kindex
+  INTEGER                     :: nbindex
+
+  REAL,DIMENSION(iim*jjm)     :: xchamp
+  REAL,DIMENSION(iim*jjm,nmon)  :: xchampm
+
+!_ ================================================================================================================================
+
+  kindex(:)=0
+
+#ifdef CPP_PARA
+  nbindex=nbp_loc
+  CALL scatter(index_g,kindex)
+  kindex(1:nbindex)=kindex(1:nbindex)-(jj_begin-1)*iim_g
+#else
+  ! Copy saved land points index
+  nbindex = nbindex_w
+  kindex(1:nbindex_w) = kindex_w(:)
+#endif
+
+!-
+
+  ALLOC_ERR=-1
+  ALLOCATE(lat_land(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of lat_land : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+!-
+! 8 topography
+!-
+
+  ALLOC_ERR=-1
+  ALLOCATE(xintopo(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of xintopo : ",ALLOC_ERR
+    STOP 
+  ENDIF
+!-
+  var_name='altitude'
+  CALL weather_read (force_id,var_name,iim_file,jjm_file,1,i_cut, &
+                     iim,jjm,n_agg,ncorr,icorr,jcorr,xchamp)
+  xintopo(:)=xchamp(kindex(1:nbindex))
+!-
+! 9. Allocate and read the monthly fields
+!-
+
+  ALLOC_ERR=-1
+  ALLOCATE(xinwet(nbindex,nmon), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of xinwet : ",ALLOC_ERR
+    STOP 
+  ENDIF
+  var_name='prs'
+  CALL weather_read (force_id,var_name,iim_file,jjm_file,nmon,i_cut, &
+                     iim,jjm,n_agg,ncorr,icorr,jcorr,xchampm)
+  xinwet(:,:)=xchampm(kindex(1:nbindex),:)
+  !-
+
+  ALLOC_ERR=-1
+  ALLOCATE(xinprec(nbindex,nmon), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of xinprec : ",ALLOC_ERR
+    STOP 
+  ENDIF
+  var_name='prm'
+  CALL weather_read (force_id,var_name,iim_file,jjm_file,nmon,i_cut, &
+                     iim,jjm,n_agg,ncorr,icorr,jcorr,xchampm)
+  xinprec(:,:)=xchampm(kindex(1:nbindex),:)
+!-
+  
+  ALLOC_ERR=-1
+  ALLOCATE(xint(nbindex,nmon), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of xint : ",ALLOC_ERR
+    STOP 
+  ENDIF
+  var_name='t2m'
+  CALL weather_read (force_id,var_name,iim_file,jjm_file,nmon,i_cut, &
+                     iim,jjm,n_agg,ncorr,icorr,jcorr,xchampm)
+  xint(:,:)=xchampm(kindex(1:nbindex),:)
+!-
+
+  ALLOC_ERR=-1
+  ALLOCATE(xinq(nbindex,nmon), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of xinq : ",ALLOC_ERR
+    STOP 
+  ENDIF
+  var_name='r2m'
+  CALL weather_read (force_id,var_name,iim_file,jjm_file,nmon,i_cut, &
+                     iim,jjm,n_agg,ncorr,icorr,jcorr,xchampm)
+  xinq(:,:)=xchampm(kindex(1:nbindex),:)
+!-
+
+  ALLOC_ERR=-1
+  ALLOCATE(xinwind(nbindex,nmon), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of xinwind : ",ALLOC_ERR
+    STOP 
+  ENDIF
+  var_name='uv10m'
+  CALL weather_read (force_id,var_name,iim_file,jjm_file,nmon,i_cut, &
+                     iim,jjm,n_agg,ncorr,icorr,jcorr,xchampm)
+  xinwind(:,:)=xchampm(kindex(1:nbindex),:)
+!-
+
+  ALLOC_ERR=-1
+  ALLOCATE(xincld(nbindex,nmon), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of xincld : ",ALLOC_ERR
+    STOP 
+  ENDIF
+  var_name='tc'
+  CALL weather_read (force_id,var_name,iim_file,jjm_file,nmon,i_cut, &
+                       iim,jjm,n_agg,ncorr,icorr,jcorr,xchampm)
+  xincld(:,:)=xchampm(kindex(1:nbindex),:)
+!-
+
+  ALLOC_ERR=-1
+  ALLOCATE(xintrng(nbindex,nmon), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of xintrng : ",ALLOC_ERR
+    STOP 
+  ENDIF
+  var_name='t2a'
+  CALL weather_read (force_id,var_name,iim_file,jjm_file,nmon,i_cut, &
+                       iim,jjm,n_agg,ncorr,icorr,jcorr,xchampm)
+  xintrng(:,:)=xchampm(kindex(1:nbindex),:)
+!-
+! 10. clean up
+!-
+  IF (is_root_prc) THEN
+     DEALLOCATE (ncorr)
+     DEALLOCATE (icorr)
+     DEALLOCATE (jcorr)
+  ENDIF
+
+!-
+! 12. Allocate space for daily mean values
+!-
+
+  ALLOC_ERR=-1
+  ALLOCATE(iwet(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of iwet : ",ALLOC_ERR
+    STOP 
+  ENDIF
+!-
+
+  ALLOC_ERR=-1
+  ALLOCATE(psurfm0(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of psurfm0 : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(cloudm0(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of cloudm0 : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(tmaxm0(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of tmaxm0 : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(tminm0(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of tminm0 : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(qdm0(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of qdm0 : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(udm0(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of udm0 : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(precipm0(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of precipm0 : ",ALLOC_ERR
+    STOP 
+  ENDIF
+!-
+
+  ALLOC_ERR=-1
+  ALLOCATE(psurfm1(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of psurfm1 : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(cloudm1(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of cloudm1 : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(tmaxm1(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of tmaxm1 : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(tminm1(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of tminm1 : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(qdm1(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of qdm1 : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(udm1(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of udm1 : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(precipm1(nbindex), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of precipm1 : ",ALLOC_ERR
+    STOP 
+  ENDIF
+END SUBROUTINE weathgen_read_file
+!
+!=
+!
+
+!! ================================================================================================================================
+!! SUBROUTINE   : weathgen_begin
+!!
+!>\BRIEF         This subroutines initializes variables or reads restart values. 
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::nbindex, ::tair, ::pb, ::qair, ::kindex
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE weathgen_begin ( &
+     & dt_force,itau, date0, &
+     & rest_id,iim,jjm, &
+     & lon,lat,tair,pb,qair,kindex,nbindex)
+  !---------------------------------------------------------------------
+  IMPLICIT NONE
+
+  !-
+
+  !! 0. Variables and parameters declaration
+
+  !! 0.1 Input variables
+
+  REAL,INTENT(IN)                     :: dt_force, date0
+  INTEGER,INTENT(IN)                  :: itau
+  INTEGER,INTENT(IN)                  :: rest_id
+  INTEGER,INTENT(IN)                  :: iim, jjm
+  REAL,DIMENSION(iim,jjm),INTENT(IN)  :: lon,lat
+
+  !! 0.2 Output variables 
+
+  INTEGER,INTENT(OUT)                     :: nbindex
+  INTEGER,DIMENSION(iim*jjm),INTENT(OUT)  :: kindex
+  REAL,DIMENSION(iim,jjm),INTENT(OUT)     :: tair,pb,qair
+
+  !! 0.4 Local variables
+
+  INTEGER  :: i, j, ij
+  REAL     :: val_exp
+  REAL,DIMENSION(iim*jjm)               :: xchamp
+  REAL,DIMENSION(iim_g*jjm_g)           :: xchamp_g
+  CHARACTER(LEN=30)                     :: var_name
+  REAL,DIMENSION(1)                     :: jullasttab
+  REAL,DIMENSION(seedsize_max)          :: seed_in_file
+  INTEGER,DIMENSION(:), ALLOCATABLE     :: seed_in_proc
+  INTEGER  :: seedsize, iret
+  INTEGER  :: nlonid, nlatid, nlonid1, nlatid1, tdimid1, varid
+  INTEGER  :: ndim, dims(4)
+  CHARACTER(LEN=30) :: assoc
+  CHARACTER(LEN=70) :: str70
+  CHARACTER(LEN=80) :: stamp
+  INTEGER  :: yy_b, mm_b, dd_b, hh, mm
+  REAL     :: ss
+  CHARACTER(LEN=10) :: today, att
+  INTEGER  :: nlandid1, nlandid, nlevid, nlevid1
+  REAL     :: lev_max, lev_min
+  REAL     :: height_lev1
+  INTEGER  :: imois
+  REAL     :: xx, td
+
+!_ ================================================================================================================================
+
+  kindex(:)=0
+
+#ifdef CPP_PARA
+  nbindex=nbp_loc
+  CALL scatter(index_g,kindex)
+  kindex(1:nbindex)=kindex(1:nbindex)-(jj_begin-1)*iim_g
+#else
+  ! Copy saved land points index
+  nbindex = nbindex_w
+  kindex(1:nbindex_w) = kindex_w(:)
+#endif
+!-
+! 13. Prescribed or statistical values?
+!-
+  !Config Key   = IPPREC
+  !Config Desc  = Use prescribed values
+  !Config If    = ALLOW_WEATHERGEN
+  !Config Def   = 0
+  !Config Help  = If this is set to 1, the weather generator
+  !Config         uses the monthly mean values for daily means.
+  !Config         If it is set to 0, the weather generator
+  !Config         uses statistical relationships to derive daily
+  !Config         values from monthly means.
+  !Config Units = [-] 
+  ipprec = 0
+  CALL getin_p ('IPPREC',ipprec)
+  WRITE(numout,*) 'IPPREC: ',ipprec
+!-
+! 14. Do we want exact monthly precipitations even with ipprec=0 ?
+!-
+  !Config Key   = WEATHGEN_PRECIP_EXACT
+  !Config Desc  = Exact monthly precipitation
+  !Config If    = ALLOW_WEATHERGEN
+  !Config Def   = n
+  !Config Help  = If this is set to y, the weather generator
+  !Config         will generate pseudo-random precipitations
+  !Config         whose monthly mean is exactly the prescribed one.
+  !Config         In this case, the daily precipitation (for rainy
+  !Config         days) is constant (that is, some days have 0 precip,
+  !Config         the other days have precip=Precip_month/n_precip,
+  !Config         where n_precip is the prescribed number of rainy days
+  !Config         per month).
+  !Config Units = [FLAG]
+  precip_exact = .FALSE.
+  CALL getin_p ('WEATHGEN_PRECIP_EXACT',precip_exact)
+  WRITE(numout,*) 'PRECIP_EXACT: ',precip_exact
+
+!-
+! 15. Read restart file
+!-
+  CALL ioget_expval (val_exp)
+!-
+  var_name= 'julian'
+  IF (is_root_prc) THEN
+     CALL restget (rest_id,var_name,1,1,1,itau,.TRUE.,jullasttab)
+     IF (jullasttab(1) == val_exp) THEN
+        jullasttab(1) = itau2date(itau-1, date0, dt_force)
+     ENDIF
+  ENDIF
+  CALL bcast(jullasttab)
+  julian_last = jullasttab(1)
+!-
+  var_name= 'seed'
+  IF (is_root_prc) &
+       CALL restget (rest_id,var_name,seedsize_max, &
+ &              1,1,itau,.TRUE.,seed_in_file)
+  CALL bcast(seed_in_file)
+  IF (ALL(seed_in_file(:) == val_exp)) THEN
+!---
+!-- there is no need to reinitialize the random number generator as
+!-- this does not seem to be a restart
+!---
+    CONTINUE
+  ELSE
+!---
+!-- reinitialize the random number generator
+!---
+     IF (is_root_prc) &
+          CALL RANDOM_SEED( SIZE = seedsize )
+     CALL bcast(seedsize)
+     IF (seedsize > seedsize_max) THEN
+        STOP 'weathgen_begin: increase seedsize_max'
+     ENDIF
+  
+     IF (precip_exact) THEN
+!---
+!-- preparer un tableau utilise pour determiner s'il pleut ou pas
+!-- (en fct. du nombre de jours de pluie par mois).
+!---
+        IF (is_root_prc) THEN
+           DO imois=1,12
+              CALL permute (ndaypm(imois),jour_precip(:,imois))
+           ENDDO
+        ENDIF
+       CALL bcast(jour_precip)
+    ENDIF
+
+    ALLOC_ERR=-1
+    ALLOCATE(seed_in_proc(seedsize), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of seed_in_proc : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    seed_in_proc(1:seedsize) = NINT( seed_in_file(1:seedsize) )
+    CALL RANDOM_SEED (PUT = seed_in_proc)
+    DEALLOCATE( seed_in_proc )
+ ENDIF
+!-
+  var_name= 'iwet'
+  IF (is_root_prc) THEN
+    CALL restget (rest_id, var_name, iim_g, jjm_g, 1, itau, .TRUE., xchamp_g)
+    IF (ALL(xchamp_g(:) == val_exp)) THEN
+      xchamp_g(:) = zero
+    ENDIF
+  ENDIF
+  CALL scatter2D_mpi(xchamp_g,xchamp)
+  iwet(:) = NINT(xchamp(kindex(1:nbindex)))
+!-
+  var_name= 'psurfm0'
+  IF (is_root_prc) THEN
+     CALL restget (rest_id, var_name, iim_g, jjm_g, 1, itau, .TRUE., xchamp_g)
+     IF (ALL(xchamp_g(:) == val_exp)) THEN
+        xchamp_g(:) = 100000.
+     ENDIF
+  ENDIF
+  CALL scatter2D_mpi(xchamp_g,xchamp)
+  psurfm0(:) = xchamp(kindex(1:nbindex))
+!-
+  var_name= 'cloudm0'
+  IF (is_root_prc) THEN
+     CALL restget (rest_id, var_name, iim_g, jjm_g, 1, itau, .TRUE., xchamp_g)
+     IF (ALL(xchamp_g(:) == val_exp)) THEN
+        xchamp_g(:) = .5
+     ENDIF
+  ENDIF
+  CALL scatter2D_mpi(xchamp_g,xchamp)
+  cloudm0(:) = xchamp(kindex(1:nbindex))
+!-
+  var_name= 'tmaxm0'
+  IF (is_root_prc) THEN
+     CALL restget (rest_id, var_name, iim_g, jjm_g, 1, itau, .TRUE., xchamp_g)
+     IF (ALL(xchamp_g(:) == val_exp)) THEN
+        xchamp_g(:) = 285.
+     ENDIF
+  ENDIF
+  CALL scatter2D_mpi(xchamp_g,xchamp)
+  tmaxm0(:) = xchamp(kindex(1:nbindex))
+!-
+  var_name= 'tminm0'
+  IF (is_root_prc) THEN
+     CALL restget (rest_id, var_name, iim_g, jjm_g, 1, itau, .TRUE., xchamp_g)
+     IF (ALL(xchamp_g(:) == val_exp)) THEN
+        xchamp_g(:) = 275.
+     ENDIF
+  ENDIF
+  CALL scatter2D_mpi(xchamp_g,xchamp)
+  tminm0(:) = xchamp(kindex(1:nbindex))
+!-
+  var_name= 'qdm0'
+  IF (is_root_prc) THEN
+     CALL restget (rest_id, var_name, iim_g, jjm_g, 1, itau, .TRUE., xchamp_g)
+     IF (ALL(xchamp_g(:) == val_exp)) THEN
+        xchamp_g(:) = 1.E-03
+     ENDIF
+  ENDIF
+  CALL scatter2D_mpi(xchamp_g,xchamp)
+  qdm0(:) = xchamp(kindex(1:nbindex))
+!-
+  var_name= 'udm0'
+  IF (is_root_prc) THEN
+     CALL restget (rest_id, var_name, iim_g, jjm_g, 1, itau, .TRUE., xchamp_g)
+     IF (ALL(xchamp_g(:) == val_exp)) THEN
+        xchamp_g(:) = 2.
+     ENDIF
+  ENDIF
+  CALL scatter2D_mpi(xchamp_g,xchamp)
+  udm0(:) = xchamp(kindex(1:nbindex))
+!-
+  var_name= 'precipm0'
+  IF (is_root_prc) THEN
+     CALL restget (rest_id, var_name, iim_g, jjm_g, 1, itau, .TRUE., xchamp_g)
+     IF (ALL(xchamp_g(:) == val_exp)) THEN
+        xchamp_g(:) = 1.
+     ENDIF
+  ENDIF
+  CALL scatter2D_mpi(xchamp_g,xchamp)
+  precipm0(:) = xchamp(kindex(1:nbindex))
+!-
+  var_name= 'psurfm1'
+  IF (is_root_prc) THEN
+     CALL restget (rest_id, var_name, iim_g, jjm_g, 1, itau, .TRUE., xchamp_g)
+     IF (ALL(xchamp_g(:) == val_exp)) THEN
+        xchamp_g(:) = 100000.
+     ENDIF
+  ENDIF
+  CALL scatter2D_mpi(xchamp_g,xchamp)
+  psurfm1(:) = xchamp(kindex(1:nbindex))
+!-
+  var_name= 'cloudm1'
+  IF (is_root_prc) THEN
+     CALL restget (rest_id, var_name, iim_g, jjm_g, 1, itau, .TRUE., xchamp_g)
+     IF (ALL(xchamp_g(:) == val_exp)) THEN
+        xchamp_g(:) = .5
+     ENDIF
+  ENDIF
+  CALL scatter2D_mpi(xchamp_g,xchamp)
+  cloudm1(:) = xchamp(kindex(1:nbindex))
+!-
+  var_name= 'tmaxm1'
+  IF (is_root_prc) THEN
+     CALL restget (rest_id, var_name, iim_g, jjm_g, 1, itau, .TRUE., xchamp_g)
+     IF (ALL(xchamp_g(:) == val_exp)) THEN
+        xchamp_g(:) = 285.
+     ENDIF
+  ENDIF
+  CALL scatter2D_mpi(xchamp_g,xchamp)
+  tmaxm1(:) = xchamp(kindex(1:nbindex))
+!-
+  var_name= 'tminm1'
+  IF (is_root_prc) THEN
+     CALL restget (rest_id, var_name, iim_g, jjm_g, 1, itau, .TRUE., xchamp_g)
+     IF (ALL(xchamp_g(:) == val_exp)) THEN
+        xchamp_g(:) = 275.
+     ENDIF
+  ENDIF
+  CALL scatter2D_mpi(xchamp_g,xchamp)
+  tminm1(:) = xchamp(kindex(1:nbindex))
+!-
+  var_name= 'qdm1'
+  IF (is_root_prc) THEN
+     CALL restget (rest_id, var_name, iim_g, jjm_g, 1, itau, .TRUE., xchamp_g)
+     IF (ALL(xchamp_g(:) == val_exp)) THEN
+        xchamp_g(:) = 1.E-03
+     ENDIF
+  ENDIF
+  CALL scatter2D_mpi(xchamp_g,xchamp)
+  qdm1(:) = xchamp(kindex(1:nbindex))
+!-
+  var_name= 'udm1'
+  IF (is_root_prc) THEN
+     CALL restget (rest_id, var_name, iim_g, jjm_g, 1, itau, .TRUE., xchamp_g)
+     IF (ALL(xchamp_g(:) == val_exp)) THEN
+        xchamp_g(:) = 2.
+     ENDIF
+  ENDIF
+  CALL scatter2D_mpi(xchamp_g,xchamp)
+  udm1(:) = xchamp(kindex(1:nbindex))
+!-
+  var_name= 'precipm1'
+  IF (is_root_prc) THEN
+     CALL restget (rest_id, var_name, iim_g, jjm_g, 1, itau, .TRUE., xchamp_g)
+     IF (ALL(xchamp_g(:) == val_exp)) THEN
+        xchamp_g(:) = 1.
+     ENDIF
+  ENDIF
+  CALL scatter2D_mpi(xchamp_g,xchamp)
+  precipm1(:) = xchamp(kindex(1:nbindex))
+
+!-
+! 16. We still need instantaneous tair, qair, and the surface pressure
+!     We take daily mean values read from the restart file
+!-
+!!$  tair(:,:)=280.
+!!$  qair(:,:)=1.E-03
+!!$  pb(:,:)=101325
+  tair(:,:)=val_exp
+  qair(:,:)=val_exp
+  pb(:,:)=val_exp
+  xx = cte_grav/rair/0.0065
+  DO ij=1,nbindex
+     j = ((kindex(ij)-1)/iim) + 1
+     i = kindex(ij) - (j-1)*iim
+     
+     lat_land(ij) = lat(i,j)
+     
+     td =  (tmaxm0(ij)+tminm0(ij))/2.
+     tair(i,j) = td
+     qair(i,j) = qdm1(ij)
+     pb(i,j) = 101325.*(td/(td+0.0065*xintopo(ij)))**xx
+  ENDDO
+!-
+! 17. We can write a forcing file for Orchidee
+!     from this weather Generator run.
+!-
+  !Config Key   = DUMP_WEATHER
+  !Config Desc  = Write weather from generator into a forcing file
+  !Config If    = ALLOW_WEATHERGEN  
+  !Config Def   = n
+  !Config Help  = This flag makes the weather generator dump its
+  !Config         generated weather into a forcing file which can
+  !Config         then be used to get the same forcing on different
+  !Config         machines. This only works correctly if there is
+  !Config         a restart file (otherwise the forcing at the first
+  !Config         time step is slightly wrong).
+  !Config Units = [FLAG]
+  dump_weather = .FALSE.
+  CALL getin_p ('DUMP_WEATHER',dump_weather)
+!-
+  IF (dump_weather .AND. is_root_prc) THEN
+!---
+!-- Initialize the file
+!---
+     !Config Key   = DUMP_WEATHER_FILE
+     !Config Desc  = Name of the file that contains the weather from generator
+     !Config If    = DUMP_WEATHER
+     !Config Def   = weather_dump.nc
+     !Config Help  =
+     !Config Units = [FILE]
+    dump_weather_file = 'weather_dump.nc'
+    CALL getin ('DUMP_WEATHER_FILE',dump_weather_file)
+!---
+    !Config Key   = DUMP_WEATHER_GATHERED
+    !Config Desc  = Dump weather data on gathered grid
+    !Config If    = DUMP_WEATHER
+    !Config Def   = y
+    !Config Help  = If 'y', the weather data are gathered for all land points.
+    !Config Units = [FLAG]
+    gathered = .TRUE.
+    CALL getin ('DUMP_WEATHER_GATHERED',gathered)
+!---
+    iret = NF90_CREATE (TRIM(dump_weather_file),NF90_CLOBBER,dump_id)
+!---
+!-- Dimensions
+!---
+    iret = NF90_DEF_DIM (dump_id,'x',iim_g,nlonid1)
+    iret = NF90_DEF_DIM (dump_id,'y',jjm_g,nlatid1)
+    iret = NF90_DEF_DIM (dump_id,'z',  1,nlevid1)
+!---
+    IF (gathered) THEN
+      iret = NF90_DEF_DIM (dump_id,'land',nbp_glo,nlandid1)
+    ENDIF
+    iret = NF90_DEF_DIM (dump_id,'tstep',NF90_UNLIMITED,tdimid1)
+!---
+!-- Coordinate variables
+!---
+    dims(1:2) = (/ nlonid1, nlatid1 /)
+!---
+    iret = NF90_DEF_VAR (dump_id,'nav_lon',n_rtp,dims(1:2),nlonid)
+    iret = NF90_PUT_ATT (dump_id,nlonid,'units',"degrees_east")
+    iret = NF90_PUT_ATT (dump_id,nlonid,'valid_min',MINVAL(lon_g))
+    iret = NF90_PUT_ATT (dump_id,nlonid,'valid_max',MAXVAL(lon_g))
+    iret = NF90_PUT_ATT (dump_id,nlonid,'long_name',"Longitude")
+!---
+    iret = NF90_DEF_VAR (dump_id,'nav_lat',n_rtp,dims(1:2),nlatid)
+    iret = NF90_PUT_ATT (dump_id,nlatid,'units',"degrees_north")
+    iret = NF90_PUT_ATT (dump_id,nlatid,'valid_min',MINVAL(lat_g))
+    iret = NF90_PUT_ATT (dump_id,nlatid,'valid_max',MAXVAL(lat_g))
+    iret = NF90_PUT_ATT (dump_id,nlatid,'long_name',"Latitude")
+!---
+    height_lev1 = 10.
+    !Config Key   = HEIGHT_LEV1
+    !Config Desc  = 
+    !Config If    = DUMP_WEATHER
+    !Config Def   = 10.
+    !Config Help  = 
+    !Config Units = [m]
+    CALL getin ('HEIGHT_LEV1',height_lev1)
+    lev_min = height_lev1
+    lev_max = height_lev1
+!---
+    iret = NF90_DEF_VAR (dump_id,'level',n_rtp,(/ nlevid1 /),nlevid)
+    iret = NF90_PUT_ATT (dump_id,nlevid,'units',"m")
+    iret = NF90_PUT_ATT (dump_id,nlevid,'valid_min',lev_min)
+    iret = NF90_PUT_ATT (dump_id,nlevid,'valid_max',lev_max)
+    iret = NF90_PUT_ATT (dump_id,nlevid,'long_name',"Vertical levels")
+!---
+    IF (gathered) THEN
+      iret = NF90_DEF_VAR (dump_id,'land',NF90_INT,(/ nlandid1 /),nlandid)
+      iret = NF90_PUT_ATT (dump_id,nlandid,'compress',"y x")
+    ENDIF
+!---
+!-- Store the time axes.
+!---
+    iret = NF90_DEF_VAR (dump_id,'time',n_rtp,tdimid1,time_id)
+
+    yy_b=0
+    mm_b=1
+    dd_b=1
+    hh=00
+    mm=00
+    ss=0.
+
+    WRITE (str70,7000) yy_b, mm_b, dd_b, hh, mm, INT(ss)
+    iret = NF90_PUT_ATT (dump_id,time_id,'units',TRIM(str70))
+    iret = NF90_PUT_ATT (dump_id,time_id,'calendar',TRIM(calendar_str))
+    iret = NF90_PUT_ATT (dump_id,time_id,'title','Time')
+    iret = NF90_PUT_ATT (dump_id,time_id,'long_name','Time axis')
+    WRITE(str70,7001) yy_b, cal(mm_b), dd_b, hh, mm, INT(ss)
+    iret = NF90_PUT_ATT (dump_id,time_id,'time_origin',TRIM(str70))
+!---
+!-- Time steps
+!---
+    iret = NF90_DEF_VAR (dump_id,'timestp',NF90_INT,tdimid1,timestp_id)
+    WRITE(str70,7002) yy_b, mm_b, dd_b, hh, mm, INT(ss)
+    iret = NF90_PUT_ATT (dump_id,timestp_id,'units',TRIM(str70))
+    iret = NF90_PUT_ATT (dump_id,timestp_id,'title','Time steps')
+    iret = NF90_PUT_ATT (dump_id,timestp_id,'tstep_sec',dt_force)
+    iret = NF90_PUT_ATT &
+ &           (dump_id,timestp_id,'long_name','Time step axis')
+    WRITE(str70,7001) yy_b, cal(mm_b), dd_b, hh, mm, INT(ss)
+    iret = NF90_PUT_ATT (dump_id,timestp_id,'time_origin',TRIM(str70))
+!---
+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)
+!---
+!-- The variables in the file are declared and their attributes
+!-- written.
+!---
+    IF (gathered) THEN
+      ndim = 2
+      dims(1:2) = (/ nlandid1, tdimid1 /)
+      assoc = 'time (nav_lat nav_lon)'
+    ELSE
+      ndim = 3
+      dims(1:3) = (/ nlonid1, nlatid1, tdimid1 /)
+      assoc = 'time nav_lat nav_lon'
+    ENDIF
+!---
+    iret = NF90_DEF_VAR (dump_id,'SWdown',n_rtp,dims(1:ndim),varid)
+    iret = NF90_PUT_ATT (dump_id,varid,'axis','TYX')
+    iret = NF90_PUT_ATT (dump_id,varid,'units','W/m^2')
+    iret = NF90_PUT_ATT (dump_id,varid,'long_name', &
+ &                       'Surface incident shortwave radiation')
+    iret = NF90_PUT_ATT (dump_id,varid,'associate',TRIM(assoc))
+    iret = NF90_PUT_ATT (dump_id,varid,'missing_value',undef_sechiba)
+    soldownid = varid
+!---
+    iret = NF90_DEF_VAR (dump_id,'Rainf',n_rtp,dims(1:ndim),varid)
+    iret = NF90_PUT_ATT (dump_id,varid,'axis','TYX')
+    iret = NF90_PUT_ATT (dump_id,varid,'units','kg/m^2s')
+    iret = NF90_PUT_ATT (dump_id,varid,'long_name', &
+ &                       'Rainfall rate')
+    iret = NF90_PUT_ATT (dump_id,varid,'associate',TRIM(assoc))
+    iret = NF90_PUT_ATT (dump_id,varid,'missing_value',undef_sechiba)
+    rainfid = varid
+!---
+    iret = NF90_DEF_VAR (dump_id,'Snowf',n_rtp,dims(1:ndim),varid)
+    iret = NF90_PUT_ATT (dump_id,varid,'axis','TYX')
+    iret = NF90_PUT_ATT (dump_id,varid,'units','kg/m^2s')
+    iret = NF90_PUT_ATT (dump_id,varid,'long_name', &
+ &                       'Snowfall rate')
+    iret = NF90_PUT_ATT (dump_id,varid,'associate',TRIM(assoc))
+    iret = NF90_PUT_ATT (dump_id,varid,'missing_value',undef_sechiba)
+    snowfid = varid
+!---
+    iret = NF90_DEF_VAR (dump_id,'LWdown',n_rtp,dims(1:ndim),varid)
+    iret = NF90_PUT_ATT (dump_id,varid,'axis','TYX')
+    iret = NF90_PUT_ATT (dump_id,varid,'units','W/m^2')
+    iret = NF90_PUT_ATT (dump_id,varid,'long_name', &
+ &                       'Surface incident longwave radiation')
+    iret = NF90_PUT_ATT (dump_id,varid,'associate',TRIM(assoc))
+    iret = NF90_PUT_ATT (dump_id,varid,'missing_value',undef_sechiba)
+    lwradid = varid
+!---
+    iret = NF90_DEF_VAR (dump_id,'PSurf',n_rtp,dims(1:ndim),varid)
+    iret = NF90_PUT_ATT (dump_id,varid,'axis','TYX')
+    iret = NF90_PUT_ATT (dump_id,varid,'units','Pa')
+    iret = NF90_PUT_ATT (dump_id,varid,'long_name', &
+ &                       'Surface pressure')
+    iret = NF90_PUT_ATT (dump_id,varid,'associate',TRIM(assoc))
+    iret = NF90_PUT_ATT (dump_id,varid,'missing_value',undef_sechiba)
+    psolid = varid
+!---
+!-- 3D Variables to be written
+!---
+    IF (gathered) THEN
+      ndim = 3
+      dims(1:3) = (/ nlandid1, nlevid1, tdimid1 /)
+      assoc = 'time level (nav_lat nav_lon)'
+    ELSE
+      ndim = 4
+      dims(1:4) = (/ nlonid1, nlatid1, nlevid1, tdimid1 /)
+      assoc = 'time level nav_lat nav_lon'
+    ENDIF
+!---
+    iret = NF90_DEF_VAR (dump_id,'Tair',n_rtp,dims(1:ndim),varid)
+    iret = NF90_PUT_ATT (dump_id,varid,'axis','TZYX')
+    iret = NF90_PUT_ATT (dump_id,varid,'units','K')
+    iret = NF90_PUT_ATT (dump_id,varid,'long_name', &
+ &                       'Near surface air temperature')
+    iret = NF90_PUT_ATT (dump_id,varid,'associate',TRIM(assoc))
+    iret = NF90_PUT_ATT (dump_id,varid,'missing_value',undef_sechiba)
+    tairid = varid
+!---
+    iret = NF90_DEF_VAR (dump_id,'Qair',n_rtp,dims(1:ndim),varid)
+    iret = NF90_PUT_ATT (dump_id,varid,'axis','TZYX')
+    iret = NF90_PUT_ATT (dump_id,varid,'units','kg/kg')
+    iret = NF90_PUT_ATT (dump_id,varid,'long_name', &
+ &                       'Near surface specific humidity')
+    iret = NF90_PUT_ATT (dump_id,varid,'associate',TRIM(assoc))
+    iret = NF90_PUT_ATT (dump_id,varid,'missing_value',undef_sechiba)
+    qairid = varid
+!---
+    iret = NF90_DEF_VAR (dump_id,'Wind_N',n_rtp,dims(1:ndim),varid)
+    iret = NF90_PUT_ATT (dump_id,varid,'axis','TZYX')
+    iret = NF90_PUT_ATT (dump_id,varid,'units','m/s')
+    iret = NF90_PUT_ATT (dump_id,varid,'long_name', &
+ &                       'Near surface northward wind component')
+    iret = NF90_PUT_ATT (dump_id,varid,'associate',TRIM(assoc))
+    iret = NF90_PUT_ATT (dump_id,varid,'missing_value',undef_sechiba)
+    uid = varid
+!---
+    iret = NF90_DEF_VAR (dump_id,'Wind_E',n_rtp,dims(1:ndim),varid)
+    iret = NF90_PUT_ATT (dump_id,varid,'axis','TZYX')
+    iret = NF90_PUT_ATT (dump_id,varid,'units','m/s')
+    iret = NF90_PUT_ATT (dump_id,varid,'long_name', &
+ &                       'Near surface eastward wind component')
+    iret = NF90_PUT_ATT (dump_id,varid,'associate',TRIM(assoc))
+    iret = NF90_PUT_ATT (dump_id,varid,'missing_value',undef_sechiba)
+    vid = varid
+!---
+!-- Global attributes
+!---
+    CALL DATE_AND_TIME (today, att)
+    stamp = "WG, date: "//TRIM(today)//" at "//TRIM(att)
+    iret = NF90_PUT_ATT (dump_id,NF90_GLOBAL,'Conventions',"GDT 1.2")
+    iret = NF90_PUT_ATT (dump_id,NF90_GLOBAL,'file_name', &
+ &                       TRIM(dump_weather_file))
+    iret = NF90_PUT_ATT (dump_id,NF90_GLOBAL,'production',TRIM(stamp))
+!---
+!-- Finish the definition phase
+!---
+    iret = NF90_ENDDEF (dump_id)
+!---
+!--    Write coordinates
+!---
+    iret = NF90_PUT_VAR (dump_id,nlonid,lon_g)
+    IF (iret /= NF90_NOERR) THEN
+       WRITE(numout,*) iret
+       CALL ipslerr_p (3,'weathgen_begin', &
+ &          'Could not put variable nav_lon in the file : ', &
+ &          TRIM(dump_weather_file),'(Solution ?)')
+    ENDIF
+    iret = NF90_PUT_VAR (dump_id,nlatid,lat_g)
+    IF (iret /= NF90_NOERR) THEN
+       WRITE(numout,*) iret
+       CALL ipslerr_p (3,'weathgen_begin', &
+ &          'Could not put variable nav_lat in the file : ', &
+ &          TRIM(dump_weather_file),'(Solution ?)')
+    ENDIF
+    iret = NF90_PUT_VAR (dump_id,nlevid,height_lev1)
+    IF (iret /= NF90_NOERR) THEN
+       WRITE(numout,*) iret
+       CALL ipslerr_p (3,'weathgen_begin', &
+ &          'Could not put variable level in the file : ', &
+ &          TRIM(dump_weather_file),'(Solution ?)')
+    ENDIF
+!---
+    IF (gathered) THEN
+       iret = NF90_PUT_VAR (dump_id,nlandid,index_g(1:nbp_glo))
+       IF (iret /= NF90_NOERR) THEN
+          WRITE(numout,*) iret
+          CALL ipslerr_p (3,'weathgen_begin', &
+ &          'Could not put variable land in the file : ', &
+ &          TRIM(dump_weather_file),'(Solution ?)')
+       ENDIF
+    ENDIF
+!---
+ ENDIF ! dump_weather
+!-----------------------------
+END SUBROUTINE weathgen_begin
+!-
+!===
+!-
+!! ================================================================================================================================
+!! SUBROUTINE   : weathgen_get
+!!
+!>\BRIEF        This subroutine initializes forcing values. 
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::swdown, ::raina, ::snowa, ::tair, ::u, ::v, ::qair, ::psurf, ::lwdown
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE weathgen_get &
+& (itau, date0, dt_force, nbindex, nband, lat, &
+&  swdown, raina, snowa, tair, u, v, qair, psurf, lwdown)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+
+  !! 0. Variables and parameters declaration
+
+  !! 0.1 Input variables
+
+  INTEGER,INTENT(IN)               :: itau      !! number of time step
+  REAL,INTENT(IN)                  :: date0     !! date when itau was 0
+  REAL,INTENT(IN)                  :: dt_force  !! time step (s)
+  INTEGER,INTENT(IN)               :: nbindex   !! number of land points
+  INTEGER,INTENT(IN)               :: nband     !! number of visible bands
+  REAL,DIMENSION(nbindex),INTENT(IN)  :: lat    !! latitude (deg)
+
+  !! 0.2 Output variables  
+
+  REAL,DIMENSION(nbindex,nband),INTENT(OUT) :: swdown        !! Downward solar radiation @tex $(W.m^{-2})$ @endtex
+  REAL,DIMENSION(nbindex),INTENT(OUT)       :: raina, snowa  !! precipitations @tex $(mm.day^{-1})$ @endtex 
+  REAL,DIMENSION(nbindex),INTENT(OUT)       :: tair          !! air temperature (K)
+  REAL,DIMENSION(nbindex),INTENT(OUT)       :: u,v           !! wind speed @tex $(m.s^{-1})$ @endtex
+  REAL,DIMENSION(nbindex),INTENT(OUT)       :: qair          !! air humidity @tex $(kg_h2o.kg_air^{-1})$ @endtex
+  REAL,DIMENSION(nbindex),INTENT(OUT)       :: psurf         !! Surface pressure (Pa)
+  REAL,DIMENSION(nbindex),INTENT(OUT)       :: lwdown        !! Downward long wave radiation @tex $(W.m^{-2})$ @endtex
+
+  !! 0.4 Local variables
+
+  REAL,DIMENSION(nbindex)        :: cloud, tmax, tmin, precipd, qd, ud
+  REAL,DIMENSION(nbindex)        :: rh
+  REAL,DIMENSION(nbindex,nband)  :: solai, solad
+  REAL                        :: julian, jur
+  REAL                        :: x
+  INTEGER                     :: yy, mm, dd
+  REAL                        :: ss, plens, time
+
+!_ ================================================================================================================================
+
+!-
+! 1. get a reduced julian day
+!-
+  julian = itau2date(itau-1, date0, dt_force)
+!SZ, test: solar noon at 12 o'clock!
+!  julian = itau2date(itau, date0, dt_force)
+  CALL ju2ymds (julian, yy, mm, dd, ss)
+  CALL ymds2ju (yy,1,1,0.0, jur)
+  julian = julian-jur
+  CALL ju2ymds (julian, yy, mm, dd, ss)
+!-
+! 2. daily values
+!-
+  IF (INT(julian_last) /= INT(julian)) THEN
+!-- today's values become yesterday's values
+    cloudm1(:) = cloudm0(:)
+    tmaxm1(:) = tmaxm0(:)
+    tminm1(:) = tminm0(:)
+    precipm1(:) = precipm0(:)
+    qdm1(:) = qdm0(:)
+    udm1(:) = udm0(:)
+    psurfm1(:) = psurfm0(:)
+!-- we have to get new daily values
+!!$    WRITE(*,*) mpi_rank, "weathgen_get : date ",yy, mm, dd, ss
+!!$    WRITE(*,*) mpi_rank, "weathgen_get : grid date ",year, month, day, sec
+    CALL daily (nbindex, mm, dd, cloudm0, tmaxm0, tminm0, &
+ &              precipm0, qdm0, udm0, psurfm0)
+  ENDIF
+!-
+! 3. interpolate daily values
+!    (otherwise we get ugly temperature jumps at midnight)
+!-
+  x = (julian-INT(julian))
+!-
+  cloud(:) = (1.-x)*cloudm1(:)+x*cloudm0(:)
+  tmax(:) = (1.-x)*tmaxm1(:)+x*tmaxm0(:)
+  tmin(:) = (1.-x)*tminm1(:)+x*tminm0(:)
+  precipd(:) = (1.-x)*precipm1(:)+x*precipm0(:)
+  qd(:) = (1.-x)*qdm1(:)+x*qdm0(:)
+  ud(:) = (1.-x)*udm1(:)+x*udm0(:)
+  psurf(:) = (1.-x)*psurfm1(:)+x*psurfm0(:)
+!-
+! 4. read instantaneous values
+!-
+  plens = one_day/dt_force
+  time = (julian-REAL(INT(julian)))*one_day
+!-
+  CALL diurnal (nbindex, nband, time, NINT(julian), plens, 0., one_day, &
+ &              lat, cloud, tmax, tmin, precipd, qd, ud, psurf, &
+ &              lwdown, solad, solai, u, tair, qair, raina, snowa, rh)
+!-
+  raina(:) = raina(:)/dt_force
+  snowa(:) = snowa(:)/dt_force
+!-
+  swdown(:,:) = solad(:,:)+solai(:,:)
+!-
+  v(:) = zero
+!-
+! 5. Store date
+!-
+  julian_last = julian
+!--------------------------
+END SUBROUTINE weathgen_get
+!-
+!===
+!-
+!! ================================================================================================================================
+!! SUBROUTINE   : weathgen_restwrite
+!!
+!>\BRIEF         This subroutine writes data in the restart file.
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE weathgen_restwrite (rest_id,itau,iim,jjm,nbindex,kindex)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+
+  !! 0. Variables and parameters declaration
+
+  !! 0.1 Input variables
+
+  INTEGER,INTENT(IN)  :: rest_id,itau,iim,jjm,nbindex
+  INTEGER,DIMENSION(iim*jjm),INTENT(IN) :: kindex
+
+  !! 0.4 Local variables
+
+  CHARACTER(LEN=30)                 :: var_name
+  INTEGER                           :: i,j,ij
+  REAL,DIMENSION(1)                 :: jullasttab
+  REAL,DIMENSION(seedsize_max)      :: seed_in_file
+  INTEGER,DIMENSION(:),ALLOCATABLE  :: seed_in_proc
+  INTEGER                           :: seedsize
+  REAL                              :: rndnum
+  REAL,DIMENSION(iim*jjm)           :: xchamp
+  REAL,DIMENSION(iim_g*jjm_g)       :: xchamp_g
+
+!_ ================================================================================================================================
+
+  var_name= 'julian'
+  jullasttab(:) = julian_last
+  IF (is_root_prc) CALL restput (rest_id, var_name, 1, 1, 1, itau, jullasttab)
+!-
+  IF (is_root_prc) THEN
+     CALL RANDOM_SEED( SIZE = seedsize )
+     IF (seedsize > seedsize_max) THEN
+        STOP 'weathgen_restwrite: increase seedsize_max'
+     ENDIF
+  ENDIF
+  CALL bcast(seedsize)
+
+  IF (is_root_prc) THEN
+     ALLOC_ERR=-1
+     ALLOCATE(seed_in_proc(seedsize), STAT=ALLOC_ERR)
+     IF (ALLOC_ERR/=0) THEN
+        WRITE(numout,*) "ERROR IN ALLOCATION of seed_in_proc : ",ALLOC_ERR
+        STOP 
+     ENDIF
+!-
+     CALL RANDOM_SEED (GET = seed_in_proc)
+!-
+     seed_in_file(1:seedsize) = REAL(seed_in_proc(1:seedsize))
+!-
+! fill in the seed up to seedsize_max
+! (useful in the case we restart on
+!  a machine with a longer seed vector:
+!  we do not want a degenerated seed)
+!-
+     DO i=seedsize+1,seedsize_max
+        CALL RANDOM_NUMBER( rndnum )
+        seed_in_file(i) = 100000.*rndnum
+     ENDDO
+  ENDIF
+  CALL bcast (seed_in_file)
+!-
+  IF (is_root_prc) THEN
+     DEALLOCATE( seed_in_proc )
+!-
+     var_name= 'seed'
+     CALL restput (rest_id,var_name,seedsize_max,1,1,itau,seed_in_file)
+  ENDIF
+!-
+
+  xchamp(:) = val_exp
+  
+!!$  DO j=1,jjm
+!!$    DO i=1,iim
+!!$      ij = (j-1)*iim+i
+!!$      xchamp(i,j) = REAL(iwet(ij))
+!!$    ENDDO
+!!$  ENDDO
+  DO ij=1,nbindex
+     xchamp(kindex(ij)) = REAL(iwet(ij))
+  ENDDO
+  var_name= 'iwet'
+  CALL gather2D_mpi(xchamp,xchamp_g)
+  IF (is_root_prc) THEN
+     CALL restput (rest_id, var_name, iim_g, jjm_g, 1, itau, xchamp_g)
+  ENDIF
+!-
+  DO ij=1,nbindex
+    xchamp(kindex(ij)) = psurfm0(ij)
+  ENDDO
+  var_name= 'psurfm0'
+  CALL gather2D_mpi(xchamp,xchamp_g)
+  IF (is_root_prc) THEN
+     CALL restput (rest_id, var_name, iim_g, jjm_g, 1, itau, xchamp_g)
+  ENDIF
+!-
+  DO ij=1,nbindex
+    xchamp(kindex(ij)) = cloudm0(ij)
+  ENDDO
+  var_name= 'cloudm0'
+  CALL gather2D_mpi(xchamp,xchamp_g)
+  IF (is_root_prc) THEN
+     CALL restput (rest_id, var_name, iim_g, jjm_g, 1, itau, xchamp_g)
+  ENDIF
+!-
+  DO ij=1,nbindex
+    xchamp(kindex(ij)) = tmaxm0(ij)
+  ENDDO
+  var_name= 'tmaxm0'
+  CALL gather2D_mpi(xchamp,xchamp_g)
+  IF (is_root_prc) THEN
+     CALL restput (rest_id, var_name, iim_g, jjm_g, 1, itau, xchamp_g)
+  ENDIF
+!-
+  DO ij=1,nbindex
+    xchamp(kindex(ij)) = tminm0(ij)
+  ENDDO
+  var_name= 'tminm0'
+  CALL gather2D_mpi(xchamp,xchamp_g)
+  IF (is_root_prc) THEN
+     CALL restput (rest_id, var_name, iim_g, jjm_g, 1, itau, xchamp_g)
+  ENDIF
+!-
+  DO ij=1,nbindex
+    xchamp(kindex(ij)) = qdm0(ij)
+  ENDDO
+  var_name= 'qdm0'
+  CALL gather2D_mpi(xchamp,xchamp_g)
+  IF (is_root_prc) THEN
+     CALL restput (rest_id, var_name, iim_g, jjm_g, 1, itau, xchamp_g)
+  ENDIF
+!-
+  DO ij=1,nbindex
+    xchamp(kindex(ij)) = udm0(ij)
+  ENDDO
+  var_name= 'udm0'
+  CALL gather2D_mpi(xchamp,xchamp_g)
+  IF (is_root_prc) THEN
+     CALL restput (rest_id, var_name, iim_g, jjm_g, 1, itau, xchamp_g)
+  ENDIF
+!-
+  DO ij=1,nbindex
+    xchamp(kindex(ij)) = precipm0(ij)
+  ENDDO
+  var_name= 'precipm0'
+  CALL gather2D_mpi(xchamp,xchamp_g)
+  IF (is_root_prc) THEN
+     CALL restput (rest_id, var_name, iim_g, jjm_g, 1, itau, xchamp_g)
+  ENDIF
+!-
+  DO ij=1,nbindex
+    xchamp(kindex(ij)) = psurfm1(ij)
+  ENDDO
+  var_name= 'psurfm1'
+  CALL gather2D_mpi(xchamp,xchamp_g)
+  IF (is_root_prc) THEN
+     CALL restput (rest_id, var_name, iim_g, jjm_g, 1, itau, xchamp_g)
+  ENDIF
+!-
+  DO ij=1,nbindex
+    xchamp(kindex(ij)) = cloudm1(ij)
+  ENDDO
+  var_name= 'cloudm1'
+  CALL gather2D_mpi(xchamp,xchamp_g)
+  IF (is_root_prc) THEN
+     CALL restput (rest_id, var_name, iim_g, jjm_g, 1, itau, xchamp_g)
+  ENDIF
+!-
+  DO ij=1,nbindex
+    xchamp(kindex(ij)) = tmaxm1(ij)
+  ENDDO
+  var_name= 'tmaxm1'
+  CALL gather2D_mpi(xchamp,xchamp_g)
+  IF (is_root_prc) THEN
+     CALL restput (rest_id, var_name, iim_g, jjm_g, 1, itau, xchamp_g)
+  ENDIF
+!-
+  DO ij=1,nbindex
+    xchamp(kindex(ij)) = tminm1(ij)
+  ENDDO
+  var_name= 'tminm1'
+  CALL gather2D_mpi(xchamp,xchamp_g)
+  IF (is_root_prc) THEN
+     CALL restput (rest_id, var_name, iim_g, jjm_g, 1, itau, xchamp_g)
+  ENDIF
+!-
+  DO ij=1,nbindex
+    xchamp(kindex(ij)) = qdm1(ij)
+  ENDDO
+  var_name= 'qdm1'
+  CALL gather2D_mpi(xchamp,xchamp_g)
+  IF (is_root_prc) THEN
+     CALL restput (rest_id, var_name, iim_g, jjm_g, 1, itau, xchamp_g)
+  ENDIF
+!-
+  DO ij=1,nbindex
+    xchamp(kindex(ij)) = udm1(ij)
+  ENDDO
+  var_name= 'udm1'
+  CALL gather2D_mpi(xchamp,xchamp_g)
+  IF (is_root_prc) THEN
+     CALL restput (rest_id, var_name, iim_g, jjm_g, 1, itau, xchamp_g)
+  ENDIF
+!-
+  DO ij=1,nbindex
+    xchamp(kindex(ij)) = precipm1(ij)
+  ENDDO
+  var_name= 'precipm1'
+  CALL gather2D_mpi(xchamp,xchamp_g)
+  IF (is_root_prc) THEN
+     CALL restput (rest_id, var_name, iim_g, jjm_g, 1, itau, xchamp_g)
+  ENDIF
+!--------------------------------
+END SUBROUTINE weathgen_restwrite
+!-
+!===
+!-
+!! ================================================================================================================================
+!! SUBROUTINE   : weathgen_data
+!!
+!>\BRIEF         This subroutine reads data from an netcdf file. 
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::champout
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE weather_read &
+& (force_id,nomvar,iim_file,jjm_file,n3,i_cut, &
+&  iim,jjm,n_agg,ncorr,icorr,jcorr,champout)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+
+  !! 0. Variables and parameters declaration
+  
+  !! 0.1 Input variables
+
+  INTEGER,INTENT(IN)                          :: force_id
+  CHARACTER(LEN=*),INTENT(IN)                 :: nomvar
+  INTEGER,INTENT(IN)                          :: iim_file,jjm_file
+  INTEGER,INTENT(IN)                          :: n3
+  INTEGER,INTENT(IN)                          :: i_cut
+  INTEGER,INTENT(IN)                          :: iim,jjm
+  INTEGER,INTENT(IN)                          :: n_agg
+  INTEGER,DIMENSION(:,:),INTENT(IN)           :: ncorr
+  INTEGER,DIMENSION(:,:,:),INTENT(IN)         :: icorr,jcorr
+
+  !! 0.2 Output variables 
+
+  REAL,DIMENSION(iim*jjm,n3),INTENT(OUT)      :: champout
+
+  !! 0.4 Local variables
+
+  REAL,DIMENSION(iim_file,jjm_file,n3)        :: champ_file
+  REAL,ALLOCATABLE,DIMENSION(:,:)             :: champout_g
+  INTEGER                                     :: i,j,ij,l,m
+
+!_ ================================================================================================================================
+
+  WRITE(numout,*) 'Lecture ',TRIM(nomvar)
+!-
+  IF (is_root_prc) THEN
+     ALLOCATE(champout_g(iim_g*jjm_g,n3))
+     IF ( n3 == 1 ) THEN
+        CALL flinget (force_id,nomvar(1:LEN_TRIM(nomvar)), &
+             &                iim_file, jjm_file, 0, 0,  1, 1, champ_file)
+     ELSE
+        DO l=1,n3
+           CALL flinget &
+                &      (force_id,nomvar(1:LEN_TRIM(nomvar)), &
+                &       iim_file, jjm_file, 0, n3,  l, l, champ_file(:,:,l))
+        ENDDO
+     ENDIF
+     ! shift if necessary
+     IF (i_cut /= 0) THEN
+        DO l=1,n3
+           CALL shift_field (iim_file,jjm_file,i_cut,champ_file(:,:,l))
+        ENDDO
+     ENDIF
+     ! interpolate onto the model grid
+     DO l=1,n3
+        DO j=1,jjm_g
+           DO i=1,iim_g
+              ij = i+(j-1)*iim_g
+              champout_g(ij,l) = zero
+              DO m=1,ncorr(i,j)
+                 champout_g(ij,l) = champout_g(ij,l) &
+        &                        +champ_file(icorr(i,j,m),jcorr(i,j,m),l)
+              ENDDO
+              champout_g(ij,l) = champout_g(ij,l)/REAL(ncorr(i,j))
+           ENDDO
+        ENDDO
+     ENDDO
+!$     DO l=1,n3
+!$        DO j=1,jjm_g
+!$           WRITE(numout,*) j,(/ ( champout_g((j-1)*iim_g+i,l), i=1,iim_g ) /)
+!$        ENDDO
+!$     ENDDO
+  ELSE
+     ALLOCATE(champout_g(1,1))
+  ENDIF
+!!$  CALL scatter2D(champout_g,champout)
+#ifndef CPP_PARA
+  champout(:,:)=champout_g(:,:)
+#else
+  CALL orch_scatter2D_mpi_rgen(champout_g,champout,n3)
+#endif
+
+!$  DO l=1,n3
+!$     DO j=1,jjm
+!$        WRITE(numout,*) j,(/ ( champout((j-1)*iim_g+i,l), i=1,iim_g ) /)
+!$     ENDDO
+!$  ENDDO
+  !----------------------------
+END SUBROUTINE weather_read
+!-
+!===
+!-
+!! ================================================================================================================================
+!! SUBROUTINE   : weathgen_dump
+!!
+!>\BRIEF        This subroutine "dumps" data before writing an netcdf file.
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE weathgen_dump &
+& (itau, dt_force, iim, jjm, nbindex, kindex, lrstwrite, &
+&  swdown, rainf, snowf, tair, u, v, qair, pb, lwdown )
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+
+  !! 0. Variables and parameters declaration
+
+  !! 0.1 Input variables
+
+  INTEGER,INTENT(IN)                     :: itau
+  REAL,INTENT(IN)                        :: dt_force
+  INTEGER,INTENT(IN)                     :: iim,jjm
+  INTEGER,INTENT(IN)                     :: nbindex
+  LOGICAL,INTENT(IN)                     :: lrstwrite
+  INTEGER,DIMENSION(iim*jjm),INTENT(IN)  :: kindex
+  REAL,DIMENSION(iim*jjm),INTENT(IN)     :: &
+ &  swdown, rainf, snowf, tair, u, v, qair, pb, lwdown
+
+  !! 0.4 Local variables
+
+  INTEGER                 :: iret,ndim
+  INTEGER,DIMENSION(4)    :: corner,edges
+  REAL,DIMENSION(iim*jjm) :: var_gather
+
+!_ ================================================================================================================================
+
+!-
+! time dimension
+!-
+  iret = NF90_PUT_VAR (dump_id,timestp_id,(/ REAL(itau) /), &
+ &                     start=(/ itau /),count=(/ 1 /))
+  iret = NF90_PUT_VAR (dump_id,time_id,(/ REAL(itau)*dt_force /), &
+ &                     start=(/ itau /),count=(/ 1 /))
+!-
+! 2D variables: pas de dimension verticale
+!-
+  IF (gathered) THEN
+    ndim = 2
+    corner(1:2) = (/ 1, itau /)
+    edges(1:2) = (/ nbindex, 1 /)
+  ELSE
+    ndim = 3
+    corner(1:3) = (/ 1, 1, itau /)
+    edges(1:3) = (/ iim, jjm, 1 /)
+  ENDIF
+!-
+  CALL gather_weather (iim*jjm,nbindex,kindex,swdown, var_gather)
+  iret = NF90_PUT_VAR (dump_id,soldownid, var_gather, &
+ &         start=corner(1:ndim), count=edges(1:ndim))
+  CALL gather_weather (iim*jjm,nbindex,kindex,rainf,  var_gather)
+  iret = NF90_PUT_VAR (dump_id,rainfid,   var_gather, &
+ &         start=corner(1:ndim), count=edges(1:ndim))
+  CALL gather_weather (iim*jjm,nbindex,kindex,snowf,  var_gather)
+  iret = NF90_PUT_VAR (dump_id,snowfid,   var_gather, &
+ &         start=corner(1:ndim), count=edges(1:ndim))
+  CALL gather_weather (iim*jjm,nbindex,kindex,pb,     var_gather)
+  iret = NF90_PUT_VAR (dump_id,psolid,    var_gather, &
+ &         start=corner(1:ndim), count=edges(1:ndim))
+  CALL gather_weather (iim*jjm,nbindex,kindex,lwdown, var_gather)
+  iret = NF90_PUT_VAR (dump_id,lwradid,   var_gather, &
+ &         start=corner(1:ndim), count=edges(1:ndim))
+!-
+! 3D variables
+!-
+  IF (gathered) THEN
+    ndim = 3
+    corner(1:3) = (/ 1, 1, itau /)
+    edges(1:3) = (/ nbindex, 1, 1 /)
+  ELSE
+    ndim = 4
+    corner(1:4) = (/ 1, 1, 1, itau /)
+    edges(1:4) = (/ iim, jjm, 1, 1 /)
+  ENDIF
+!-
+  CALL gather_weather (iim*jjm,nbindex,kindex,u,    var_gather)
+  iret = NF90_PUT_VAR (dump_id,uid,    var_gather, &
+ &         start=corner(1:ndim), count=edges(1:ndim))
+  CALL gather_weather (iim*jjm,nbindex,kindex,v,    var_gather)
+  iret = NF90_PUT_VAR (dump_id,vid,    var_gather, &
+ &         start=corner(1:ndim), count=edges(1:ndim))
+  CALL gather_weather (iim*jjm,nbindex,kindex,tair, var_gather)
+  iret = NF90_PUT_VAR (dump_id,tairid, var_gather, &
+ &         start=corner(1:ndim), count=edges(1:ndim))
+  CALL gather_weather (iim*jjm,nbindex,kindex,qair, var_gather)
+  iret = NF90_PUT_VAR (dump_id,qairid, var_gather, &
+ &         start=corner(1:ndim), count=edges(1:ndim))
+!-
+  IF (lrstwrite) THEN
+    iret = NF90_CLOSE (dump_id)
+  ENDIF
+!---------------------------
+END SUBROUTINE weathgen_dump
+!-
+!===
+!-
+
+!! ================================================================================================================================
+!! SUBROUTINE   : gather_weather
+!!
+!>\BRIEF        This subroutine determines which points are not in the computational domain and
+!! creates a mask for these points. 
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::var_out
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE gather_weather (iimjjm, nbindex, kindex, var_in, var_out)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+
+  !! 0. Variables and parameters declaration
+
+  !! 0.1 Input variables
+
+  INTEGER,INTENT(IN)                     :: iimjjm,nbindex
+  INTEGER,DIMENSION(iimjjm),INTENT(IN)   :: kindex
+  REAL,DIMENSION(iimjjm),INTENT(IN)      :: var_in
+
+  !! 0.2 Output variables  
+
+  REAL,DIMENSION(iimjjm),INTENT(OUT)     :: var_out
+
+  !! 0.4 Local variables
+
+  INTEGER                                :: i
+  LOGICAL,SAVE                           :: firstcall = .TRUE.
+  INTEGER,SAVE                           :: nb_outside
+  INTEGER,ALLOCATABLE,SAVE,DIMENSION(:)  :: outside
+
+!_ ================================================================================================================================
+
+  IF (firstcall) THEN
+!---
+!-- determine which points are not in the computational domain and
+!-- create a mask for these points
+!---
+    firstcall = .FALSE.
+  
+    ALLOC_ERR=-1
+    ALLOCATE(outside(iimjjm), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of outside : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    outside(:) = zero
+    nb_outside = 0
+    DO i=1,iimjjm
+      IF ( ALL( kindex(:) /= i ) ) THEN
+        nb_outside = nb_outside+1
+        outside(nb_outside) = i
+      ENDIF
+    ENDDO
+  ENDIF
+!-
+  IF ( gathered ) THEN
+    DO i=1,nbindex
+      var_out(i) = var_in(kindex(i))
+    ENDDO
+  ELSE
+    var_out(:) = var_in(:)
+    DO i=1,nb_outside
+      var_out(outside(i)) = undef_sechiba
+    ENDDO
+  ENDIF
+!--------------------
+END SUBROUTINE gather_weather
+!-
+!===
+!-
+
+!! ================================================================================================================================
+!! SUBROUTINE   : shift_shield
+!!
+!>\BRIEF        
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::champ
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE shift_field (im,jm,i_cut,champ)
+!---------------------------------------------------------------------
+
+  !! 0. Variables and parameters declaration
+
+  !! 0.1 Input variables
+
+  INTEGER,INTENT(IN)                  :: im,jm,i_cut
+
+  !! 0.3 Modified variables
+
+  REAL,DIMENSION(im,jm),INTENT(INOUT) :: champ
+
+  !! 0.4 Local variables
+
+  REAL,DIMENSION(im,jm)               :: champ_temp
+
+!_ ================================================================================================================================
+
+  IF ( (i_cut >= 1).AND.(i_cut <= im) ) THEN
+    champ_temp(1:im-i_cut-1,:) = champ(i_cut:im,:)
+    champ_temp(im-i_cut:im,:)  = champ(1:i_cut+1,:)
+    champ(:,:) = champ_temp(:,:)
+  ENDIF
+!-------------------------
+END SUBROUTINE shift_field
+!-
+!===
+!-
+!! ================================================================================================================================
+!! SUBROUTINE   : weathgen_domain_size
+!!
+!>\BRIEF        This subroutine determines the size of the domain.
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::iim, ::jjm, ::limit_west, ::limit_east, ::limit_north, ::limit_south
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE weathgen_domain_size &
+& (limit_west,limit_east,limit_north,limit_south, &
+&  zonal_res,merid_res,iim,jjm)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  !! 0. Variables and parameters declaration
+
+  !! 0.1 Input variables
+
+  REAL,INTENT(IN)     :: zonal_res,merid_res
+
+  !! 0.2 Output variables 
+
+  INTEGER,INTENT(OUT) :: iim,jjm
+
+  !! 0.3 Modified variables
+
+  REAL,INTENT(INOUT)  :: limit_west,limit_east,limit_north,limit_south
+
+!_ ================================================================================================================================
+
+  IF (limit_west > limit_east)  limit_east = limit_east+360.
+!-
+  IF (    (limit_west >= limit_east) &
+ &    .OR.(limit_east > 360.) &
+ &    .OR.(limit_west < -180.) &
+ &    .OR.(limit_east-limit_west > 360.) ) THEN
+    WRITE(numout,*) 'PROBLEME longitudes.'
+    WRITE(numout,*) 'Limites Ouest, Est: ',limit_west,limit_east
+    STOP
+  ENDIF
+!-
+  IF (    (limit_south < -90.) &
+ &    .OR.(limit_north > 90.) &
+ &    .OR.(limit_south >= limit_north ) ) THEN
+    WRITE(numout,*) 'PROBLEME latitudes.'
+    WRITE(numout,*) 'Limites Nord, Sud: ',limit_north,limit_south
+    STOP
+  ENDIF
+!-
+  IF (    (zonal_res <= 0. ) &
+ &    .OR.(zonal_res > limit_east-limit_west) ) THEN
+    WRITE(numout,*) 'PROBLEME resolution zonale.'
+    WRITE(numout,*) 'Limites Ouest, Est, Resolution: ', &
+ &             limit_west,limit_east,zonal_res
+    STOP
+  ENDIF
+!-
+  IF (    (merid_res <= 0.) &
+ &    .OR.(merid_res > limit_north-limit_south) ) THEN
+    WRITE(numout,*) 'PROBLEME resolution meridionale.'
+    WRITE(numout,*) 'Limites Nord, Sud, Resolution: ', &
+ &             limit_north,limit_south,merid_res
+    STOP
+  ENDIF
+!-
+  iim = NINT(MAX((limit_east-limit_west)/zonal_res,1.))
+  jjm = NINT(MAX((limit_north-limit_south)/merid_res,1.))
+!-
+  WRITE(numout,*) 'Domain size: iim, jjm = ', iim, jjm
+!----------------------------------
+END SUBROUTINE weathgen_domain_size
+!-
+!===
+!-
+
+!! ================================================================================================================================
+!! FUNCTION     : tsat1 
+!!
+!>\BRIEF         This function computes the saturated temperature for vapor. 
+!!
+!! DESCRIPTION :  functions tsatl,tsati are used below so that Lowe's
+!!                polyomial for liquid is used if t gt 273.16, or for ice if
+!!                t lt 273.16. also impose range of validity for Lowe's polys.\n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : tsat
+!!
+!! REFERENCE(S) : 
+!! - Lowe PR, 1977, An Approximating Polynomial for the Computation of Saturation
+!! Vapor Pressure, Journal of Applied Meteorology.16,101-103.
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+FUNCTION tsatl (t) RESULT (tsat)
+
+  !! 0. Variables and parameters declaration
+  
+  !! 0.1 Input variables
+
+  REAL,INTENT(IN) :: t
+
+  !! 0.2 Result
+  REAL            :: tsat
+
+!_ ================================================================================================================================
+
+  tsat = MIN(100.,MAX(t-zero_t,zero))
+!-----------------
+END FUNCTION tsatl
+!-
+!===
+!-
+!! ================================================================================================================================
+!! FUNCTION     : tsati 
+!!
+!>\BRIEF         This function computes the saturated temperature for ice. 
+!!
+!! DESCRIPTION :  functions tsatl,tsati are used below so that Lowe's
+!!                polyomial for liquid is used if t gt 273.16, or for ice if
+!!                t lt 273.16. also impose range of validity for Lowe's polys.\n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : tsat
+!!
+!! REFERENCE(S) : 
+!! - Lowe PR, 1977, An Approximating Polynomial for the Computation of Saturation
+!! Vapor Pressure, Journal of Applied Meteorology.16,101-103.
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+FUNCTION tsati (t) RESULT (tsat)
+
+  !! 0. Variables and parameters declaration
+  
+  !! 0.1 Input variables
+
+  REAL,INTENT(IN) :: t
+
+  !! 0.2 Result
+  REAL            :: tsat
+
+!_ ================================================================================================================================
+
+  tsat = MAX(-60.,MIN(t-zero_t,zero))
+
+!-----------------
+END FUNCTION tsati
+!-
+!===
+!-
+
+!! ================================================================================================================================
+!! FUNCTION     : esat
+!!
+!>\BRIEF         This function computes specific humidity with the polynomials of Lowe.
+!!
+!! DESCRIPTION : The function esat is svp in n/m**2, with t in deg k.
+!!               (100 * lowe's poly since 1 mb = 100 n/m**2.). \n
+!!               Polynomials for svp(t), d(svp)/dt over water and ice 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : esatout
+!!
+!! REFERENCE(S) : 
+!! - Lowe PR, 1977, An Approximating Polynomial for the Computation of Saturation
+!! Vapor Pressure, Journal of Applied Meteorology.16,101-103.
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+FUNCTION esat (t) RESULT (esatout)
+
+  !! 0. Variables and parameters declaration
+
+  REAL,PARAMETER :: &                                                    !! polynomials for svp(t), d(svp)/dt over water and ice are from
+ & asat0 = 6.1078000,    asat1 = 4.4365185e-1, asat2 = 1.4289458e-2, &   !! lowe(1977),jam,16,101-103.
+ & asat3 = 2.6506485e-4, asat4 = 3.0312404e-6, asat5 = 2.0340809e-8, &
+ & asat6 = 6.1368209e-11, &
+ & bsat0 = 6.1091780,    bsat1 = 5.0346990e-1, bsat2 = 1.8860134e-2, &
+ & bsat3 = 4.1762237e-4, bsat4 = 5.8247203e-6, bsat5 = 4.8388032e-8, &
+ & bsat6 = 1.8388269e-10
+
+  !! 0.1 Input variables
+
+  REAL,INTENT(IN) :: t
+
+  !! 0.2 Result
+
+  REAL             :: esatout
+
+  !! 0.4 Local variables
+
+  REAL             :: x
+
+!_ ================================================================================================================================
+
+  IF (t >= zero_t) THEN
+    x = asat0
+  ELSE
+    x = bsat0
+  ENDIF
+!-
+  esatout = 100.* &
+    ( x &
+     +tsatl(t)*(asat1+tsatl(t)*(asat2+tsatl(t)*(asat3 &
+     +tsatl(t)*(asat4+tsatl(t)*(asat5+tsatl(t)* asat6))))) &
+     +tsati(t)*(bsat1+tsati(t)*(bsat2+tsati(t)*(bsat3 &
+     +tsati(t)*(bsat4+tsati(t)*(bsat5+tsati(t)* bsat6)))))  )
+!----------------
+END FUNCTION esat
+!-
+!===
+!-
+! ================================================================================================================================
+!! FUNCTION     : qsat
+!!
+!>\BRIEF         This function computes the saturation specific humidity. 
+!!
+!! DESCRIPTION :  statement function qsat is saturation specific humidity,
+!! with svp e and ambient pressure p in n/m**2. impose an upper
+!! limit of 1 to avoid spurious values for very high svp
+!! and/or small p
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : qsatout
+!!
+!! REFERENCE(S) : 
+!! - Lowe PR, 1977, An Approximating Polynomial for the Computation of Saturation
+!! Vapor Pressure, Journal of Applied Meteorology.16,101-103.
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+FUNCTION qsat (e,p) RESULT (qsatout)
+
+  !! 0. Variables and parameters declaration
+
+  !! 0.1 Input variables
+
+  REAL, INTENT(IN) :: e,p
+
+  !! 0.2 Result
+  REAL             :: qsatout
+
+!_ ================================================================================================================================
+
+  qsatout = 0.622*e/MAX(p-(1.0-0.622)*e,0.622*e)
+!----------------
+END FUNCTION qsat
+!-
+!===
+!-
+
+!! ================================================================================================================================
+!! SUBROUTINE   : weathgen_qsat
+!!
+!>\BRIEF        This subroutine calculates the saturation vapor pressure with the polynomials of Lowe. 
+!!
+!! DESCRIPTION  : Vectorized version of functions esat and qsat.
+!!                statement function esat is svp in n/m**2, with t in deg K.\n
+!!               (100 * lowe's poly since 1 mb = 100 n/m**2.)\n
+!!               Polynomials for svp(t), d(svp)/dt over water 
+!!               and ice are from Lowe(1977),jam,16,101-103 \n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::qsat
+!!
+!! REFERENCE(S) :
+!! - Lowe PR, 1977, An Approximating Polynomial for the Computation of Saturation 
+!! Vapor Pressure, Journal of Applied Meteorology.16,101-103.
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE weathgen_qsat (npoi,t,p,qsat)
+
+
+  !! 0. Variables and parameters declaration
+
+ !-
+ ! polynomials for svp(t), d(svp)/dt over water and ice
+ ! are from lowe(1977),ja
+  REAL,PARAMETER :: &
+ & asat0 = 6.1078000,    asat1 = 4.4365185e-1, asat2 = 1.4289458e-2, &   !! polynomials for svp(t), d(svp)/dt over water and ice
+ & asat3 = 2.6506485e-4, asat4 = 3.0312404e-6, asat5 = 2.0340809e-8, &
+ & asat6 = 6.1368209e-11, &
+ & bsat0 = 6.1091780,    bsat1 = 5.0346990e-1, bsat2 = 1.8860134e-2, &
+ & bsat3 = 4.1762237e-4, bsat4 = 5.8247203e-6, bsat5 = 4.8388032e-8, &
+ & bsat6 = 1.8388269e-10
+
+  !! 0.1 Input variables
+
+  INTEGER,INTENT(IN)              :: npoi
+  REAL,DIMENSION(npoi),INTENT(IN) :: t,p
+
+  !! 0.2 Output variables 
+
+  REAL,DIMENSION(npoi),INTENT(OUT):: qsat
+
+  !! 0.4 Local variables
+
+  REAL,DIMENSION(npoi) :: x, tl, ti, e
+
+!_ ================================================================================================================================
+
+  WHERE (t(:) > zero_t)
+    x(:) = asat0
+  ELSEWHERE
+    x(:) = bsat0
+  ENDWHERE
+!-
+  tl(:) = MIN(100.,MAX(t(:)-zero_t,zero))
+  ti(:) = MAX(-60.,MIN(t(:)-zero_t,zero))
+!-
+  e(:) =  100.* &
+    ( x(:) &
+     +tl(:)*(asat1+tl(:)*(asat2+tl(:)*(asat3 &
+     +tl(:)*(asat4+tl(:)*(asat5+tl(:)* asat6))))) &
+     +ti(:)*(bsat1+ti(:)*(bsat2+ti(:)*(bsat3 &
+     +ti(:)*(bsat4+ti(:)*(bsat5+ti(:)* bsat6)))))  )
+!-
+  qsat(:) = 0.622*e(:)/MAX(p(:)-(1.0-0.622)*e(:),0.622*e(:))
+!---------------------------
+END SUBROUTINE weathgen_qsat
+!-
+!===
+!-
+
+!! ================================================================================================================================
+!! SUBROUTINE   : weathgen_qsat_2d
+!!
+!>\BRIEF        This subroutine calculates the saturation vapor pressure with the polynomials of Lowe. 
+!!
+!! DESCRIPTION  : Vectorized version of functions esat and qsat.
+!!                statement function esat is svp in n/m**2, with t in deg K.\n
+!!               (100 * lowe's poly since 1 mb = 100 n/m**2.)\n
+!!               Polynomials for svp(t), d(svp)/dt over water 
+!!               and ice are from Lowe(1977),jam,16,101-103 \n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::qsat
+!!
+!! REFERENCE(S) :
+!! - Lowe PR, 1977, An Approximating Polynomial for the Computation of Saturation 
+!! Vapor Pressure, Journal of Applied Meteorology.16,101-103.
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE weathgen_qsat_2d (iim,jjm,t,p,qsat)
+
+  !! 0. Parameters and variable declaration
+
+  !! 0.1 Input variables
+
+  INTEGER, INTENT(IN) :: iim
+  INTEGER, INTENT(IN) :: jjm
+  REAL,DIMENSION(iim,jjm),INTENT(IN)  :: t,p
+
+   !! 0.2 Output variables
+   REAL,DIMENSION(iim,jjm),INTENT(OUT) :: qsat
+
+   !! 0.4 Local variables
+
+   REAL,DIMENSION(iim,jjm) :: x, tl, ti, e
+
+  REAL,PARAMETER :: &
+ & asat0 = 6.1078000,    asat1 = 4.4365185e-1, asat2 = 1.4289458e-2, &
+ & asat3 = 2.6506485e-4, asat4 = 3.0312404e-6, asat5 = 2.0340809e-8, &
+ & asat6 = 6.1368209e-11, &
+ & bsat0 = 6.1091780,    bsat1 = 5.0346990e-1, bsat2 = 1.8860134e-2, &
+ & bsat3 = 4.1762237e-4, bsat4 = 5.8247203e-6, bsat5 = 4.8388032e-8, &
+ & bsat6 = 1.8388269e-10
+
+!_ ================================================================================================================================
+
+  WHERE (t(:,:) > zero_t)
+    x(:,:) = asat0
+  ELSEWHERE
+    x(:,:) = bsat0
+  ENDWHERE
+!-
+  tl(:,:) = MIN(100.,MAX(t(:,:)-zero_t,0.))
+  ti(:,:) = MAX(-60.,MIN(t(:,:)-zero_t,0.))
+!-
+  e(:,:) =  100.* &
+    ( x(:,:) &
+     +tl(:,:)*(asat1+tl(:,:)*(asat2+tl(:,:)*(asat3 &
+     +tl(:,:)*(asat4+tl(:,:)*(asat5+tl(:,:)* asat6))))) &
+     +ti(:,:)*(bsat1+ti(:,:)*(bsat2+ti(:,:)*(bsat3 &
+     +ti(:,:)*(bsat4+ti(:,:)*(bsat5+ti(:,:)* bsat6)))))  )
+!-
+  qsat(:,:) = 0.622*e(:,:)/MAX(p(:,:)-(1.0-0.622)*e(:,:),0.622*e(:,:))
+!---------------------------
+END SUBROUTINE weathgen_qsat_2d
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : mask_c_o 
+!!
+!>\BRIEF        This subroutine computes a field which indicated if the point is terrestrial or oceanic.
+!!
+!! DESCRIPTION  : From a mask field, we make an indicator mask Earth/ocean. Earth : 1 ; ocean : 0.
+!!
+!! RECENT CHANGE(S): z.x.li,01/04/1994 : creation of the subroutine 
+!!
+!! MAIN OUTPUT VARIABLE(S): ::mask, ::ncorr, ::icorr
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE mask_c_o &
+& (imdep, jmdep, xdata, ydata, mask_in, fcrit, &
+&  imar, jmar, zonal_res, merid_res, n_agg, x, y, mask, &
+&  ncorr, icorr, jcorr)
+
+  !! 0. Variables and parameters declaration
+
+  !! 0.1 Input variables
+
+  INTEGER :: imdep,jmdep
+  REAL :: xdata(imdep),ydata(jmdep)
+  REAL :: mask_in(imdep,jmdep)
+  REAL :: fcrit
+  INTEGER :: imar,jmar
+  REAL :: zonal_res,merid_res
+  INTEGER :: n_agg
+  REAL :: x(imar),y(jmar)
+
+  !! 0.2 Output variables 
+
+  REAL, INTENT(OUT) :: mask(imar,jmar)
+  INTEGER :: ncorr(imar,jmar)
+  INTEGER,DIMENSION(imar,jmar,n_agg) :: icorr,jcorr
+
+  !! 0.4 Local variables 
+
+  INTEGER i, j, ii, jj
+  REAL a(imar),b(imar),c(jmar),d(jmar)
+  INTEGER num_tot(imar,jmar), num_oce(imar,jmar)
+  REAL,ALLOCATABLE :: distans(:)
+  INTEGER ij_proche(1),i_proche,j_proche
+!-
+  INTEGER,DIMENSION(imar,jmar) :: ncorr_oce , ncorr_land
+  INTEGER,DIMENSION(imar,jmar,n_agg) :: &
+ &  icorr_oce, jcorr_oce , icorr_land, jcorr_land
+!-
+  INTEGER imdepp
+  REAL,ALLOCATABLE :: xdatap(:)
+  REAL,ALLOCATABLE :: mask_inp(:,:)
+  LOGICAL :: extend
+
+!_ ================================================================================================================================
+
+  ncorr(:,:) = 0
+  icorr(:,:,:) = -1; jcorr(:,:,:) = -1
+  ncorr_land(:,:) = 0
+  icorr_land(:,:,:) = -1; jcorr_land(:,:,:) = -1
+  ncorr_oce(:,:) = 0
+  icorr_oce(:,:,:) = -1; jcorr_oce(:,:,:) = -1
+! do we have to extend the domain (-x...-x+360)?
+  IF ( xdata(1)+360.-xdata(imdep) > 0.01 ) THEN
+    extend = .TRUE.
+    imdepp = imdep+1
+  ELSE
+    extend = .FALSE.
+    imdepp = imdep
+  ENDIF
+!-
+
+  ALLOC_ERR=-1
+  ALLOCATE(xdatap(imdepp), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of xdatap : ",ALLOC_ERR
+    STOP 
+  ENDIF
+
+  ALLOC_ERR=-1
+  ALLOCATE(mask_inp(imdepp,jmdep), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of mask_inp : ",ALLOC_ERR
+    STOP 
+  ENDIF
+!-
+  xdatap(1:imdep) = xdata(1:imdep)
+  mask_inp(1:imdep,:) = mask_in(1:imdep,:)
+!-
+  IF (extend) THEN
+    xdatap(imdepp) = xdatap(1)+360.
+    mask_inp(imdepp,:) = mask_inp(1,:)
+  ENDIF
+!-
+
+  ALLOC_ERR=-1
+  ALLOCATE(distans(imdepp*jmdep), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+    WRITE(numout,*) "ERROR IN ALLOCATION of distans : ",ALLOC_ERR
+    STOP 
+  ENDIF
+! Definition des limites des boites de la grille d'arrivee.
+  IF (imar > 1) THEN
+    a(1) = x(1)-(x(2)-x(1))/2.0
+    b(1) = (x(1)+x(2))/2.0
+    DO i=2,imar-1
+      a(i) = b(i-1)
+      b(i) = (x(i)+x(i+1))/2.0
+    ENDDO
+    a(imar) = b(imar-1)
+    b(imar) = x(imar)+(x(imar)-x(imar-1))/2.0
+  ELSE
+    a(1) = x(1)-zonal_res/2.
+    b(1) = x(1)+zonal_res/2.
+  ENDIF
+!-
+  IF (jmar > 1) THEN
+    c(1) = y(1)-(y(2)-y(1))/2.0
+    d(1) = (y(1)+y(2))/2.0
+    DO j=2,jmar-1
+      c(j) = d(j-1)
+      d(j) = (y(j)+y(j+1))/2.0
+    ENDDO
+    c(jmar) = d(jmar-1)
+    d(jmar) = y(jmar)+(y(jmar)-y(jmar-1))/2.0
+  ELSE
+    c(1) = y(1)-merid_res/2.
+    d(1) = y(1)+merid_res/2.
+  ENDIF
+!-
+  num_oce(1:imar,1:jmar) = 0
+  num_tot(1:imar,1:jmar) = 0
+!-
+!  .....  Modif  P. Le Van ( 23/08/95 )  ....
+!-
+  DO ii=1,imar
+    DO jj=1,jmar
+      DO i=1,imdepp
+        IF (    (     (xdatap(i)-a(ii) >= 1.e-5) &
+ &               .AND.(xdatap(i)-b(ii) <= 1.e-5) ) &
+ &          .OR.(     (xdatap(i)-a(ii) <= 1.e-5) &
+ &               .AND.(xdatap(i)-b(ii) >= 1.e-5) ) ) THEN
+          DO j=1,jmdep
+            IF (    (     (ydata(j)-c(jj) >= 1.e-5) &
+ &                   .AND.(ydata(j)-d(jj) <= 1.e-5) ) &
+ &              .OR.(     (ydata(j)-c(jj) <= 1.e-5) &
+ &                   .AND.(ydata(j)-d(jj) >= 1.e-5) ) ) THEN
+              num_tot(ii,jj) = num_tot(ii,jj)+1
+              IF (mask_inp(i,j) < 0.5) THEN
+                num_oce(ii,jj) = num_oce(ii,jj)+1
+!-------------- on a trouve un point oceanique. On le memorise.
+                ncorr_oce(ii,jj) = ncorr_oce(ii,jj)+1
+                IF ((i == imdepp).AND.extend) THEN
+                  icorr_oce(ii,jj,ncorr_oce(ii,jj)) = 1
+                ELSE
+                  icorr_oce(ii,jj,ncorr_oce(ii,jj)) = i
+                ENDIF
+                jcorr_oce(ii,jj,ncorr_oce(ii,jj)) = j
+              ELSE
+!-------------- on a trouve un point continental. On le memorise.
+                ncorr_land(ii,jj) = ncorr_land(ii,jj)+1
+                IF ((i == imdepp).AND.extend) THEN
+                  icorr_land(ii,jj,ncorr_land(ii,jj)) = 1
+                ELSE
+                  icorr_land(ii,jj,ncorr_land(ii,jj)) = i
+                ENDIF
+                jcorr_land(ii,jj,ncorr_land(ii,jj)) = j
+              ENDIF
+            ENDIF
+          ENDDO
+        ENDIF
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  DO i=1,imar
+    DO j=1,jmar
+      IF (num_tot(i,j) > 0) THEN
+        IF (    (     (num_oce(i,j) == 0) &
+ &               .AND.(num_tot(i,j) > 0) ) &
+ &          .OR.(     (num_oce(i,j) > 0) &
+ &               .AND.(   REAL(num_oce(i,j)) &
+ &                     <= REAL(num_tot(i,j))*(1.-fcrit) ) ) ) THEN
+          mask(i,j) = un
+          ncorr(i,j) = ncorr_land(i,j)
+          icorr(i,j,:) = icorr_land(i,j,:)
+          jcorr(i,j,:) = jcorr_land(i,j,:)
+        ELSE
+          mask(i,j) = zero
+          ncorr(i,j) = ncorr_oce(i,j)
+          icorr(i,j,:) = icorr_oce(i,j,:)
+          jcorr(i,j,:) = jcorr_oce(i,j,:)
+        ENDIF
+      ELSE
+        CALL dist_sphe(x(i),y(j),xdatap,ydata,imdepp,jmdep,distans)
+        ij_proche(:) = MINLOC(distans)
+        j_proche = (ij_proche(1)-1)/imdepp+1
+        i_proche = ij_proche(1)-(j_proche-1)*imdepp
+        mask(i,j) = mask_inp(i_proche,j_proche)
+        IF ( (i_proche == imdepp).AND.extend)  i_proche=1
+        ncorr(i,j) = 1
+        icorr(i,j,1) = i_proche
+        jcorr(i,j,1) = j_proche
+      ENDIF
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE mask_c_o
+!-
+!===
+!-
+!! ================================================================================================================================
+!! SUBROUTINE   : dist_sphe
+!!
+!>\BRIEF        This subroutine computes the minimum distance between two points on Earth
+!! according the great circle. \n
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): Laurent Li, 30/12/1996 : creation of this subroutine
+!!
+!! MAIN OUTPUT VARIABLE(S): ::distance
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE dist_sphe (rf_lon,rf_lat,rlon,rlat,im,jm,distance)
+
+  !! 0. Variables and parameters declaration
+
+  !! 0.1 Input variables
+
+  INTEGER :: im, jm    !! dimensions
+  REAL    :: rf_lon       !! longitude of the referenced point (degrees)
+  REAL    :: rf_lat       !! latitude of the referenced point (degrees)
+  REAL    :: rlon(im), rlat(jm) !! longitude and latitude of points
+
+  !! 0.2 Output variables
+
+  REAL :: distance(im,jm) !! distances in meters (m)
+
+  !! 0.4 Local variables
+
+  REAL :: rlon1, rlat1
+  REAL :: rlon2, rlat2
+  REAL :: dist
+  REAL :: pa, pb, p
+  INTEGER :: i,j
+
+!_ ================================================================================================================================
+
+  DO j=1,jm
+    DO i=1,im
+      rlon1=rf_lon
+      rlat1=rf_lat
+      rlon2=rlon(i)
+      rlat2=rlat(j)
+      pa = pi/2.0-rlat1*pir ! dist. entre pole n et point a
+      pb = pi/2.0-rlat2*pir ! dist. entre pole n et point b
+!-----
+      p = (rlon1-rlon2)*pir ! angle entre a et b (leurs meridiens)
+!-----
+      dist = ACOS( COS(pa)*COS(pb)+SIN(pa)*SIN(pb)*COS(p))
+      dist = R_Earth*dist      
+      distance(i,j) = dist
+    ENDDO
+  ENDDO
+!-----------------------
+END SUBROUTINE dist_sphe
+!-
+!===
+!-
+
+!! ================================================================================================================================
+!! SUBROUTINE   : permute
+!!
+!>\BRIEF         This subroutine initializes an array of size n by random integers between 1 and n.  
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::ordre
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE permute (n,ordre)
+!---------------------------------------------------------------------
+
+  !! 0. Variables and parameters declaration 
+
+  !! 0.1 Input variables
+
+  INTEGER,INTENT(IN) :: n   !! size of the array
+
+  !! 0.2 Output variables 
+
+  INTEGER,DIMENSION(n),INTENT(OUT) :: ordre
+
+  !! 0.4 Local variables
+
+  INTEGER,DIMENSION(n) :: restant
+  INTEGER :: ipique, i, n_rest
+  REAL    :: rndnum
+
+!_ ================================================================================================================================
+
+  n_rest = n
+  restant(:) = (/ (i, i=1,n) /)
+!-
+  DO i=1,n
+    CALL random_number (rndnum)
+    ipique = INT(rndnum*n_rest)+1
+    ordre(i) = restant(ipique)
+    restant(ipique:n_rest-1) = restant(ipique+1:n_rest)
+    n_rest = n_rest-1
+  ENDDO
+!---------------------
+END SUBROUTINE permute
+!-
+!===
+!-----------------
+END MODULE weather
Index: branches/publications/ORCHIDEE_CAN_NHA/src_global/AA_make
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_global/AA_make	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_global/AA_make	(revision 7236)
@@ -0,0 +1,69 @@
+#-
+#- $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  \
+	gauss_jordan_method.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
+	$(A_C) $(ORCHIDEE_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.o)
+
+$(MODEL_LIB)(gauss_jordan_method.o): \
+  $(PARAM_LIB)(constantes.o)
Index: branches/publications/ORCHIDEE_CAN_NHA/src_global/AA_make.ldef
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_global/AA_make.ldef	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_global/AA_make.ldef	(revision 7236)
@@ -0,0 +1,19 @@
+#-
+#- $Id$
+#-
+#---------------------------------------------------------------------
+#- Creation des elements relatifs a ORGLOB
+#---------------------------------------------------------------------
+SHELL = /bin/sh
+#---------------------------------------------------------------------
+LIBDIR = ../../../lib
+BINDIR = ../../../bin
+MODDIR = $(LIBDIR)
+#---------------------------------------------------------------------
+ORCHIDEE_LIB = $(LIBDIR)/liborchidee.a
+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: branches/publications/ORCHIDEE_CAN_NHA/src_global/gauss_jordan_method.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_global/gauss_jordan_method.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_global/gauss_jordan_method.f90	(revision 7236)
@@ -0,0 +1,244 @@
+! =================================================================================================================================
+! MODULE       : matrix_resolution
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2011)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         This module solves a linear system using the Gauss-Jordan elimination method. It also calculates relative errors
+!! globally and for the passive pools.        
+!! 
+!!
+!!\n DESCRIPTION:  This module solves a linear system AX = B with the Gauss Jordan elimination method
+!!                 (chosen because the system has no particular properties). \n
+!!                 The code has originally picked up in Numerical recipes in Fortran 90. \n
+!!                 We simplified the code in our case because we solve a basic (7,7) matrix for each point and each pft
+!!                 (so we have npts*nvm*(7,7) systems to solve each time we call this routine). \n
+!!                 We also calculate relative for biomass and passive carbon pools in order to test the threshold error. \n
+!!
+!! RECENT CHANGE(S): Didier Solyga - add subroutine for calculating relative error for passive pool.
+!!
+!! REFERENCE(S)	: None
+!!
+!! SVN          :
+!! $HeadURL: $
+!! $Date: $
+!! $Revision:  $
+!! \n
+!_ ================================================================================================================================
+
+MODULE matrix_resolution
+
+  ! modules used 
+
+  USE ioipsl ! for precision
+  USE constantes
+
+  IMPLICIT NONE
+
+  CONTAINS
+    
+
+!! ================================================================================================================================
+!! SUBROUTINE   : gauss-jordan_method 
+!!
+!>\BRIEF          This subroutine resolves a linear system by the Gauss-Jordan method.
+!! (inversion of the system - complexity O(n^3)) .
+!!
+!! DESCRIPTION  : 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): vector_b contains the solution of the system.
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+    SUBROUTINE gauss_jordan_method(n,matrix_a,vector_b)
+
+      IMPLICIT NONE
+
+      !! 0. Variables and parameters declaration    
+
+      !! 0.1 Input variables 
+ 
+      INTEGER(i_std), INTENT(in) :: n  !! size of the system (1-N, unitless)
+
+      !! 0.3 Modified variables
+
+      REAL(r_std), DIMENSION(n,n), INTENT(inout) :: matrix_a   !! Matrix A of the linear system A.X = B
+      REAL(r_std), DIMENSION(n), INTENT(inout)   :: vector_b   !! Vector B in the linear system A.X = B
+      
+      !! 0.4 Local Variables
+
+      INTEGER(r_std) :: i,col,row,j,k,ii,jj        !! index (uniltess)
+      INTEGER(i_std), DIMENSION(n) :: index_pivot  !! vector containing the pivot index
+      INTEGER(i_std), DIMENSION(n) :: index_col    !! vector containing the columns index
+      INTEGER(i_std), DIMENSION(n) :: index_row    !! vector containing the rows index
+      REAL(r_std) :: pivot_max,inv_pivot,temp      !! temporary variables
+      
+!_ ================================================================================================================================
+      
+      !! Initialization
+      index_pivot(:) = 0
+      
+      !! Search the pivot (strategy of full pivoting)
+      !! We search the greatest pivot (in order to reduce errors)
+      DO i = 1,n     
+         pivot_max = 0.
+         DO  j = 1,n
+            IF(index_pivot(j) /= 1) THEN
+               DO k = 1,n
+                  IF(index_pivot(k) .EQ. 0) THEN
+                     IF(ABS(matrix_a(j,k)) .GE. pivot_max) THEN  
+                        pivot_max = ABS(matrix_a(j,k))           
+                        row = j
+                        col = k
+                     ENDIF
+                  ENDIF
+               ENDDO
+            ENDIF
+         ENDDO
+         index_pivot(col)=index_pivot(col) + 1
+
+         !! We exchange the rows and the lines if needed
+         IF(row /= col) THEN
+            DO j = 1,n
+               temp = matrix_a(row,j)
+               matrix_a(row,j) = matrix_a(col,j)
+               matrix_a(col,j) = temp
+            ENDDO
+            temp = vector_b(row)
+            vector_b(row) = vector_b(col)
+            vector_b(col) = temp
+         ENDIF
+         index_row(i) = row
+         index_col(i) = col
+         IF(matrix_a(col,col) .EQ. 0.) THEN
+            WRITE(numout,*) 'Column is zero ',col
+            WRITE(numout,*) matrix_a(:,col)
+            DO j=1,n
+               WRITE(numout,*) 'ijfe ',matrix_a(j,:)
+            ENDDO
+            STOP 'the matrix A is not inversible'
+         ENDIF
+         inv_pivot = 1./matrix_a(col,col)
+         DO j = 1,n
+            matrix_a(col,j) = matrix_a(col,j) * inv_pivot 
+         ENDDO
+         vector_b(col) = vector_b(col) * inv_pivot
+         DO ii = 1,n
+            IF(ii /= col) THEN
+               temp = matrix_a(ii,col)
+               matrix_a(ii,col) = 0.
+               DO jj = 1,n
+                  matrix_a(ii,jj) = matrix_a(ii,jj) - matrix_a(col,jj)*temp
+               ENDDO
+               vector_b(ii) = vector_b(ii) - vector_b(col)*temp
+            ENDIF
+         ENDDO
+      ENDDO
+      
+      DO j = n,1,-1
+         IF(index_row(j) /= index_col(j)) THEN
+            DO i = 1,n
+               temp = matrix_a(i,index_row(j))
+               matrix_a(i,index_row(j)) = matrix_a(i,index_col(j)) 
+               matrix_a(i,index_col(j)) = temp
+          ENDDO
+       ENDIF
+    ENDDO
+    
+    
+  END SUBROUTINE gauss_jordan_method
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : error_L1_passive
+!!
+!>\BRIEF          This subroutine calculates relative errors of a vector by taking the relative error for the passive pool.
+!!
+!! DESCRIPTION  : 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): flag is to true if the maximum relative error is less than a threshold chosen by the user.
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+ SUBROUTINE error_L1_passive(npts,nb_veget, nb_pools, current_value, previous_value, veget_max, criterion, flag)
+  
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+    
+    !! 0.1 Input variables    
+    
+    INTEGER(i_std), INTENT(in) :: npts                                             !! Number of continental grid cells (unitless)
+    INTEGER(i_std), INTENT(in) :: nb_veget                                         !! Number of vegetation types (2-N, unitless)
+    INTEGER(i_std), INTENT(in) :: nb_pools                                         !! Number of carbon pools (unitless)
+    REAL(r_std), DIMENSION(npts,nb_veget,nb_pools), INTENT(in) :: current_value    !! Previous values of carbon pools obtained
+                                                                                   !! by matrix resolution (gC.m^{-2})
+    REAL(r_std), DIMENSION(npts,nb_veget,nb_pools), INTENT(in) :: previous_value   !! Current values of carbon pools  obtained
+                                                                                   !! by matrix resolution (gC.m^{-2})   
+    REAL(r_std), DIMENSION(npts,nb_veget), INTENT(in) :: veget_max                 !! Fraction of vegetation (0-1, uniless)
+    REAL(r_std), INTENT(in) :: criterion                                           !! Threshold for the relativ error (0-1, unitless) 
+    
+    !! 0.2 Output variables
+    
+    LOGICAL, DIMENSION(npts), INTENT(out) :: flag   !! Logical array used only inside this subroutine (true/false)
+    
+    !! 0.4 Local variables
+    
+    INTEGER(i_std) :: j                                      !! Index (unitless)
+    REAL(r_std), DIMENSION(npts) :: previous_passive_stock   !! Previous value of total passive carbon (gC) 
+    REAL(r_std), DIMENSION(npts) :: current_passive_stock    !! Current value of total passive carbon (gC)
+    REAL(r_std), DIMENSION(npts) :: error_global             !! Temporary arrays containing the relative error for each grid cell 
+                                                             !! (unitless)         
+    REAL(r_std), DIMENSION(npts) :: temp_diff                !! Working array storing difference values between previous_passive_stock
+                                                             !! and current_passive_stock (gC)
+
+!_ ================================================================================================================================
+
+    !! Initialize flag and error_global
+    flag(:) = .FALSE.
+    error_global(:) = zero
+
+    !! Calculation previous_passive_stock
+    previous_passive_stock(:) = zero
+    DO j = 1, nb_veget
+       previous_passive_stock(:) = previous_passive_stock(:) + previous_value(:,j,ipassive_pool)*veget_max(:,j)
+    ENDDO
+
+    !! Calculation current_passive_stock
+    current_passive_stock(:) = zero
+    DO j = 1, nb_veget
+       current_passive_stock(:) = current_passive_stock(:) + current_value(:,j,ipassive_pool)*veget_max(:,j)
+    ENDDO
+    
+    !! We calculate for the error for the passive pool for each pixel
+    temp_diff(:) = zero
+    temp_diff(:) =  current_passive_stock(:) - previous_passive_stock(:) 
+    WHERE ( previous_passive_stock(:) >  min_stomate )
+       error_global(:) = 100.*ABS(temp_diff(:))/previous_passive_stock(:) 
+    ELSEWHERE
+       error_global(:) = ABS(temp_diff(:))
+    ENDWHERE
+
+    !! if the criterion is reached, we can mark the point 
+    WHERE (error_global(:) <= criterion)
+       flag = .TRUE.
+    ENDWHERE
+       
+  END SUBROUTINE error_L1_passive       
+
+
+END MODULE matrix_resolution
Index: branches/publications/ORCHIDEE_CAN_NHA/src_global/grid.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_global/grid.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_global/grid.f90	(revision 7236)
@@ -0,0 +1,596 @@
+! =================================================================================================================================
+! MODULE       : grid
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         This module define variables for the grid to gathered points.
+!!
+!!\n DESCRIPTION: 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	: None
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE grid
+
+  USE defprec
+  USE constantes
+  USE mod_orchidee_para
+
+  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 = .TRUE.
+!$OMP THREADPRIVATE(global)
+  !
+  !-
+  !- 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
+!$OMP THREADPRIVATE(limit_west, limit_east, limit_north, limit_south)
+  !-
+  !! Geographical coordinates
+  REAL(r_std), ALLOCATABLE, DIMENSION (:,:), SAVE     :: lalo
+!$OMP THREADPRIVATE(lalo)
+  !! index  of land points
+  INTEGER, ALLOCATABLE, DIMENSION (:), SAVE          :: ilandindex,jlandindex
+!$OMP THREADPRIVATE(ilandindex, jlandindex)
+  !- 
+  !! Fraction of continents.
+  REAL(r_std), ALLOCATABLE, DIMENSION (:), SAVE       :: contfrac
+!$OMP THREADPRIVATE(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
+!$OMP THREADPRIVATE(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
+!$OMP THREADPRIVATE(resolution)
+  REAL(r_std), DIMENSION(2), SAVE :: min_resol,max_resol
+!$OMP THREADPRIVATE(min_resol, max_resol)
+  REAL(r_std), ALLOCATABLE, DIMENSION (:), SAVE     :: area
+!$OMP THREADPRIVATE(area)
+  !
+  !
+  ! Get the direction of the grid
+  !
+  CHARACTER(LEN=2), DIMENSION(2), SAVE, PRIVATE      :: grid_dir
+!$OMP THREADPRIVATE(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
+!$OMP THREADPRIVATE(rose)
+  !
+  ! The calendar
+  CHARACTER(LEN=20), SAVE         :: calendar_str
+!$OMP THREADPRIVATE(calendar_str)
+  !
+  ! The date
+  REAL(r_std), SAVE                     :: in_julian
+!$OMP THREADPRIVATE(in_julian)
+  ! Diff with day 0
+  REAL(r_std), SAVE                     :: julian_diff
+!$OMP THREADPRIVATE(julian_diff)
+  !
+  INTEGER(i_std), SAVE                  :: year, month, day
+!$OMP THREADPRIVATE(year, month, day)
+  REAL(r_std), SAVE                     :: sec
+!$OMP THREADPRIVATE(sec)
+  !
+  ! month_len (d)
+  INTEGER(i_std), SAVE                  :: month_len
+!$OMP THREADPRIVATE(month_len)
+  !
+  ! year length (d)
+  INTEGER(i_std), SAVE            :: year_length=0
+!$OMP THREADPRIVATE(year_length)
+  !
+  ! Ration between calendar year in days (ie 360d or 365d ...) to gregorian year length 
+  REAL(r_std), SAVE :: year_spread
+!$OMP THREADPRIVATE(year_spread)
+  !
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE   : init_grid
+!!
+!>\BRIEF         
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE init_grid ( npts )
+
+    IMPLICIT NONE
+
+    !! 0. Parameter and variables declaration
+    
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in) :: npts  !! Domain size : 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
+!!
+!>\BRIEF         
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE grid_stuff (npts_glo, iim, jjm, grid_lon, grid_lat, kindex)
+
+    IMPLICIT NONE
+
+    !! 0. Parameter and variables declaration
+    
+    !! 0.1 Input variables
+    
+    INTEGER(i_std), INTENT(in)                  :: npts_glo                               !! Domain size
+    INTEGER(i_std), INTENT(in)                  :: iim, jjm                               !! Size of cartesian grid
+    REAL(r_std), DIMENSION(iim,jjm), INTENT(in) :: grid_lon                               !! Longitudes on cartesian grid
+    REAL(r_std), DIMENSION(iim,jjm), INTENT(in) :: grid_lat                               !! Latitudes on cartesian grid
+    INTEGER(i_std), DIMENSION(:), INTENT(in)    :: kindex                                 !! Index of land point on 2D map (in local position)
+
+    !! 0.4 Local variables
+
+    INTEGER, ALLOCATABLE, DIMENSION (:)         :: index_p                                !! Index of land point on 2D map (in global position)
+    INTEGER(i_std), DIMENSION(iim,jjm)          :: correspondance                         !! which STOMATE point corresponds to 
+                                                                                          !! the given point on the cartesian grid
+    REAL(r_std)                                 :: coslat                                 !! cosine of the latitude
+    INTEGER(i_std)                              :: ndefault_lon, ndefault_lat             !! number of points where default resolution is used
+    INTEGER(i_std)                              :: i,ip,jp, imm1, imp1, imm1l, imp1l, ii  !! Indices
+    INTEGER(i_std), SAVE                        :: bavard = 2                             !!
+!$OMP THREADPRIVATE(bavard)
+    
+!_ ================================================================================================================================
+    
+    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.
+          ELSE
+             global = .FALSE.
+          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. ), mincos )     
+          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: branches/publications/ORCHIDEE_CAN_NHA/src_global/interpol_help.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_global/interpol_help.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_global/interpol_help.f90	(revision 7236)
@@ -0,0 +1,1000 @@
+! =================================================================================================================================
+! MODULE       : interpol_help
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         This module contains aggregation routines.
+!!
+!!\n DESCRIPTION: 
+! 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.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	: None
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE interpol_help
+
+  ! Modules used :
+
+  USE constantes
+  USE mod_orchidee_para
+
+  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
+  !
+  LOGICAL, PARAMETER                              :: check_grid=.FALSE.
+  !
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE   : aggregate_2d
+!!
+!>\BRIEF          This routine 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.
+!!
+!! DESCRIPTION  : 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+
+  SUBROUTINE aggregate_2d (nbpt, lalo, neighbours, resolution, contfrac, &
+       &                iml, jml, lon_rel, lat_rel, mask, callsign, &
+       &                incmax, indinc, areaoverlap, ok)
+
+    USE grid, ONLY : global
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    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 !)
+    INTEGER(i_std), DIMENSION(nbpt,8), INTENT(in)          :: neighbours     !! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
+    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 land in each grid box.
+    INTEGER(i_std), INTENT(in)                             :: iml, jml       !! Size of the finer grid
+    REAL(r_std), DIMENSION(iml,jml), INTENT(in)            :: lon_rel        !! Longitudes for the finer grid
+    REAL(r_std), DIMENSION(iml,jml), INTENT(in)            :: lat_rel        !! Latitudes for the finer grid
+    INTEGER(i_std), DIMENSION(iml,jml), INTENT(in)         :: mask           !! 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.
+
+    !! 0.2 Output variables
+
+    INTEGER(i_std), DIMENSION(nbpt,incmax,2), INTENT(out)  :: indinc         !!
+    REAL(r_std), DIMENSION(nbpt,incmax), INTENT(out)       :: areaoverlap    !!
+    LOGICAL, OPTIONAL, INTENT(out)                         :: ok             !! return code
+
+    !! 0.4 Local Variables
+
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)               :: lat_ful        !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)               :: lon_ful        !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)               :: loup_rel       !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)               :: lolow_rel      !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)               :: laup_rel       !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)               :: lalow_rel      !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)            :: searchind      !! 
+    REAL(r_std)                                            :: lon_up         !!
+    REAL(r_std)                                            :: lon_low        !!
+    REAL(r_std)                                            :: lat_up         !!
+    REAL(r_std)                                            :: lat_low        !!
+    REAL(r_std)                                            :: coslat         !!
+    REAL(r_std)                                            :: ax, ay         !!
+    REAL(r_std)                                            :: sgn            !!
+    REAL(r_std)                                            :: lonrel         !!
+    REAL(r_std)                                            :: lolowrel       !!
+    REAL(r_std)                                            :: louprel        !!
+    INTEGER(i_std)                                         :: fopt           !!
+    INTEGER(i_std)                                         :: fopt_max       !! 
+    INTEGER(i_std)                                         :: ip, jp, ib, i  !!
+    INTEGER(i_std)                                         :: itmp           !!
+    INTEGER(i_std)                                         :: iprog          !! 
+    INTEGER(i_std)                                         :: nbind          !!
+    REAL(r_std)                                            :: domain_minlon  !! 
+    REAL(r_std)                                            :: domain_maxlon  !!  
+    REAL(r_std)                                            :: domain_minlat  !!
+    REAL(r_std)                                            :: domain_maxlat  !!
+    INTEGER(i_std), DIMENSION(1)                           :: minLon         !!
+    INTEGER(i_std), DIMENSION(1)                           :: maxLon         !!
+    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)
+!    WRITE(6,*) 'jifoez lat_rel(1,jml),jml',lat_rel(1,jml),jml
+    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_aggregate_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 ( global ) THEN
+       ! Here we do the entire globe
+       WRITE(numout,*) 'In aggregate_p : do interpolation to global model domain'
+       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
+       WRITE(numout,*) 'In aggregate_p : do interpolation to regional model domain'
+       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, lalo(ib,2), lalo(ib,1)
+          CALL ipslerr_p(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
+    !
+    DO ib=1,nbpt
+       DO fopt=1,incmax
+          IF (( indinc(ib,fopt,1) == 0 .AND. indinc(ib,fopt,2) > 0) .OR.&
+               & ( indinc(ib,fopt,2) == 0 .AND. indinc(ib,fopt,1) > 0) ) THEN
+             WRITE(*,*) "aggregate_2d PROBLEM : point =",ib, fopt," Indicies = ", &
+                  & indinc(ib,fopt,1), indinc(ib,fopt,2), areaoverlap(ib,fopt)
+          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
+
+!! ================================================================================================================================
+!! SUBROUTINE   : aggregate_vec
+!!
+!>\BRIEF         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.
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE aggregate_vec (nbpt, lalo, neighbours, resolution, contfrac, &
+       &                iml, lon_rel, lat_rel, resol_lon, resol_lat, callsign, &
+       &                incmax, indinc, areaoverlap, ok)
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    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 !)
+    INTEGER(i_std), DIMENSION(nbpt,8), INTENT(in)          :: neighbours     !! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
+    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 land in each grid box.
+    INTEGER(i_std), INTENT(in)                             :: iml            !! Size of the finer grid
+    REAL(r_std), DIMENSION(iml), INTENT(in)                :: lon_rel        !! Longitudes for the finer grid
+    REAL(r_std), DIMENSION(iml), INTENT(in)                :: lat_rel        !! 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.
+
+    !! 0.2 Output variables
+
+    INTEGER(i_std), DIMENSION(nbpt,incmax), INTENT(out)    :: indinc         !!
+    REAL(r_std), DIMENSION(nbpt,incmax), INTENT(out)       :: areaoverlap    !!
+    LOGICAL, OPTIONAL, INTENT(out)                         :: ok             !! return code
+
+    !! 0.4 Local Variables
+
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)              :: searchind      !! 
+    REAL(r_std)                                            :: lon_up         !!
+    REAL(r_std)                                            :: lon_low        !!
+    REAL(r_std)                                            :: lat_up         !!
+    REAL(r_std)                                            :: lat_low        !!
+    REAL(r_std)                                            :: coslat         !!
+    REAL(r_std)                                            :: ax, ay         !!
+    REAL(r_std)                                            :: sgn            !!
+    REAL(r_std)                                            :: lonrel         !!
+    REAL(r_std)                                            :: lolowrel       !!
+    REAL(r_std)                                            :: louprel        !!
+
+    REAL(r_std)                                            :: latrel         !!
+    REAL(r_std)                                            :: lalowrel       !!
+    REAL(r_std)                                            :: lauprel        !!
+    INTEGER(i_std), DIMENSION(nbpt)                        :: fopt           !!
+    INTEGER(i_std)                                         :: fopt_max       !!
+    INTEGER(i_std)                                         :: not_found_fopt !! 
+    INTEGER(i_std)                                         :: ip, jp, ib, i  !!
+    INTEGER(i_std)                                         :: itmp           !!
+    INTEGER(i_std)                                         :: iprog          !! 
+    INTEGER(i_std)                                         :: nbind          !!
+    INTEGER(i_std)                                         :: pp, ipp        !!
+    REAL(r_std)                                            :: domain_minlon  !! 
+    REAL(r_std)                                            :: domain_maxlon  !!  
+    REAL(r_std)                                            :: domain_minlat  !!
+    REAL(r_std)                                            :: domain_maxlat  !!
+    REAL(r_std)                                            :: minlon         !!
+    REAL(r_std)                                            :: minlat         !!
+    REAL(r_std)                                            :: mini           !!
+    INTEGER(i_std), DIMENSION(1)                           :: ff             !!
+    INTEGER(i_std)                                         :: incp           !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)            :: fine_ind       !!
+    INTEGER(i_std), DIMENSION(5)                           :: pos_pnt        !!
+    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)
+    !
+    ! Find appropriate resolution for index table
+    !
+    ff=MINLOC(resolution(:,1))
+    coslat = MAX(COS(lalo(ff(1),1) * pi/180. ), mincos )*pi/180. * R_Earth
+    minlon=resolution(ff(1),1)/(2.0*coslat)
+    ff=MINLOC(resolution(:,2))
+    coslat = pi/180. * R_Earth
+    minlat=resolution(ff(1),2)/(2.0*coslat)
+    mini=MIN(minlon, minlat)
+    !
+    ! This interpolation only works if the model grid is coarser than the data grid
+    !
+    IF (MINVAL(resolution(:,1)) < resol_lon .OR. MINVAL(resolution(:,2)) < resol_lat) THEN
+       WRITE(numout,*) " === WARNING == "
+       WRITE(numout,*) "Resolution minima of the model (lon, lat) : ", &
+            & MINVAL(resolution(:,1)), MINVAL(resolution(:,2))
+       WRITE(numout,*) "Resolution of the file to be interpolated (fine grid) : ", resol_lon, resol_lat
+       WRITE(numout,*) "This interpolation assumes that we aggregate from a fine grid to a coarser grid"
+       WRITE(numout,*) "In the data submitted it apears that the model is runing on a finer grid than the data"
+    ENDIF
+    !
+    incp = 10
+    IF (mini < 0.1) THEN
+       incp=100
+    ELSE IF (mini < 0.01) THEN
+       incp = 1000
+    ENDIF
+    !
+    ! Allocate the needed memory for fine_ind
+    !
+    ALLOC_ERR=-1
+    ALLOCATE (fine_ind(NINT(domain_minlon*incp)-2:NINT(domain_maxlon*incp)+2, &
+         & NINT(domain_minlat*incp)-2:NINT(domain_maxlat*incp)+2), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "aggregate_vec : ERROR IN ALLOCATION of fine_ind : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    !
+    ! Generate a quick access table for the coarse grid
+    !
+    fine_ind(:,:) = zero
+    !
+    DO ib=1,nbpt
+       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) 
+       !
+       fine_ind(NINT(lon_low*incp):NINT(lon_up*incp),NINT(lat_low*incp):NINT(lat_up*incp))=ib
+       !
+    ENDDO
+    !
+    WRITE(numout,*) 'Domaine LON range : ', domain_minlon, domain_maxlon
+    WRITE(numout,*) 'Domaine LAT range : ', domain_minlat, domain_maxlat
+    !
+    ! 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 = MIN(lon_rel(ip) + resol_lon/(2.0*coslat), 180.)
+          lolowrel = MAX(lon_rel(ip) - resol_lon/(2.0*coslat), -180.)
+          coslat = pi/180. * R_Earth
+          lauprel = MIN(lat_rel(ip) + resol_lat/(2.0*coslat), 90.)
+          lalowrel = MAX(lat_rel(ip) - resol_lat/(2.0*coslat), -90.)
+          !
+          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 and ', nbpt, 'for the coarse grid'
+    !
+    WRITE(numout,*) 'Aggregate_vec : ', callsign
+    !
+    !   Now we take each grid point and find out which values from the forcing we need to average
+    !
+    fopt(:) = zero
+    fopt_max = -1
+    !
+    !
+    !
+    loopnbind : 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 = MIN(lon_rel(ip) + resol_lon/(2.0*coslat), domain_maxlon)
+       lolowrel = MAX(lon_rel(ip) - resol_lon/(2.0*coslat), domain_minlon)
+       !
+       latrel = lat_rel(ip)
+       coslat = pi/180. * R_Earth
+       lauprel = MIN(lat_rel(ip) + resol_lat/(2.0*coslat), domain_maxlat)
+       lalowrel = MAX(lat_rel(ip) - resol_lat/(2.0*coslat), domain_minlat)
+       !
+       !
+       pos_pnt(:) = zero
+       ipp = zero
+       pp = fine_ind(NINT(lonrel*incp),NINT(latrel*incp))
+       !
+       IF (COUNT(pos_pnt(:) == pp) == zero ) THEN 
+          pos_pnt(ipp+1) = pp
+          ipp = ipp + 1
+       ENDIF
+       pp = fine_ind(NINT(louprel*incp),NINT(lauprel*incp))
+       !
+       IF (COUNT(pos_pnt(:) == pp) == zero ) THEN 
+          pos_pnt(ipp+1) = pp
+          ipp = ipp + 1
+       ENDIF
+       pp = fine_ind(NINT(louprel*incp),NINT(lalowrel*incp))
+       !
+       IF (COUNT(pos_pnt(:) == pp) == zero ) THEN 
+          pos_pnt(ipp+1) = pp
+          ipp = ipp + 1
+       ENDIF
+       pp = fine_ind(NINT(lolowrel*incp),NINT(lauprel*incp))
+       !
+       IF (COUNT(pos_pnt(:) == pp) == zero ) THEN 
+          pos_pnt(ipp+1) = pp
+          ipp = ipp + 1
+       ENDIF
+       pp = fine_ind(NINT(lolowrel*incp),NINT(lalowrel*incp))
+       !
+       IF (COUNT(pos_pnt(:) == pp) == zero ) THEN 
+          pos_pnt(ipp+1) = pp
+          ipp = ipp + 1
+       ENDIF
+       !
+       !
+       IF ( ipp > zero ) THEN
+          !
+          DO pp=1,ipp
+             ib = pos_pnt(pp)
+             !
+             !  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
+                      !
+                   ENDIF
+                ENDIF
+             ENDIF
+          ENDDO
+       ENDIF
+    ENDDO loopnbind
+    !
+    IF (err_fopt) THEN
+       WRITE(numout,*) 'Reached value ', fopt(ib),' for fopt on point', ib
+       CALL ipslerr_p(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
+    !
+    WRITE(numout,*) 
+    not_found_fopt = COUNT(fopt(:) .EQ. zero)
+    WRITE(numout,*) "aggregate_vec : ",not_found_fopt, &
+         & "did not find any corresponding data in the input file."
+    WRITE(numout,*) "aggregate_vec : This is ", not_found_fopt/FLOAT(nbpt)*100., &
+         & " % of the grid"
+    WRITE(numout,*) "aggregate_vec : nbvmax = ",incmax, "max used = ",fopt_max
+    !
+    ! Do some memory management.
+    !
+    DEALLOCATE (searchind)
+    DEALLOCATE (fine_ind)
+    !
+    ! Close the progress meter
+    !
+    WRITE(numout,*) '    '
+    !
+  END SUBROUTINE aggregate_vec
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : aggregate_vec_p
+!!
+!>\BRIEF         
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  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
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                             :: nbpt           !! 
+    REAL(r_std), DIMENSION(nbpt,2), INTENT(in)             :: lalo           !! 
+    INTEGER(i_std), DIMENSION(nbpt,8), INTENT(in)          :: neighbours     !! 
+    REAL(r_std), DIMENSION(nbpt,2), INTENT(in)             :: resolution     !! 
+    REAL(r_std), DIMENSION(nbpt), INTENT(in)               :: contfrac       !! 
+    INTEGER(i_std), INTENT(in)                             :: iml            !! 
+    REAL(r_std), DIMENSION(iml), INTENT(in)                :: lon_ful        !! 
+    REAL(r_std), DIMENSION(iml), INTENT(in)                :: lat_ful        !! 
+    REAL(r_std), INTENT(in)                                :: resol_lon, resol_lat !! 
+    CHARACTER(LEN=*), INTENT(in)                           :: callsign       !! 
+    INTEGER(i_std), INTENT(in)                             :: nbvmax         !! 
+
+    !! 0.2 Output variables
+
+    INTEGER(i_std), DIMENSION(nbpt,nbvmax), INTENT(out)    :: sub_index      !!
+    REAL(r_std), DIMENSION(nbpt,nbvmax), INTENT(out)       :: sub_area       !!
+    LOGICAL, OPTIONAL, INTENT(out)                         :: ok             !! return code
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std), DIMENSION(nbp_glo,nbvmax)              :: sub_index_g    !! 
+    REAL(r_std), DIMENSION(nbp_glo,nbvmax)                 :: sub_area_g     !! 
+
+!_ ================================================================================================================================
+        
+    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
+!!
+!>\BRIEF         
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  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
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                             :: nbpt           !! 
+    REAL(r_std), DIMENSION(nbpt,2), INTENT(in)             :: lalo           !! 
+    INTEGER(i_std), DIMENSION(nbpt,8), INTENT(in)          :: neighbours     !! 
+    REAL(r_std), DIMENSION(nbpt,2), INTENT(in)             :: resolution     !! 
+    REAL(r_std), DIMENSION(nbpt), INTENT(in)               :: contfrac       !! 
+    INTEGER(i_std), INTENT(in)                             :: iml, jml       !! 
+    REAL(r_std), DIMENSION(iml,jml), INTENT(in)            :: lon_ful        !! 
+    REAL(r_std), DIMENSION(iml,jml), INTENT(in)            :: lat_ful        !! 
+    INTEGER(i_std), DIMENSION(iml,jml), INTENT(in)         :: mask           !!
+    CHARACTER(LEN=*), INTENT(in)                           :: callsign       !! 
+    INTEGER(i_std), INTENT(in)                             :: nbvmax         !! 
+
+    !! 0.2 Output variables
+
+    INTEGER(i_std), DIMENSION(nbpt,nbvmax,2), INTENT(out)  :: sub_index      !!
+    REAL(r_std), DIMENSION(nbpt,nbvmax), INTENT(out)       :: sub_area       !!
+    LOGICAL, OPTIONAL, INTENT(out)                         :: ok             !! return code
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std), DIMENSION(nbp_glo,nbvmax,2)            :: sub_index_g    !! 
+    REAL(r_std), DIMENSION(nbp_glo,nbvmax)                 :: sub_area_g     !! 
+
+!_ ================================================================================================================================
+    
+    ok=.FALSE.
+
+    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: branches/publications/ORCHIDEE_CAN_NHA/src_global/solar.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_global/solar.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_global/solar.f90	(revision 7236)
@@ -0,0 +1,600 @@
+! =================================================================================================================================
+! MODULE       : solar
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2011)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        This module define solar 
+!!
+!!\n DESCRIPTION: 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	: None
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE solar
+
+  USE defprec
+  USE constantes
+  USE ioipsl_para 
+
+  IMPLICIT NONE
+
+
+
+CONTAINS
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : solarang
+!!
+!>\BRIEF         This subroutine computes the solar angle according to the method used by GSWP and developed by J.C. Morill.
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::csang
+!!
+!! REFERENCE(S) : See for further details :
+!! http://www.atmo.arizona.edu/~morrill/swrad.html
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE solarang (julian, julian0, iim, jjm, lon, lat, csang)
+
+    USE calendar
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+    
+    !! 0.1 Input variables
+
+    INTEGER, INTENT(in)                      :: iim, jjm        !!
+    REAL, INTENT(in)                         :: julian          !!
+    REAL, INTENT(in)                         :: julian0         !!
+    REAL, DIMENSION(iim,jjm), INTENT(in)     :: lon, lat        !!
+
+    !! 0.2 Output variables
+
+    REAL, DIMENSION(iim,jjm), INTENT(out)    :: csang           !!
+
+    !! 0.4 Local variables
+
+    REAL                                     :: gamma           !!
+    REAL                                     :: dec             !!
+    REAL                                     :: decd            !!
+    REAL                                     :: et              !!
+    REAL                                     :: gmt             !!
+    REAL                                     :: le              !!
+    REAL                                     :: ls              !!
+    REAL                                     :: lcorr           !!
+    REAL                                     :: latime          !!
+    REAL                                     :: omega           !!
+    REAL                                     :: omegad          !!
+    REAL                                     :: llatd, llat     !!
+    INTEGER                                  :: igmt            !!
+    INTEGER                                  :: ilon, ilat      !!
+    INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: zone            !!
+!$OMP THREADPRIVATE(zone)
+    REAL, SAVE, ALLOCATABLE, DIMENSION(:)    :: lhour           !!
+!$OMP THREADPRIVATE(lhour)
+    !
+    LOGICAL                                  :: check = .FALSE. !!
+!$OMP THREADPRIVATE(check)
+
+!_ ================================================================================================================================
+
+    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(gmt, 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
+!!
+!>\BRIEF         
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::zone, ::lhour
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE time_zone (gmt, iim, jjm, lon, zone, lhour)
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+    
+    !! 0.1 Input variables
+
+    INTEGER, INTENT(in)                   :: iim, jjm        !!
+    REAL, DIMENSION(iim,jjm), INTENT(in)  :: lon             !!
+    REAL, INTENT(in)                      :: gmt             !!
+
+    !! 0.2 Output variables
+
+    INTEGER, DIMENSION(iim), INTENT(out)  :: zone            !!
+    REAL, DIMENSION(iim), INTENT(out)     :: lhour           !!
+
+    !! 0.4 Local variables
+
+    INTEGER                               :: deg             !!
+    !!??   REAL :: deg
+    INTEGER                               :: i, ilon, change !! Indices
+
+!_ ================================================================================================================================
+
+    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) >= 24) lhour(ilon) = lhour(ilon)-24
+       !---
+    ENDDO
+    !-----------------------
+  END SUBROUTINE time_zone
+
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : downward_solar_flux
+!!
+!>\BRIEF         
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::solad, ::solai
+!!
+!! REFERENCE(S) :See for further details :
+!! http://www.atmo.arizona.edu/~morrill/swrad.html
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE downward_solar_flux (npoi,latitude,calendar_str,jday,rtime,cloud,nband,solad,solai)
+
+    IMPLICIT NONE
+
+    !! 0. Parameter and variables declaration
+    
+    !! 0.1 Input variables
+    
+    INTEGER, INTENT(in)                      :: npoi               !! number of grid points (unitless)
+    REAL, DIMENSION(npoi), INTENT(in)        :: latitude           !! latitude in degrees
+    CHARACTER(LEN=20),INTENT(in)             :: calendar_str       !! Calendar type
+    REAL, INTENT(in)                      :: jday
+    REAL,INTENT(in)                          :: rtime
+    REAL, DIMENSION(npoi), INTENT(in)        :: cloud              !! cloud fraction (0-1, unitless)
+    INTEGER,INTENT(in)                       :: nband              !! number of visible bands (unitless)
+
+    !! 0.2 Output variables
+
+    REAL, DIMENSION(npoi,nband), INTENT(out) :: solad              !! direct downward solar flux 
+                                                                   !! @tex $(W.m^{-2})$ @endtex
+    REAL, DIMENSION(npoi,nband), INTENT(out) :: solai              !! diffuse downward solar flux 
+                                                                   !! @tex $(W.m^{-2})$ @endtex
+
+    !! 0.4 Local variables
+
+    ! Parametres orbitaux:
+
+    REAL, SAVE                               :: ecc                !! Eccentricity
+!$OMP THREADPRIVATE(ecc)
+    REAL, SAVE                               :: perh               !! Longitude of perihelie
+!$OMP THREADPRIVATE(perh)
+    REAL, SAVE                               :: xob                !! obliquity
+!$OMP THREADPRIVATE(xob)
+    REAL, PARAMETER                          :: pir = pi/180.      !!
+    REAL, SAVE                               :: step               !!
+!$OMP THREADPRIVATE(step)
+    REAL                                     :: xl                 !!
+    REAL                                     :: so                 !!
+    REAL                                     :: xllp               !!
+    REAL                                     :: xee                !!
+    REAL                                     :: xse                !!  
+    REAL                                     :: xlam               !!
+    REAL                                     :: dlamm              !!
+    REAL                                     :: anm                !!
+    REAL                                     :: ranm               !!
+    REAL                                     :: ranv               !!
+    REAL                                     :: anv                !!
+    REAL                                     :: tls                !!
+    REAL                                     :: rlam               !!
+    REAL                                     :: sd                 !!
+    REAL                                     :: cd                 !!
+    REAL                                     :: deltar             !!
+    REAL                                     :: delta              !!
+    REAL                                     :: Dis_ST             !!  
+    REAL                                     :: ddt                !!
+    REAL                                     :: orbit              !!
+    REAL                                     :: angle              !!
+    REAL                                     :: xdecl              !!
+    REAL                                     :: xlat               !!
+    REAL, DIMENSION(npoi)                    :: trans              !!
+    REAL, DIMENSION(npoi)                    :: fdiffuse           !!
+    REAL, DIMENSION(npoi)                    :: coszen             !! cosine of solar zenith angle
+    REAL                                     :: sw                 !!
+    REAL                                     :: frac               !!
+    INTEGER                                  :: i,ib               !!
+    LOGICAL, SAVE                            :: firstcall = .TRUE. !!
+!$OMP THREADPRIVATE(firstcall)
+
+!_ ================================================================================================================================
+    
+    IF (firstcall) THEN
+       IF ( TRIM(calendar_str) .EQ. 'gregorian' ) THEN  
+          step = 1.0
+       ELSE
+          step = one_year/365.2425
+       ENDIF
+       !-
+       ! Read Orbital Parameters
+       !-
+
+       !Config Key   = ECCENTRICITY
+       !Config Desc  = Use prescribed values
+       !Config If    = ALLOW_WEATHERGEN
+       !Config Def   = 0.016724
+       !Config Help  =
+       !Config Units = [-]
+       ecc = 0.016724
+       CALL getin_p ('ECCENTRICITY',ecc)
+       WRITE(numout,*) 'ECCENTRICITY: ',ecc
+       !
+       !Config Key  = PERIHELIE
+       !Config Desc = Use prescribed values
+       !Config If   = ALLOW_WEATHERGEN
+       !Config Def  = 102.04
+       !Config Help  =
+       !Config Units = [-]
+       perh = 102.04
+       CALL getin_p ('PERIHELIE',perh)
+       WRITE(numout,*) 'PERIHELIE: ',perh
+       !
+       !Config Key  = OBLIQUITY
+       !Config Desc = Use prescribed values
+       !Config If   = ALLOW_WEATHERGEN
+       !Config Def  = 23.446
+       !Config Help  =
+       !Config Units = [Degrees]
+       xob = 23.446
+       CALL getin_p ('OBLIQUITY',xob)
+       WRITE(numout,*) 'OBLIQUITY: ',xob
+
+       firstcall = .FALSE.
+    ENDIF
+
+    !-
+    ! calendar and orbital calculations
+    !-
+
+    !-
+    ! calculate the earth's orbital angle (around the sun) in radians
+    orbit = 2.0*pi*jday/365.2425
+    !-
+    ! calculate the solar hour angle in radians
+    angle = 2.0*pi*(rtime-12.0)/24.0
+    !-
+    ! calculate the current solar declination angle
+    ! ref: global physical climatology, hartmann, appendix a
+    !
+    ! xdecl = 0.006918 &
+    !        -0.399912*cos(orbit) &
+    !        +0.070257*sin(orbit) &
+    !        -0.006758*cos(2.0*orbit) &
+    !        +0.000907*sin(2.0*orbit) &
+    !        -0.002697*cos(3.0*orbit) &
+    !        +0.001480*sin(3.0*orbit)
+    !
+    ! calculate the effective solar constant,
+    ! including effects of eccentricity
+    ! ref: global physical climatology, hartmann, appendix a
+    !
+    ! sw = 1370.*( 1.000110 &
+    !             +0.034221*cos(orbit) &
+    !             +0.001280*sin(orbit) &
+    !             +0.000719*cos(2.0*orbit) &
+    !             +0.000077*sin(2.0*orbit))
+    !
+    ! correction Marie-France Loutre
+    !
+    !    orbital parameters
+    !
+    !    ecc = 0.016724
+    !    perh = 102.04
+    !    xob = 23.446
+    !-
+    xl = perh+180.0
+    ! so : sinus of obliquity
+    so = sin(xob*pir)
+    !-
+    xllp = xl*pir
+    xee  = ecc*ecc
+    xse  = sqrt(1.0d0-xee)
+    ! xlam : true long. sun for mean long. = 0
+    xlam = (ecc/2.0+ecc*xee/8.0d0)*(1.0+xse)*sin(xllp)-xee/4.0 &
+         &      *(0.5+xse)*sin(2.0*xllp)+ecc*xee/8.0*(1.0/3.0+xse) &
+         &      *sin(3.0*xllp)
+    xlam  =2.0d0*xlam/pir
+    ! dlamm : mean long. sun for ma-ja
+    dlamm =xlam+(INT(jday)-79)*step
+    anm   = dlamm-xl
+    ranm  = anm*pir
+    xee   = xee*ecc
+    ! ranv : anomalie vraie    (radian)
+    ranv = ranm+(2.0*ecc-xee/4.0)*sin(ranm)+5.0/4.0*ecc*ecc &
+         &      *sin(2.0*ranm)+13.0/12.0*xee*sin(3.0*ranm)
+    ! anv  : anomalie vraie    (degrees)
+    anv  = ranv/pir
+    ! tls  : longitude vraie   (degrees)
+    tls  = anv+xl
+    ! rlam : longitude vraie   (radian)
+    rlam = tls*pir
+    ! sd and cd: cosinus and sinus of solar declination angle (delta)
+    ! sinus delta = sin (obl)*sin(lambda) with lambda = real longitude
+    ! (Phd. thesis of Marie-France Loutre, ASTR-UCL, Belgium, 1993)
+    sd    = so*sin(rlam)
+    cd    = sqrt(1.0d0-sd*sd)
+    ! delta : Solar Declination (degrees, angle sun at equator)
+    deltar = atan(sd/cd)
+    delta  = deltar/pir
+    !-
+    ! Eccentricity Effect
+    !-
+    Dis_ST  =(1.0-ecc*ecc)/(1.0+ecc*cos(ranv))
+    ! ddt :    1 / normalized earth's sun distance
+    ddt = 1.0/Dis_ST
+    !-
+    ! Insolation normal to the atmosphere (W/m2)
+    !-
+    sw  = ddt *ddt *1370.d0
+    !-
+    xdecl = deltar
+    !-
+    ! solar calculations
+    !-
+    do i=1,npoi
+       !---
+       !-- calculate the latitude in radians
+       !---
+       xlat = latitude(i)*pi/180.0
+       !---
+       !-- calculate the cosine of the solar zenith angle
+       !---
+       coszen(i) = MAX(0.0, (sin(xlat)*sin(xdecl) &
+            &                      + cos(xlat)*cos(xdecl)*cos(angle)))
+       !---
+       !-- calculate the solar transmission through the atmosphere
+       !-- using simple linear function of tranmission and cloud cover
+       !---
+       !-- note that the 'cloud cover' data is typically obtained from
+       !-- sunshine hours -- not direct cloud observations
+       !---
+       !-- where, cloud cover = 1 - sunshine fraction
+       !---
+       !-- different authors present different values for the slope and
+       !-- intercept terms of this equation
+       !---
+       !-- Friend, A: Parameterization of a global daily weather generator
+       !-- for terrestrial ecosystem and biogeochemical modelling,
+       !-- Ecological Modelling
+       !---
+       !-- Spitters et al., 1986: Separating the diffuse and direct component
+       !-- of global radiation and its implications for modeling canopy
+       !-- photosynthesis, Part I: Components of incoming radiation,
+       !-- Agricultural and Forest Meteorology, 38, 217-229.
+       !---
+       !-- A. Friend       : trans = 0.251+0.509*(1.0-cloud(i))
+       !-- Spitters et al. : trans = 0.200+0.560*(1.0-cloud(i))
+       !---
+       !-- we are using the values from A. Friend
+       !---
+       trans(i) = 0.251+0.509*(1.0-cloud(i))
+       !---
+       !-- calculate the fraction of indirect (diffuse) solar radiation
+       !-- based upon the cloud cover
+       !---
+       !-- note that these relationships typically are measured for either
+       !-- monthly or daily timescales, and may not be exactly appropriate
+       !-- for hourly calculations -- however, in ibis, cloud cover is fixed
+       !-- through the entire day so it may not make much difference
+       !---
+       !-- method i --
+       !---
+       !-- we use a simple empirical relationships
+       !-- from Nikolov and Zeller (1992)
+       !---
+       !-- Nikolov, N. and K.F. Zeller, 1992:  A solar radiation algorithm
+       !-- for ecosystem dynamics models, Ecological Modelling, 61, 149-168.
+       !---
+       fdiffuse(i) = 1.0045+trans(i)*( 0.0435+trans(i) &
+            &                                 *(-3.5227+trans(i)*2.6313))
+       !---
+       IF (trans(i) > 0.75) fdiffuse(i) = 0.166
+       !---
+       !-- method ii --
+       !---
+       !-- another method was suggested by Spitters et al. (1986) based on
+       !-- long-term data from the Netherlands
+       !--
+       !-- Spitters et al., 1986: Separating the diffuse and direct component
+       !-- of global radiation and its implications for modeling canopy
+       !-- photosynthesis, Part I: Components of incoming radiation,
+       !-- Agricultural and Forest Meteorology, 38, 217-229.
+       !---
+       !--       if ((trans == 0.00).and.(trans < 0.07)) then
+       !--         fdiffuse = 1.0
+       !--       else if ((trans >= 0.07).and.(trans < 0.35)) then
+       !--         fdiffuse = 1.0-2.3*(trans-0.07)**2
+       !--       else if ((trans >= 0.35).and.(trans < 0.75)) then
+       !--         fdiffuse = 1.33-1.46*trans
+       !--       ELSE
+       !--         fdiffuse = 0.23
+       !--       endif
+       !---
+    ENDDO
+    !-----------------------
+    !-
+    ! do for each waveband
+    !-
+    DO ib=1,nband
+       !---
+       !-- calculate the fraction in each waveband
+       !---
+       !-- GK010200
+       IF (nband == 2) then
+          frac = 0.46+0.08*REAL(ib-1)
+       ELSE
+          frac = 1./REAL(nband)
+       ENDIF
+       !---
+       DO i=1,npoi
+          !-----
+          !---- calculate the direct and indirect solar radiation
+          !-----
+          solad(i,ib) = sw*coszen(i)*frac*trans(i)*(1.-fdiffuse(i))
+          solai(i,ib) = sw*coszen(i)*frac*trans(i)*fdiffuse(i)
+       ENDDO
+    ENDDO
+
+
+  END SUBROUTINE downward_solar_flux
+
+ 
+END MODULE solar
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/AA_make
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/AA_make	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/AA_make	(revision 7236)
@@ -0,0 +1,164 @@
+#-
+#- $Id$
+#-
+MODS1 = mod_orchidee_para_var.F90 \
+        xios_orchidee.f90 \
+        mod_orchidee_mpi_data.F90 \
+	mod_orchidee_omp_data.F90 \
+	timer.f90 \
+        mod_orchidee_mpi_transfert.F90 \
+        mod_orchidee_omp_transfert.F90 \
+        mod_orchidee_transfert_para.F90 \
+        mod_orchidee_para.F90 \
+	tools_para.f90 \
+	ioipsl_para.f90 \
+	orch_write_field.f90 \
+	write_field.f90 \
+	orch_write_field_p.f90 \
+	write_field_p.f90
+
+
+PARAM_LIB=$(LIBDIR)/libparameters.a
+FILTERf90=$(filter %.f90,$(MODS1))
+FILTERF90=$(filter %.F90,$(MODS1))
+OBJSMODS1=$(FILTERf90:.f90=.o) $(FILTERF90:.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
+	$(A_C) $(ORCHIDEE_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
+
+$(MODEL_LIB)(%.o) : %.F90
+	$(F_C) $(F_O) -I$(NCDF_INC) $*.F90
+	$(A_C) $(MODEL_LIB) $*.o
+	$(A_C) $(ORCHIDEE_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
+
+
+$(PARAM_LIB)(pft_parameters_var.o) : ../src_parameters/pft_parameters_var.f90
+	$(F_C) $(F_O) -I$(NCDF_INC) ../src_parameters/pft_parameters_var.f90
+	$(A_C) $(PARAM_LIB) pft_parameters_var.o
+	$(A_C) $(ORCHIDEE_LIB) pft_parameters_var.o
+	$(RM) ../src_parallel/pft_parameters_var.o
+
+$(PARAM_LIB)(constantes_var.o) : ../src_parameters/constantes_var.f90
+	$(F_C) $(F_O) -I$(NCDF_INC) ../src_parameters/constantes_var.f90
+	$(A_C) $(PARAM_LIB) constantes_var.o
+	$(A_C) $(ORCHIDEE_LIB) constantes_var.o
+	$(RM) ../src_parallel/constantes_var.o
+
+$(PARAM_LIB)(constantes_soil_var.o) : ../src_parameters/constantes_soil_var.f90
+	$(F_C) $(F_O) -I$(NCDF_INC) ../src_parameters/constantes_soil_var.f90
+	$(A_C) $(PARAM_LIB) constantes_soil_var.o
+	$(A_C) $(ORCHIDEE_LIB) constantes_soil_var.o
+	$(RM) ../src_parallel/constantes_soil_var.o
+
+config : 
+	$(BINDIR)/Fparser -name PARALLEL $(MODS1)
+	echo 'Configuration of PARALLEL done'
+
+clean:
+	$(RM) $(MODEL_LIB)
+
+$(MODEL_LIB)(mpi_dummy.o):
+
+$(MODEL_LIB)(mod_orchidee_para_var.o):
+
+$(MODEL_LIB)(xios_orchidee.o): \
+       $(MODEL_LIB)(mod_orchidee_para_var.o) \
+       $(MODEL_LIB)(mod_orchidee_transfert_para.o) \
+       $(MODEL_LIB)(ioipsl_para.o) \
+       $(PARAM_LIB)(pft_parameters_var.o) \
+       $(PARAM_LIB)(constantes_var.o) \
+       $(PARAM_LIB)(constantes_soil_var.o)
+
+$(MODEL_LIB)(mod_orchidee_mpi_data.o): \
+    $(MODEL_LIB)(mod_orchidee_para_var.o) \
+    $(MODEL_LIB)(xios_orchidee.o) 
+
+$(MODEL_LIB)(mod_orchidee_omp_data.o): \
+    $(MODEL_LIB)(mod_orchidee_para_var.o)
+
+$(MODEL_LIB)(timer.o): \
+    $(MODEL_LIB)(mod_orchidee_para_var.o)
+
+$(MODEL_LIB)(orch_write_field.o): \
+    $(MODEL_LIB)(mod_orchidee_para.o)
+
+$(MODEL_LIB)(write_field.o): \
+  $(MODEL_LIB)(orch_write_field.o)
+
+$(MODEL_LIB)(mod_orchidee_mpi_transfert.o): \
+  $(MODEL_LIB)(mod_orchidee_para_var.o) \
+  $(MODEL_LIB)(timer.o)
+
+$(MODEL_LIB)(mod_orchidee_omp_transfert.o): \
+  $(MODEL_LIB)(mod_orchidee_omp_data.o)
+
+$(MODEL_LIB)(mod_orchidee_transfert_para.o): \
+  $(MODEL_LIB)(mod_orchidee_para_var.o) \
+  $(MODEL_LIB)(mod_orchidee_mpi_transfert.o) \
+  $(MODEL_LIB)(mod_orchidee_omp_transfert.o)
+
+$(MODEL_LIB)(mod_orchidee_para.o): \
+  $(MODEL_LIB)(mod_orchidee_mpi_data.o) \
+  $(MODEL_LIB)(mod_orchidee_omp_data.o) \
+  $(MODEL_LIB)(mod_orchidee_transfert_para.o)
+
+$(MODEL_LIB)(ioipsl_para.o): \
+  $(MODEL_LIB)(mod_orchidee_transfert_para.o) \
+  $(MODEL_LIB)(mod_orchidee_para_var.o)
+
+$(MODEL_LIB)(tools_para.o): \
+  $(MODEL_LIB)(mod_orchidee_para_var.o)
+
+$(MODEL_LIB)(orch_write_field_p.o): \
+  $(MODEL_LIB)(mod_orchidee_para.o) \
+  $(MODEL_LIB)(write_field.o)
+
+$(MODEL_LIB)(write_field_p.o): \
+  $(MODEL_LIB)(orch_write_field_p.o)
+
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/AA_make.ldef
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/AA_make.ldef	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/AA_make.ldef	(revision 7236)
@@ -0,0 +1,20 @@
+#-
+#- $Id$
+#-
+#---------------------------------------------------------------------
+#- Creation des elements relatifs a PARALLEL
+#---------------------------------------------------------------------
+SHELL = /bin/sh
+#---------------------------------------------------------------------
+LIBDIR = ../../../lib
+BINDIR = ../../../bin
+MODDIR = $(LIBDIR)
+ORDIR  = ..
+#---------------------------------------------------------------------
+ORCHIDEE_LIB = $(LIBDIR)/liborchidee.a
+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: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/ioipsl_para.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/ioipsl_para.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/ioipsl_para.f90	(revision 7236)
@@ -0,0 +1,654 @@
+! Overlap of IOIPSL functions for specific parallel use in ORCHIDEE.
+
+!-
+!< $HeadURL$ 
+!< $Date$
+!< $Author$
+!< $Revision$
+!-
+
+MODULE ioipsl_para
+  USE ioipsl
+  USE mod_orchidee_para_var
+  USE mod_orchidee_transfert_para
+!-
+  IMPLICIT NONE
+
+  INTEGER, SAVE :: orch_domain_id 
+!-
+   INTEGER :: orch_ipslout=6, orch_ilv_cur=0, orch_ilv_max=0
+!$OMP THREADPRIVATE( orch_ipslout, orch_ilv_cur, orch_ilv_max )
+
+!-
+!-
+#include "src_parallel.h"
+!-
+  INTERFACE getin_p
+    MODULE PROCEDURE getin_p_c,getin_p_c1,   &
+         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
+
+
+  INTERFACE histwrite_p
+     MODULE PROCEDURE &
+     histwrite_r1d_p,histwrite_r2d_p,histwrite_r3d_p     
+  END INTERFACE
+
+CONTAINS
+
+
+
+  SUBROUTINE Init_ioipsl_para
+
+    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 
+
+    IF (is_omp_root) THEN
+      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)
+     ENDIF
+     
+  END SUBROUTINE Init_ioipsl_para
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!   Definition de ioconf_setatt_p      !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE ioconf_setatt_p (attname,attvalue)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*), INTENT(in) :: attname,attvalue
+!---------------------------------------------------------------------
+
+  IF (is_root_prc) THEN 
+     CALL ioconf_setatt(attname,attvalue)
+  ENDIF
+
+END SUBROUTINE ioconf_setatt_p
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!   Definition de parallel ipslerr functions    !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!===
+SUBROUTINE ipslnlf_p (new_number,old_number)
+!!--------------------------------------------------------------------
+!! The "ipslnlf" routine allows to know and modify
+!! the current logical number for the messages.
+!!
+!! SUBROUTINE ipslnlf (new_number,old_number)
+!!
+!! Optional INPUT argument
+!!
+!! (I) new_number : new logical number of the file
+!!
+!! Optional OUTPUT argument
+!!
+!! (I) old_number : current logical number of the file
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,OPTIONAL,INTENT(IN)  :: new_number
+  INTEGER,OPTIONAL,INTENT(OUT) :: old_number
+!---------------------------------------------------------------------
+  IF (PRESENT(old_number)) THEN
+#ifndef CPP_OMP
+    CALL ipslnlf(old_number=orch_ipslout)
+#endif
+    old_number = orch_ipslout
+  ENDIF
+  IF (PRESENT(new_number)) THEN
+    orch_ipslout = new_number
+#ifndef CPP_OMP
+    CALL ipslnlf(new_number=orch_ipslout)
+#endif
+  ENDIF
+!---------------------
+END SUBROUTINE ipslnlf_p
+!===
+SUBROUTINE ipslerr_p (plev,pcname,pstr1,pstr2,pstr3)
+!---------------------------------------------------------------------
+!! The "ipslerr_p" routine
+!! allows to handle the messages to the user.
+!!
+!! parallel version of IOIPSL ipslerr
+!!
+!! INPUT
+!!
+!! plev   : Category of message to be reported to the user
+!!          1 = Note to the user
+!!          2 = Warning to the user
+!!          3 = Fatal error
+!! pcname : Name of subroutine which has called ipslerr
+!! pstr1   
+!! pstr2  : Strings containing the explanations to the user
+!! pstr3
+!---------------------------------------------------------------------
+   IMPLICIT NONE
+!-
+   INTEGER :: plev
+   CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3
+!-
+   CHARACTER(LEN=30),DIMENSION(3) :: pemsg = &
+  &  (/ "NOTE TO THE USER FROM ROUTINE ", &
+  &     "WARNING FROM ROUTINE          ", &
+  &     "FATAL ERROR FROM ROUTINE      " /)
+!---------------------------------------------------------------------
+   IF ( (plev >= 1).AND.(plev <= 3) ) THEN
+     orch_ilv_cur = plev
+     orch_ilv_max = MAX(orch_ilv_max,plev)
+     WRITE(orch_ipslout,'(/,A," ",A)') TRIM(pemsg(plev)),TRIM(pcname)
+     WRITE(orch_ipslout,'(3(" --> ",A,/))') TRIM(pstr1),TRIM(pstr2),TRIM(pstr3)
+   ENDIF
+   IF (plev == 3) THEN
+     WRITE(orch_ipslout,'("Fatal error from ORCHIDEE. STOP in ipslerr_p with code")')
+#ifdef CPP_PARA
+    CALL MPI_ABORT(plev)
+#endif     
+    STOP 'Fatal error from ORCHIDEE'
+   ENDIF
+!---------------------
+END SUBROUTINE ipslerr_p
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!   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  
+
+
+  SUBROUTINE getin_p_c1(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_c1 
+
+!! -- 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(r_std),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(r_std),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(r_std),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(r_std) :: var(:)
+    CHARACTER(LEN=*) :: MY_OPERATOR
+    INTEGER :: nbindex, ijndex(nbindex)
+    !-----------------------------
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: temp_g
+
+    IF (is_root_prc) THEN 
+       ALLOCATE( temp_g(iim*jjm*llm) )
+    ELSE
+       ALLOCATE( temp_g(1) )
+    ENDIF
+        
+    IF (is_root_prc) THEN 
+       CALL restget &
+            (fid, vname_q, iim, jjm, llm, itau, def_beha, &
+            temp_g, MY_OPERATOR, nbindex, ijndex)
+    ENDIF
+    CALL scatter(temp_g,var)
+    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(r_std) :: var(:,:)
+    CHARACTER(LEN=*) :: MY_OPERATOR
+    INTEGER :: nbindex, ijndex(nbindex)
+    !-----------------------------
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: temp_g
+
+    IF (is_root_prc) THEN 
+       ALLOCATE( temp_g(iim,jjm) )
+    ELSE
+      ALLOCATE( temp_g(1,1) )
+    ENDIF
+
+    IF (is_root_prc) THEN 
+       CALL restget &
+            (fid, vname_q, iim, jjm, llm, itau, def_beha, &
+            temp_g, MY_OPERATOR, nbindex, ijndex)
+    ENDIF
+    CALL scatter(temp_g,var)
+    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(r_std) :: var(:)
+    !-------------------------
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: temp_g
+
+    IF (is_root_prc) THEN 
+       ALLOCATE( temp_g(iim*jjm*llm) )
+    ELSE
+       ALLOCATE( temp_g(1) )
+    ENDIF
+
+    IF (is_root_prc) THEN 
+       CALL restget &
+            (fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
+    ENDIF
+    CALL scatter(temp_g,var)
+    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(r_std) :: var(:,:)
+    !-------------------------
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: temp_g
+
+    IF (is_root_prc) THEN 
+       ALLOCATE( temp_g(iim,jjm) )
+    ELSE
+       ALLOCATE( temp_g(1,1) )
+    ENDIF
+    IF (is_root_prc) THEN 
+       CALL restget &
+            (fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
+    ENDIF
+    CALL scatter(temp_g,var)
+    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(r_std) :: var(:,:,:)
+    !-------------------------
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
+
+    IF (is_root_prc) THEN 
+       ALLOCATE( temp_g(iim,jjm,llm) )
+    ELSE 
+       ALLOCATE( temp_g(1,1,1) )
+    ENDIF
+    
+    IF (is_root_prc) THEN 
+       CALL restget &
+            (fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
+    ENDIF
+    CALL scatter(temp_g,var)
+    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(r_std) :: var(:)
+    CHARACTER(LEN=*) :: MY_OPERATOR
+    INTEGER :: nbindex, ijndex(nbindex)
+    !-----------------------------
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: temp_g
+
+    IF (is_root_prc) THEN 
+      ALLOCATE( temp_g(iim*jjm*llm) )
+    ELSE
+      ALLOCATE ( temp_g(1) )
+    ENDIF
+    
+    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)
+    ENDIF
+
+    DEALLOCATE( temp_g )
+          
+  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(r_std) :: var(:,:)
+    CHARACTER(LEN=*) :: MY_OPERATOR
+    INTEGER :: nbindex, ijndex(nbindex)
+    !-----------------------------
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: temp_g
+
+    IF (is_root_prc) THEN
+      ALLOCATE( temp_g(iim,jjm) )
+    ELSE
+      ALLOCATE( temp_g(1,1) )
+    ENDIF
+          
+    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)
+    ENDIF
+    DEALLOCATE( temp_g )
+          
+  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(r_std) :: var(:)
+    !-----------------------------
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: temp_g
+
+    IF (is_root_prc) THEN
+      ALLOCATE( temp_g(iim*jjm*llm) )
+    ELSE
+      ALLOCATE( temp_g(1) )
+    ENDIF
+    
+    CALL gather(var,temp_g)
+    IF (is_root_prc) THEN
+       CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
+    ENDIF
+    DEALLOCATE( temp_g )
+          
+  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(r_std) :: var(:,:)
+    !-------------------------
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: temp_g
+
+    IF (is_root_prc) THEN
+      ALLOCATE( temp_g(iim,jjm) )
+    ELSE
+      ALLOCATE( temp_g(1,1) )
+    ENDIF
+    
+    CALL gather(var,temp_g)
+    IF (is_root_prc) THEN
+       CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
+    ENDIF
+    DEALLOCATE( temp_g )
+          
+  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(r_std) :: var(:,:,:)
+    !-------------------------
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
+
+    IF (is_root_prc) THEN
+      ALLOCATE( temp_g(iim,jjm,llm) )
+    ELSE
+      ALLOCATE( temp_g(iim,jjm,llm) )
+    ENDIF
+    
+    CALL gather(var,temp_g)
+    IF (is_root_prc) THEN
+       CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
+    ENDIF
+    DEALLOCATE( temp_g )
+          
+  END SUBROUTINE restput_p_r3d
+
+
+  SUBROUTINE histwrite_r1d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex)
+    IMPLICIT NONE
+!-
+    INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex)
+    REAL(r_std),DIMENSION(:),INTENT(IN) :: pdata
+    CHARACTER(LEN=*),INTENT(IN) :: pvarname
+    
+    REAL(r_std),DIMENSION(nbp_mpi)    :: pdata_mpi
+    
+    IF (pfileid > 0) THEN 
+       ! Continue only if the file is initilalized
+       CALL gather_omp(pdata,pdata_mpi)
+       IF (is_omp_root) THEN
+          CALL histwrite(pfileid,pvarname,pitau,pdata_mpi,nbp_mpi,kindex_mpi) 
+       ENDIF
+    END IF
+      
+  END SUBROUTINE histwrite_r1d_p
+  
+
+  SUBROUTINE histwrite_r2d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex)
+    IMPLICIT NONE
+!-
+    INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex)
+    REAL(r_std),DIMENSION(:,:),INTENT(IN) :: pdata
+    CHARACTER(LEN=*),INTENT(IN) :: pvarname
+
+    IF (pfileid > 0) THEN 
+       ! Continue only if the file is initilalized
+       CALL body(size(pdata,2),nindex)
+    END IF
+
+  CONTAINS 
+
+    SUBROUTINE body(dim,nindex)
+    INTEGER :: dim
+    INTEGER :: nindex(nbp_omp,dim)
+    
+    INTEGER :: nindex_mpi(nbp_mpi,dim)
+    REAL(r_std)    :: pdata_mpi(nbp_mpi,dim)
+    
+      CALL gather_omp(pdata,pdata_mpi)
+      CALL gather_omp(nindex,nindex_mpi)
+    
+      IF (is_omp_root) THEN
+       CALL histwrite(pfileid,pvarname,pitau,pdata_mpi,nbp_mpi*dim,reshape(nindex_mpi,(/nbp_mpi*dim/)))
+      ENDIF
+    END SUBROUTINE body
+       
+  END SUBROUTINE histwrite_r2d_p
+
+  
+  SUBROUTINE histwrite_r3d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex)
+    IMPLICIT NONE
+!-
+    INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex)
+    REAL(r_std),DIMENSION(:,:,:),INTENT(IN) :: pdata
+    CHARACTER(LEN=*),INTENT(IN) :: pvarname
+  
+    STOP 'histwrite_r3d_p !!!'
+    
+  END SUBROUTINE histwrite_r3d_p
+
+
+END MODULE ioipsl_para
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_mpi_data.F90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_mpi_data.F90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_mpi_data.F90	(revision 7236)
@@ -0,0 +1,401 @@
+! Definition and allocation of parallel datas for MPI.
+! Initialization of parallel or sequentiel IOs.
+! Definition of Load Balancing functions.
+
+!-
+!- $Header: $
+!- 
+
+MODULE mod_orchidee_mpi_data
+
+!-
+  USE defprec
+  USE ioipsl
+  USE xios_orchidee
+  USE mod_orchidee_para_var
+
+  IMPLICIT NONE
+
+!-
+#include "src_parallel.h"
+!-
+!-
+
+CONTAINS
+ 
+  SUBROUTINE Init_orchidee_mpi(communicator)
+
+
+    IMPLICIT NONE
+    INTEGER, OPTIONAL, INTENT(in) :: communicator
+    INTEGER :: COMM
+    INTEGER :: ierr
+    
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+
+    !Config Key   = XIOS_ORCHIDEE_OK
+    !Config Desc  = Use XIOS for writing diagnostics file
+    !Config If    = 
+    !Config Def   = FALSE
+    !Config Help  = 
+    !Config Units = [FLAG]
+    CALL getin('XIOS_ORCHIDEE_OK',xios_orchidee_ok)
+    WRITE(numout,*)'In init_ochidee_mpi : xios_orchidee_ok=',xios_orchidee_ok
+
+#ifdef CPP_PARA
+    IF ( xios_orchidee_ok ) THEN
+       CALL MPI_INIT(ierr)
+       CALL xios_orchidee_comm_init(COMM)
+    ELSE IF ( PRESENT(communicator) ) THEN
+       COMM=communicator
+    ELSE
+       CALL MPI_INIT(ierr)
+       COMM=MPI_COMM_WORLD
+    ENDIF
+    CALL MPI_COMM_SIZE(COMM,mpi_size,ierr)
+    CALL MPI_COMM_RANK(COMM,mpi_rank,ierr)
+    is_ok_mpi=.TRUE.
+#else
+    mpi_rank=0
+    mpi_size=1
+    is_ok_mpi=.FALSE.
+    ! It is not possible to use XIOS without MPI
+    WRITE(numout,*)'XIOS cannot be run without MPI. xios_orchidee_ok is set to false.'
+    xios_orchidee_ok=.FALSE.
+#endif
+    
+    mpi_rank_root=0
+
+    IF (mpi_rank==mpi_rank_root) THEN 
+      is_mpi_root=.TRUE.
+    ELSE
+      is_mpi_root=.FALSE.
+    ENDIF
+  
+    CALL Init_const_mpi(COMM)
+      
+  END SUBROUTINE Init_orchidee_mpi
+
+
+
+  SUBROUTINE Init_orchidee_mpi_data(arg_nbp_mpi,arg_kindex_mpi,arg_offset_mpi,COMM)
+
+  IMPLICIT NONE
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER, INTENT(IN) :: arg_nbp_mpi
+    INTEGER, INTENT(IN) :: arg_kindex_mpi(arg_nbp_mpi)
+    INTEGER, INTENT(IN) :: arg_offset_mpi
+    INTEGER, INTENT(IN) :: COMM
+
+    INTEGER :: i
+  
+#ifdef CPP_PARA
+    INTEGER :: ierr
+    is_ok_mpi=.TRUE.
+#else
+    is_ok_mpi=.FALSE.
+#endif
+
+    ! Initialization of MPI_COMM_ORCH 
+    CALL init_const_mpi(COMM)
+    IF (is_ok_mpi) THEN    
+#ifdef CPP_PARA
+      CALL MPI_COMM_SIZE(MPI_COMM_ORCH,mpi_size,ierr)    
+      CALL MPI_COMM_RANK(MPI_COMM_ORCH,mpi_rank,ierr)
+#endif
+    ELSE
+      mpi_size=1
+      mpi_rank=0
+    ENDIF   
+    
+    IF (mpi_rank == 0) THEN
+      mpi_rank_root = 0
+      is_mpi_root = .true.
+    ENDIF
+    
+    ALLOCATE(nbp_mpi_para(0:mpi_size-1))
+    ALLOCATE(nbp_mpi_para_begin(0:mpi_size-1))
+    ALLOCATE(nbp_mpi_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))
+    
+
+    nbp_mpi=arg_nbp_mpi
+    ALLOCATE(kindex_mpi(nbp_mpi))
+    kindex_mpi(:)=arg_kindex_mpi(:)
+    
+    offset_mpi=arg_offset_mpi
+    
+    IF (is_ok_mpi) THEN
+#ifdef CPP_PARA
+      CALL MPI_AllGather(nbp_mpi,1,MPI_INT_ORCH,nbp_mpi_para,1,MPI_INT_ORCH,MPI_COMM_ORCH,ierr)
+#endif
+    ELSE
+      nbp_mpi_para(0)=nbp_mpi
+    ENDIF
+    
+    nbp_mpi_para_begin(0)=1
+    nbp_mpi_para_end(0)=nbp_mpi_para(0)
+    DO i=1,mpi_size-1
+      nbp_mpi_para_begin(i)=nbp_mpi_para_end(i-1)+1
+      nbp_mpi_para_end(i)=nbp_mpi_para_begin(i)+nbp_mpi_para(i)-1
+    ENDDO
+    nbp_mpi_begin=nbp_mpi_para_begin(mpi_rank)
+    nbp_mpi_end=nbp_mpi_para_end(mpi_rank)
+    
+    
+    IF (mpi_rank==mpi_size-1) THEN
+      ij_end=iim_g*jjm_g
+    ELSE
+      ij_end=kindex_mpi(nbp_mpi)+offset_mpi
+    ENDIF
+
+    IF (is_ok_mpi) THEN    
+#ifdef CPP_PARA    
+      CALL MPI_Allgather(ij_end,1,MPI_INT_ORCH,ij_para_end,1,MPI_INT_ORCH,MPI_COMM_ORCH,ierr)
+#endif
+    ELSE
+      ij_para_end(0)=ij_end
+    ENDIF
+    
+    ij_para_begin(0)=1
+    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_nb(i)=ij_para_end(i)-ij_para_begin(i)+1
+    ENDDO
+    
+    DO i=0,mpi_size-1
+      jj_para_begin(i)=(ij_para_begin(i)-1)/iim_g + 1
+      jj_para_end(i)=(ij_para_end(i)-1)/iim_g + 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_g)+1
+      ii_para_end(i)=MOD(ij_para_end(i)-1,iim_g)+1
+    ENDDO
+
+   
+    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)
+        
+      
+    CALL print_mpi_data
+  
+    
+  END SUBROUTINE Init_orchidee_mpi_data
+  
+  SUBROUTINE init_const_mpi(COMM)
+
+  IMPLICIT NONE
+    INTEGER :: COMM
+
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+    
+    MPI_COMM_ORCH=COMM
+    
+    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
+
+  END SUBROUTINE init_const_mpi
+
+  SUBROUTINE Finalize_mpi
+
+  IMPLICIT NONE
+#ifdef CPP_PARA
+  include 'mpif.h'  
+  INTEGER :: ierr
+
+  CALL xios_orchidee_finalize
+
+  CALL MPI_FINALIZE(ierr)
+#endif
+   
+  END SUBROUTINE Finalize_mpi
+  
+  SUBROUTINE print_mpi_data
+
+  IMPLICIT NONE
+    
+    WRITE(numout,*) '==== MPI DOMAIN ===='
+    WRITE(numout,*) '     ----------     '
+    WRITE(numout,*) 'mpi_size',mpi_size
+    WRITE(numout,*) 'mpi_rank',mpi_rank
+    WRITE(numout,*) 'is_mpi_root',is_mpi_root
+    WRITE(numout,*) 'mpi_rank_root',mpi_rank_root
+
+    WRITE(numout,*) 'nbp_mpi_begin=',nbp_mpi_begin
+    WRITE(numout,*) 'nbp_mpi_end  =',nbp_mpi_end
+    WRITE(numout,*) 'nbp_mpi=',nbp_mpi
+          
+    WRITE(numout,*) 'ij_begin=',ij_begin
+    WRITE(numout,*) 'ij_end=',ij_end
+    WRITE(numout,*) 'ij_nb=',ij_nb
+    WRITE(numout,*) 'jj_begin=',jj_begin
+    WRITE(numout,*) 'jj_end=',jj_end
+    WRITE(numout,*) 'jj_nb=',jj_nb	
+    WRITE(numout,*) 'ii_begin=',ii_begin
+    WRITE(numout,*) 'ii_end=',ii_end
+    
+    WRITE(numout,*) 'offset_mpi',offset_mpi
+    WRITE(numout,*) 'nbp_mpi_para_begin=',nbp_mpi_para_begin
+    WRITE(numout,*) 'nbp_mpi_para_end  =',nbp_mpi_para_end
+    WRITE(numout,*) 'nbp_mpi_para=',nbp_mpi_para
+          
+    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
+  
+  END SUBROUTINE print_mpi_data
+  
+ SUBROUTINE Read_Load_balance(NbPoints,Nbpoints_loc)
+
+    IMPLICIT NONE
+    INTEGER,INTENT(IN)  :: NbPoints
+    INTEGER,INTENT(OUT) :: Nbpoints_loc(0:mpi_size-1)
+    INTEGER :: i,s
+    INTEGER :: ierr
+    
+#ifdef CPP_PARA
+    CHARACTER(len=255)  :: filename='Load_balance_orchidee.dat'
+    INTEGER :: j
+    INTEGER :: unit_number=10
+#endif   
+
+#ifdef CPP_PARA
+    OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='old',FORM='formatted',IOSTAT=ierr) 
+#else
+    ierr=1
+#endif   
+    Nbpoints_loc(:) = 0
+
+    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
+  
+    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)
+    
+    WRITE(numout,*) 'time',times
+
+    IF (is_ok_mpi) THEN
+#ifdef CPP_PARA
+      CALL MPI_GATHER(times,1,MPI_REAL_ORCH,All_times,1,MPI_REAL_ORCH,mpi_rank_root,MPI_COMM_ORCH,ierr)
+#endif
+    ELSE
+      All_times(:)=times
+    ENDIF
+    
+    IF (is_mpi_root) WRITE(numout,*) 'ALL_times',All_times
+
+    IF (is_mpi_root) 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_mpi_para(i)
+          New_nbpoints(i)=Nbp_mpi_para(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_mpi_para(:)
+       ENDIF
+       
+       DO i=0,mpi_size-1
+          WRITE(Unit_number,*) i,New_nbpoints(i)
+       ENDDO
+       CLOSE(Unit_number)
+    ENDIF
+
+  END SUBROUTINE Write_Load_Balance
+  
+END MODULE mod_orchidee_mpi_data
+
+#include "mpi_dummy.h"
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_mpi_transfert.F90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_mpi_transfert.F90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_mpi_transfert.F90	(revision 7236)
@@ -0,0 +1,2939 @@
+! Low level MPI parallel communication encapsulations for ORCHIDEE.
+
+!-
+!- $Header: $
+!-
+
+MODULE mod_orchidee_mpi_transfert
+  !-
+  USE defprec
+  USE mod_orchidee_para_var
+  USE timer
+  !-
+  IMPLICIT NONE
+  !-
+#include "src_parallel.h"
+  !-
+
+  INTERFACE bcast_mpi
+     MODULE PROCEDURE bcast_mpi_c, bcast_mpi_c1,                           &
+          bcast_mpi_i,bcast_mpi_i1,bcast_mpi_i2,bcast_mpi_i3,bcast_mpi_i4, &
+          bcast_mpi_r,bcast_mpi_r1,bcast_mpi_r2,bcast_mpi_r3,bcast_mpi_r4, &
+          bcast_mpi_l,bcast_mpi_l1,bcast_mpi_l2,bcast_mpi_l3,bcast_mpi_l4
+  END INTERFACE
+
+  INTERFACE scatter_mpi
+     MODULE PROCEDURE scatter_mpi_i,scatter_mpi_i1,scatter_mpi_i2,scatter_mpi_i3, &
+          scatter_mpi_r,scatter_mpi_r1,scatter_mpi_r2,scatter_mpi_r3, &
+          scatter_mpi_l,scatter_mpi_l1,scatter_mpi_l2,scatter_mpi_l3
+  END INTERFACE
+
+  INTERFACE gather_mpi_s
+     MODULE PROCEDURE gather_mpi_is, &
+          gather_mpi_rs, &
+          gather_mpi_ls
+  END INTERFACE
+
+  INTERFACE gather_mpi
+     MODULE PROCEDURE gather_mpi_i,gather_mpi_i1,gather_mpi_i2,gather_mpi_i3, &
+          gather_mpi_r,gather_mpi_r1,gather_mpi_r2,gather_mpi_r3, &
+          gather_mpi_l,gather_mpi_l1,gather_mpi_l2,gather_mpi_l3  
+  END INTERFACE
+
+  INTERFACE scatter2D_mpi
+     MODULE PROCEDURE scatter2D_mpi_i,scatter2D_mpi_i1,scatter2D_mpi_i2,scatter2D_mpi_i3, &
+          scatter2D_mpi_r0,scatter2D_mpi_r,scatter2D_mpi_r1,scatter2D_mpi_r2,scatter2D_mpi_r3, &
+          scatter2D_mpi_l,scatter2D_mpi_l1,scatter2D_mpi_l2,scatter2D_mpi_l3
+  END INTERFACE
+
+  INTERFACE gather2D_mpi
+     MODULE PROCEDURE gather2D_mpi_i,gather2D_mpi_i1,gather2D_mpi_i2,gather2D_mpi_i3, &
+          gather2D_mpi_r0,gather2D_mpi_r,gather2D_mpi_r1,gather2D_mpi_r2,gather2D_mpi_r3, &
+          gather2D_mpi_l,gather2D_mpi_l1,gather2D_mpi_l2,gather2D_mpi_l3
+  END INTERFACE
+
+  INTERFACE reduce_sum_mpi
+     MODULE PROCEDURE reduce_sum_mpi_i,reduce_sum_mpi_i1,reduce_sum_mpi_i2,reduce_sum_mpi_i3,reduce_sum_mpi_i4, &
+          reduce_sum_mpi_r,reduce_sum_mpi_r1,reduce_sum_mpi_r2,reduce_sum_mpi_r3,reduce_sum_mpi_r4
+  END INTERFACE
+
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Broadcast --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  !! -- Les chaine de charactère -- !!
+
+  SUBROUTINE bcast_mpi_c(var)
+    IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+    CHARACTER(LEN=len(Var)),DIMENSION(1) :: Var1
+
+#ifndef CPP_PARA
+    RETURN
+#else
+    IF (is_mpi_root) &
+         Var1(1)=Var
+    CALL orch_bcast_mpi_cgen(Var1,1)
+    Var=Var1(1)
+#endif
+  END SUBROUTINE bcast_mpi_c
+
+  SUBROUTINE bcast_mpi_c1(var)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var(:)
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL orch_bcast_mpi_cgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_mpi_c1
+
+
+  !! -- Les entiers -- !!
+
+  SUBROUTINE bcast_mpi_i(var)
+    IMPLICIT NONE
+    INTEGER(i_std),INTENT(INOUT) :: Var
+    INTEGER(i_std),DIMENSION(1) :: Var1
+
+#ifndef CPP_PARA
+    RETURN
+#else
+    IF (is_mpi_root) &
+         Var1(1)=Var
+    CALL orch_bcast_mpi_igen(Var1,1)
+    Var=Var1(1)
+#endif
+  END SUBROUTINE bcast_mpi_i
+
+  SUBROUTINE bcast_mpi_i1(var)
+    IMPLICIT NONE
+    INTEGER(i_std),INTENT(INOUT) :: Var(:)
+
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL orch_bcast_mpi_igen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_mpi_i1
+
+  SUBROUTINE bcast_mpi_i2(var)
+    IMPLICIT NONE
+    INTEGER(i_std),INTENT(INOUT) :: Var(:,:)
+
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL orch_bcast_mpi_igen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_mpi_i2
+
+  SUBROUTINE bcast_mpi_i3(var)
+    IMPLICIT NONE
+    INTEGER(i_std),INTENT(INOUT) :: Var(:,:,:)
+
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL orch_bcast_mpi_igen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_mpi_i3
+
+  SUBROUTINE bcast_mpi_i4(var)
+    IMPLICIT NONE
+    INTEGER(i_std),INTENT(INOUT) :: Var(:,:,:,:)
+
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL orch_bcast_mpi_igen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_mpi_i4
+
+
+  !! -- Les reels -- !!
+
+  SUBROUTINE bcast_mpi_r(var)
+    IMPLICIT NONE
+    REAL(r_std),INTENT(INOUT) :: Var
+    REAL(r_std),DIMENSION(1) :: Var1
+
+#ifndef CPP_PARA
+    RETURN
+#else
+    IF (is_mpi_root) &
+         Var1(1)=Var
+    CALL orch_bcast_mpi_rgen(Var1,1)
+    Var=Var1(1)
+#endif
+  END SUBROUTINE bcast_mpi_r
+
+  SUBROUTINE bcast_mpi_r1(var)
+    IMPLICIT NONE
+    REAL(r_std),INTENT(INOUT) :: Var(:)
+
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL orch_bcast_mpi_rgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_mpi_r1
+
+  SUBROUTINE bcast_mpi_r2(var)
+    IMPLICIT NONE
+    REAL(r_std),INTENT(INOUT) :: Var(:,:)
+
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL orch_bcast_mpi_rgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_mpi_r2
+
+  SUBROUTINE bcast_mpi_r3(var)
+    IMPLICIT NONE
+    REAL(r_std),INTENT(INOUT) :: Var(:,:,:)
+
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL orch_bcast_mpi_rgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_mpi_r3
+
+  SUBROUTINE bcast_mpi_r4(var)
+    IMPLICIT NONE
+    REAL(r_std),INTENT(INOUT) :: Var(:,:,:,:)
+
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL orch_bcast_mpi_rgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_mpi_r4
+
+  !! -- Les booleans -- !!
+
+  SUBROUTINE bcast_mpi_l(var)
+    IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+    LOGICAL,DIMENSION(1) :: Var1
+#ifndef CPP_PARA
+    RETURN
+#else
+    IF (is_mpi_root) &
+         Var1(1)=Var
+    CALL orch_bcast_mpi_lgen(Var1,1)
+    Var=Var1(1)
+#endif
+  END SUBROUTINE bcast_mpi_l
+
+  SUBROUTINE bcast_mpi_l1(var)
+    IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL orch_bcast_mpi_lgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_mpi_l1
+
+  SUBROUTINE bcast_mpi_l2(var)
+    IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL orch_bcast_mpi_lgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_mpi_l2
+
+  SUBROUTINE bcast_mpi_l3(var)
+    IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL orch_bcast_mpi_lgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_mpi_l3
+
+  SUBROUTINE bcast_mpi_l4(var)
+    IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL orch_bcast_mpi_lgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_mpi_l4
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_mpi_i(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(nbp_glo) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(nbp_mpi) :: VarOut
+
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_scatter_mpi_igen(VarIn,Varout,SIZE(VarIn,1),1)
+    ELSE
+       CALL orch_scatter_mpi_igen(dummy,Varout,1,1)
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter_mpi_i
+
+  SUBROUTINE scatter_mpi_i1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1,SIZE(VarOut,2)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+    IF (is_mpi_root) THEN
+       CALL orch_scatter_mpi_igen(VarIn,Varout,SIZE(VarIn,1),SIZE(VarOut,2))
+    ELSE
+       CALL orch_scatter_mpi_igen(dummy,Varout,1,SIZE(VarOut,2))
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter_mpi_i1
+
+  SUBROUTINE scatter_mpi_i2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1,SIZE(VarOut,2)*SIZE(VarOut,3)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else    
+    IF (is_mpi_root) THEN
+       CALL orch_scatter_mpi_igen(VarIn,Varout,SIZE(VarIn,1),SIZE(VarOut,2)*SIZE(VarOut,3))
+    ELSE
+       CALL orch_scatter_mpi_igen(dummy,Varout,1,SIZE(VarOut,2)*SIZE(VarOut,3))
+    ENDIF
+#endif
+  END SUBROUTINE scatter_mpi_i2
+
+  SUBROUTINE scatter_mpi_i3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1,SIZE(VarOut,2)*SIZE(VarOut,3)*SIZE(VarOut,4)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else    
+    IF (is_mpi_root) THEN
+       CALL orch_scatter_mpi_igen(VarIn,Varout,SIZE(VarIn,1),SIZE(VarOut,2)*SIZE(VarOut,3)*SIZE(VarOut,4))
+    ELSE
+       CALL orch_scatter_mpi_igen(dummy,Varout,1,SIZE(VarOut,2)*SIZE(VarOut,3)*SIZE(VarOut,4))
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter_mpi_i3
+
+
+  SUBROUTINE scatter_mpi_r(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:) :: VarOut
+
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+    IF (is_mpi_root) THEN
+       CALL orch_scatter_mpi_rgen(VarIn,Varout,SIZE(VarIn,1),1)
+    ELSE
+       CALL orch_scatter_mpi_rgen(dummy,Varout,1,1)
+    ENDIF
+#endif
+  END SUBROUTINE scatter_mpi_r
+
+  SUBROUTINE scatter_mpi_r1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1,SIZE(VarOut,2)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+    IF (is_mpi_root) THEN
+       CALL orch_scatter_mpi_rgen(VarIn,Varout,SIZE(VarIn,1),SIZE(VarOut,2))
+    ELSE
+       CALL orch_scatter_mpi_rgen(dummy,Varout,1,SIZE(VarOut,2))
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter_mpi_r1
+
+  SUBROUTINE scatter_mpi_r2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1,SIZE(VarOut,2)*SIZE(VarOut,3)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+    IF (is_mpi_root) THEN
+       CALL orch_scatter_mpi_rgen(VarIn,Varout,SIZE(VarIn,1),SIZE(VarOut,2)*SIZE(VarOut,3))
+    ELSE
+       CALL orch_scatter_mpi_rgen(dummy,Varout,1,SIZE(VarOut,2)*SIZE(VarOut,3))
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter_mpi_r2
+
+  SUBROUTINE scatter_mpi_r3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1,SIZE(VarOut,2)*SIZE(VarOut,3)*SIZE(VarOut,4)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+    IF (is_mpi_root) THEN
+       CALL orch_scatter_mpi_rgen(VarIn,Varout,SIZE(VarIn,1),SIZE(VarOut,2)*SIZE(VarOut,3)*SIZE(VarOut,4))
+    ELSE
+       CALL orch_scatter_mpi_rgen(dummy,Varout,1,SIZE(VarOut,2)*SIZE(VarOut,3)*SIZE(VarOut,4))
+    ENDIF
+#endif
+  END SUBROUTINE scatter_mpi_r3
+
+
+  SUBROUTINE scatter_mpi_l(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+#ifdef CPP_PARA    
+    LOGICAL,DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+    IF (is_mpi_root) THEN
+       CALL orch_scatter_mpi_lgen(VarIn,Varout,SIZE(VarIn,1),1)
+    ELSE
+       CALL orch_scatter_mpi_lgen(dummy,Varout,1,1)
+    ENDIF
+#endif
+  END SUBROUTINE scatter_mpi_l
+
+  SUBROUTINE scatter_mpi_l1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA
+    LOGICAL,DIMENSION(1,SIZE(VarOut,2)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+    IF (is_mpi_root) THEN
+       CALL orch_scatter_mpi_lgen(VarIn,Varout,SIZE(VarIn,1),SIZE(VarOut,2))
+    ELSE
+       CALL orch_scatter_mpi_lgen(dummy,Varout,1,SIZE(VarOut,2))
+    ENDIF
+#endif
+  END SUBROUTINE scatter_mpi_l1
+
+  SUBROUTINE scatter_mpi_l2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    LOGICAL,DIMENSION(1,SIZE(VarOut,2)*SIZE(VarOut,3)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+    IF (is_mpi_root) THEN
+       CALL orch_scatter_mpi_lgen(VarIn,Varout,SIZE(VarIn,1),SIZE(VarOut,2)*SIZE(VarOut,3))
+    ELSE
+       CALL orch_scatter_mpi_lgen(dummy,Varout,1,SIZE(VarOut,2)*SIZE(VarOut,3))
+    ENDIF
+#endif
+  END SUBROUTINE scatter_mpi_l2
+
+  SUBROUTINE scatter_mpi_l3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    LOGICAL,DIMENSION(1,SIZE(VarOut,2)*SIZE(VarOut,3)*SIZE(VarOut,4)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+    IF (is_mpi_root) THEN
+       CALL orch_scatter_mpi_lgen(VarIn,Varout,SIZE(VarIn,1),SIZE(VarOut,2)*SIZE(VarOut,3)*SIZE(VarOut,4))
+    ELSE
+       CALL orch_scatter_mpi_lgen(dummy,Varout,1,SIZE(VarOut,2)*SIZE(VarOut,3)*SIZE(VarOut,4))
+    ENDIF
+#endif
+  END SUBROUTINE scatter_mpi_l3
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE gather_mpi_is(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+
+    INTEGER(i_std),INTENT(IN) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std) :: nb,i,index_para,rank
+    INTEGER(i_std) :: 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_mpi_is VarIn=",VarIn    
+
+#ifdef CPP_PARA
+    CALL MPI_GATHER(VarIn,1,MPI_INT_ORCH,VarOut,1,MPI_INT_ORCH,mpi_rank_root,MPI_COMM_ORCH,ierr)
+#endif
+
+    IF (check) &
+         WRITE(numout,*) "gather_mpi_is VarOut=",VarOut
+    IF (flag) CALL resume_timer(timer_mpi)
+#endif
+  END SUBROUTINE gather_mpi_is
+
+  SUBROUTINE gather_mpi_rs(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+
+    REAL(r_std),INTENT(IN) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std) :: nb,i,index_para,rank
+    INTEGER(i_std) :: 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_mpi_rs VarIn=",VarIn    
+
+#ifdef CPP_PARA
+    CALL MPI_GATHER(VarIn,1,MPI_REAL_ORCH,VarOut,1,MPI_REAL_ORCH,mpi_rank_root,MPI_COMM_ORCH,ierr)
+#endif
+
+    IF (check) &
+         WRITE(numout,*) "gather_mpi_rs VarOut=",VarOut
+
+    IF (flag) CALL resume_timer(timer_mpi)
+#endif
+  END SUBROUTINE gather_mpi_rs
+
+  SUBROUTINE gather_mpi_ls(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+
+    LOGICAL,INTENT(IN) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std) :: nb,i,index_para,rank
+    INTEGER(i_std) :: 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_mpi_ls VarIn=",VarIn    
+
+#ifdef CPP_PARA
+    CALL MPI_GATHER(VarIn,1,MPI_LOGICAL,VarOut,1,MPI_LOGICAL,mpi_rank_root,MPI_COMM_ORCH,ierr)
+#endif
+
+    IF (check) &
+         WRITE(numout,*) "gather_mpi_ls VarOut=",VarOut
+    IF (flag) CALL resume_timer(timer_mpi)
+#endif
+  END SUBROUTINE gather_mpi_ls
+
+!!!!! --> Les entiers
+
+  SUBROUTINE gather_mpi_i(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather_mpi_igen(VarIn,VarOut,SIZE(VarOut,1),1)
+    ELSE
+       CALL orch_gather_mpi_igen(VarIn,dummy,1,1)
+    ENDIF
+
+#endif
+  END SUBROUTINE gather_mpi_i
+
+!!!!!
+
+  SUBROUTINE gather_mpi_i1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1,SIZE(VarIn,2)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather_mpi_igen(VarIn,VarOut,SIZE(VarOut,1),SIZE(VarIn,2))
+    ELSE
+       CALL orch_gather_mpi_igen(VarIn,dummy,1,SIZE(VarIn,2))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather_mpi_i1
+
+!!!!!
+
+  SUBROUTINE gather_mpi_i2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1,SIZE(VarIn,2)*SIZE(VarIn,3)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather_mpi_igen(VarIn,VarOut,SIZE(VarOut,1),SIZE(VarIn,2)*SIZE(VarIn,3))
+    ELSE
+       CALL orch_gather_mpi_igen(VarIn,dummy,1,SIZE(VarIn,2)*SIZE(VarIn,3))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather_mpi_i2
+
+!!!!!
+
+  SUBROUTINE gather_mpi_i3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1,SIZE(VarIn,2)*SIZE(VarIn,3)*SIZE(VarIn,4)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather_mpi_igen(VarIn,VarOut,SIZE(VarOut,1),SIZE(VarIn,2)*SIZE(VarIn,3)*SIZE(VarIn,4))
+    ELSE
+       CALL orch_gather_mpi_igen(VarIn,dummy,1,SIZE(VarIn,2)*SIZE(VarIn,3)*SIZE(VarIn,4))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather_mpi_i3
+
+!!!!! --> Les reels
+
+  SUBROUTINE gather_mpi_r(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather_mpi_rgen(VarIn,VarOut,SIZE(VarOut,1),1)
+    ELSE
+       CALL orch_gather_mpi_rgen(VarIn,dummy,1,1)
+    ENDIF
+
+#endif
+  END SUBROUTINE gather_mpi_r
+
+!!!!!
+
+  SUBROUTINE gather_mpi_r1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1,SIZE(VarIn,2)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather_mpi_rgen(VarIn,VarOut,SIZE(VarOut,1),SIZE(VarIn,2))
+    ELSE
+       CALL orch_gather_mpi_rgen(VarIn,dummy,1,SIZE(VarIn,2))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather_mpi_r1
+
+!!!!!
+
+  SUBROUTINE gather_mpi_r2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1,SIZE(VarIn,2)*SIZE(VarIn,3)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather_mpi_rgen(VarIn,VarOut,SIZE(VarOut,1),SIZE(VarIn,2)*SIZE(VarIn,3))
+    ELSE
+       CALL orch_gather_mpi_rgen(VarIn,dummy,1,SIZE(VarIn,2)*SIZE(VarIn,3))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather_mpi_r2
+
+!!!!!
+
+  SUBROUTINE gather_mpi_r3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1,SIZE(VarIn,2)*SIZE(VarIn,3)*SIZE(VarIn,4)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather_mpi_rgen(VarIn,VarOut,SIZE(VarOut,1),SIZE(VarIn,2)*SIZE(VarIn,3)*SIZE(VarIn,4))
+    ELSE
+       CALL orch_gather_mpi_rgen(VarIn,dummy,1,SIZE(VarIn,2)*SIZE(VarIn,3)*SIZE(VarIn,4))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather_mpi_r3
+
+!!!!! --> Les booleen
+
+  SUBROUTINE gather_mpi_l(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+#ifdef CPP_PARA
+    LOGICAL,DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather_mpi_lgen(VarIn,VarOut,SIZE(VarOut,1),1)
+    ELSE
+       CALL orch_gather_mpi_lgen(VarIn,dummy,1,1)      
+    ENDIF
+
+#endif
+  END SUBROUTINE gather_mpi_l
+
+!!!!!
+
+  SUBROUTINE gather_mpi_l1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA
+    LOGICAL,DIMENSION(1,SIZE(VarIn,2)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather_mpi_lgen(VarIn,VarOut,SIZE(VarOut,1),SIZE(VarIn,2))
+    ELSE
+       CALL orch_gather_mpi_lgen(VarIn,dummy,1,SIZE(VarIn,2))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather_mpi_l1
+
+!!!!!
+
+  SUBROUTINE gather_mpi_l2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    LOGICAL,DIMENSION(1,SIZE(VarIn,2)*SIZE(VarIn,3)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather_mpi_lgen(VarIn,VarOut,SIZE(VarOut,1),SIZE(VarIn,2)*SIZE(VarIn,3))
+    ELSE
+       CALL orch_gather_mpi_lgen(VarIn,dummy,1,SIZE(VarIn,2)*SIZE(VarIn,3))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather_mpi_l2
+
+!!!!!
+
+  SUBROUTINE gather_mpi_l3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    LOGICAL,DIMENSION(1,SIZE(VarIn,2)*SIZE(VarIn,3)*SIZE(VarIn,4)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather_mpi_lgen(VarIn,VarOut,SIZE(VarOut,1),SIZE(VarIn,2)*SIZE(VarIn,3)*SIZE(VarIn,4))
+    ELSE
+       CALL orch_gather_mpi_lgen(VarIn,dummy,1,SIZE(VarIn,2)*SIZE(VarIn,3)*SIZE(VarIn,4))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather_mpi_l3
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter2D_mpi_i(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1,1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_scatter2D_mpi_igen(VarIn,VarOut,SIZE(VarIn,1)*SIZE(VarIn,2),1)
+    ELSE
+       CALL orch_scatter2D_mpi_igen(dummy,VarOut,1,1)
+    ENDIF
+
+
+#endif
+  END SUBROUTINE scatter2D_mpi_i
+
+  SUBROUTINE scatter2D_mpi_i1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1,SIZE(VarOut,3)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_scatter2D_mpi_igen(VarIn,VarOut,SIZE(VarIn,1)*SIZE(VarIn,2),SIZE(VarOut,3))
+    ELSE
+       CALL orch_scatter2D_mpi_igen(dummy,VarOut,1,SIZE(VarOut,3))
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter2D_mpi_i1
+
+  SUBROUTINE scatter2D_mpi_i2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1,SIZE(VarOut,3)*SIZE(VarOut,4)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_scatter2D_mpi_igen(VarIn,VarOut,SIZE(VarIn,1)*SIZE(VarIn,2),SIZE(VarOut,3)*SIZE(VarOut,4))
+    ELSE
+       CALL orch_scatter2D_mpi_igen(dummy,VarOut,1,SIZE(VarOut,3)*SIZE(VarOut,4))
+    ENDIF
+
+
+#endif
+  END SUBROUTINE scatter2D_mpi_i2
+
+  SUBROUTINE scatter2D_mpi_i3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:,:,:,:)  :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_scatter2D_mpi_igen(VarIn,VarOut,SIZE(VarIn,1)*SIZE(VarIn,2),SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
+    ELSE
+       CALL orch_scatter2D_mpi_igen(dummy,VarOut,1,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter2D_mpi_i3
+
+
+  SUBROUTINE scatter2D_mpi_r0(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_scatter2D_mpi_rgen(VarIn,VarOut,SIZE(VarIn,1),1)
+    ELSE
+       CALL orch_scatter2D_mpi_rgen(dummy,VarOut,1,1)      
+    ENDIF
+
+
+#endif
+  END SUBROUTINE scatter2D_mpi_r0
+
+  SUBROUTINE scatter2D_mpi_r(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL(r_std),INTENT(INOUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1,1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_scatter2D_mpi_rgen(VarIn,VarOut,SIZE(VarIn,1)*SIZE(VarIn,2),1)
+    ELSE
+       CALL orch_scatter2D_mpi_rgen(dummy,VarOut,1,1)
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter2D_mpi_r
+
+  SUBROUTINE scatter2D_mpi_r1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1,SIZE(VarOut,3)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_scatter2D_mpi_rgen(VarIn,VarOut,SIZE(VarIn,1)*SIZE(VarIn,2),SIZE(VarOut,3))
+    ELSE
+       CALL orch_scatter2D_mpi_rgen(dummy,VarOut,1,SIZE(VarOut,3))
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter2D_mpi_r1
+
+  SUBROUTINE scatter2D_mpi_r2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL(r_std),INTENT(INOUT),DIMENSION(:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1,SIZE(VarOut,3)*SIZE(VarOut,4)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_scatter2D_mpi_rgen(VarIn,VarOut,SIZE(VarIn,1)*SIZE(VarIn,2),SIZE(VarOut,3)*SIZE(VarOut,4))
+    ELSE
+       CALL orch_scatter2D_mpi_rgen(dummy,VarOut,1,SIZE(VarOut,3)*SIZE(VarOut,4))
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter2D_mpi_r2
+
+  SUBROUTINE scatter2D_mpi_r3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:,:,:)  :: VarIn
+    REAL(r_std),INTENT(INOUT),DIMENSION(:,:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_scatter2D_mpi_rgen(VarIn,VarOut,SIZE(VarIn,1)*SIZE(VarIn,2),SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
+    ELSE
+       CALL orch_scatter2D_mpi_rgen(dummy,VarOut,1,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter2D_mpi_r3
+
+
+  SUBROUTINE scatter2D_mpi_l(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA
+    LOGICAL,DIMENSION(1,1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_scatter2D_mpi_lgen(VarIn,VarOut,SIZE(VarIn,1)*SIZE(VarIn,2),1)
+    ELSE
+       CALL orch_scatter2D_mpi_lgen(dummy,VarOut,1,1)
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter2D_mpi_l
+
+  SUBROUTINE scatter2D_mpi_l1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(INOUT),DIMENSION(:,:,:) :: VarOut
+
+#ifdef CPP_PARA    
+    LOGICAL,DIMENSION(1,SIZE(VarOut,3)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_scatter2D_mpi_lgen(VarIn,VarOut,SIZE(VarIn,1)*SIZE(VarIn,2),SIZE(VarOut,3))
+    ELSE
+       CALL orch_scatter2D_mpi_lgen(dummy,VarOut,1,SIZE(VarOut,3))
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter2D_mpi_l1
+
+  SUBROUTINE scatter2D_mpi_l2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(INOUT),DIMENSION(:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    LOGICAL,DIMENSION(1,SIZE(VarOut,3)*SIZE(VarOut,4)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_scatter2D_mpi_lgen(VarIn,VarOut,SIZE(VarIn,1)*SIZE(VarIn,2),SIZE(VarOut,3)*SIZE(VarOut,4))
+    ELSE
+       CALL orch_scatter2D_mpi_lgen(dummy,VarOut,1,SIZE(VarOut,3)*SIZE(VarOut,4))
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter2D_mpi_l2
+
+  SUBROUTINE scatter2D_mpi_l3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:)  :: VarIn
+    LOGICAL,INTENT(INOUT),DIMENSION(:,:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    LOGICAL,DIMENSION(1,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_scatter2D_mpi_lgen(VarIn,VarOut,SIZE(VarIn,1)*SIZE(VarIn,2),SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
+    ELSE
+       CALL orch_scatter2D_mpi_lgen(dummy,VarOut,1,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter2D_mpi_l3
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE gather2D_mpi_i(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1,1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather2D_mpi_igen(VarIn,VarOut,SIZE(VarOut,1)*SIZE(VarOut,2),1)
+    ELSE
+       CALL orch_gather2D_mpi_igen(VarIn,dummy,1,1)
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_mpi_i
+
+  SUBROUTINE gather2D_mpi_i1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1,SIZE(VarIn,3)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather2D_mpi_igen(VarIn,VarOut,SIZE(VarOut,1)*SIZE(VarOut,2),SIZE(VarIn,3))
+    ELSE
+       CALL orch_gather2D_mpi_igen(VarIn,dummy,1,SIZE(VarIn,3))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_mpi_i1
+
+  SUBROUTINE gather2D_mpi_i2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1,SIZE(VarIn,3)*SIZE(VarIn,4)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather2D_mpi_igen(VarIn,VarOut,SIZE(VarOut,1)*SIZE(VarOut,2),SIZE(VarIn,3)*SIZE(VarIn,4))
+    ELSE
+       CALL orch_gather2D_mpi_igen(VarIn,dummy,1,SIZE(VarIn,3)*SIZE(VarIn,4))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_mpi_i2
+
+  SUBROUTINE gather2D_mpi_i3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather2D_mpi_igen(VarIn,VarOut,SIZE(VarOut,1)*SIZE(VarOut,2),SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
+    ELSE
+       CALL orch_gather2D_mpi_igen(VarIn,dummy,1,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_mpi_i3
+
+
+  SUBROUTINE gather2D_mpi_r0(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather2D_mpi_rgen(VarIn,VarOut,SIZE(VarOut,1),1)
+    ELSE
+       CALL orch_gather2D_mpi_rgen(VarIn,dummy,1,1)
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_mpi_r0
+
+  SUBROUTINE gather2D_mpi_r(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1,1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather2D_mpi_rgen(VarIn,VarOut,SIZE(VarOut,1)*SIZE(VarOut,2),1)
+    ELSE
+       CALL orch_gather2D_mpi_rgen(VarIn,dummy,1,1)
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_mpi_r
+
+  SUBROUTINE gather2D_mpi_r1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1,SIZE(VarIn,3)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather2D_mpi_rgen(VarIn,VarOut,SIZE(VarOut,1)*SIZE(VarOut,2),SIZE(VarIn,3))
+    ELSE
+       CALL orch_gather2D_mpi_rgen(VarIn,dummy,1,SIZE(VarIn,3))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_mpi_r1
+
+  SUBROUTINE gather2D_mpi_r2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1,SIZE(VarIn,3)*SIZE(VarIn,4)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather2D_mpi_rgen(VarIn,VarOut,SIZE(VarOut,1)*SIZE(VarOut,2),SIZE(VarIn,3)*SIZE(VarIn,4))
+    ELSE
+       CALL orch_gather2D_mpi_rgen(VarIn,dummy,1,SIZE(VarIn,3)*SIZE(VarIn,4))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_mpi_r2
+
+  SUBROUTINE gather2D_mpi_r3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather2D_mpi_rgen(VarIn,VarOut,SIZE(VarOut,1)*SIZE(VarOut,2),SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
+    ELSE
+       CALL orch_gather2D_mpi_rgen(VarIn,dummy,1,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_mpi_r3
+
+
+  SUBROUTINE gather2D_mpi_l(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA    
+    LOGICAL,DIMENSION(1,1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather2D_mpi_lgen(VarIn,VarOut,SIZE(VarOut,1)*SIZE(VarOut,2),1)
+    ELSE
+       CALL orch_gather2D_mpi_lgen(VarIn,dummy,1,1)
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_mpi_l
+
+  SUBROUTINE gather2D_mpi_l1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+#ifdef CPP_PARA    
+    LOGICAL,DIMENSION(1,SIZE(VarIn,3)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather2D_mpi_lgen(VarIn,VarOut,SIZE(VarOut,1)*SIZE(VarOut,2),SIZE(VarIn,3))
+    ELSE
+       CALL orch_gather2D_mpi_lgen(VarIn,dummy,1,SIZE(VarIn,3))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_mpi_l1
+
+  SUBROUTINE gather2D_mpi_l2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA    
+    LOGICAL,DIMENSION(1,SIZE(VarIn,3)*SIZE(VarIn,4)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather2D_mpi_lgen(VarIn,VarOut,SIZE(VarOut,1)*SIZE(VarOut,2),SIZE(VarIn,3)*SIZE(VarIn,4))
+    ELSE
+       CALL orch_gather2D_mpi_lgen(VarIn,dummy,1,SIZE(VarIn,3)*SIZE(VarIn,4))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_mpi_l2
+
+  SUBROUTINE gather2D_mpi_l3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA    
+    LOGICAL,DIMENSION(1,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5)) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_gather2D_mpi_lgen(VarIn,VarOut,SIZE(VarOut,1)*SIZE(VarOut,2),SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
+    ELSE
+       CALL orch_gather2D_mpi_lgen(VarIn,dummy,1,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_mpi_l3
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des reduce_sum   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE reduce_sum_mpi_i(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN)  :: VarIn
+    INTEGER(i_std),INTENT(OUT) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1) :: Var1
+    INTEGER(i_std),DIMENSION(1) :: Var2
+    INTEGER(i_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut=VarIn
+    RETURN
+#else
+    Var1(1)=VarIn
+    IF (is_mpi_root) THEN
+       CALL orch_reduce_sum_mpi_igen(Var1,Var2,1)
+       VarOut=Var2(1)
+    ELSE
+       CALL orch_reduce_sum_mpi_igen(Var1,dummy,1)
+       VarOut=VarIn
+    ENDIF
+#endif
+  END SUBROUTINE reduce_sum_mpi_i
+
+  SUBROUTINE reduce_sum_mpi_i1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+       CALL orch_reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+
+#endif
+  END SUBROUTINE reduce_sum_mpi_i1
+
+  SUBROUTINE reduce_sum_mpi_i2(VarIn, VarOut)
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+       CALL orch_reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+
+#endif
+  END SUBROUTINE reduce_sum_mpi_i2
+
+  SUBROUTINE reduce_sum_mpi_i3(VarIn, VarOut)
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+       CALL orch_reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+
+#endif
+  END SUBROUTINE reduce_sum_mpi_i3
+
+  SUBROUTINE reduce_sum_mpi_i4(VarIn, VarOut)
+    IMPLICIT NONE
+
+    INTEGER(i_std),INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER(i_std),INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    INTEGER(i_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+       CALL orch_reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+
+#endif
+  END SUBROUTINE reduce_sum_mpi_i4
+
+
+  SUBROUTINE reduce_sum_mpi_r(VarIn, VarOut)
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN)  :: VarIn
+    REAL(r_std),INTENT(OUT) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1) :: Var1
+    REAL(r_std),DIMENSION(1) :: Var2
+    REAL(r_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut=VarIn
+    RETURN
+#else
+
+    Var1(1)=VarIn
+    IF (is_mpi_root) THEN
+       CALL orch_reduce_sum_mpi_rgen(Var1,Var2,1)
+       VarOut=Var2(1)
+    ELSE
+       CALL orch_reduce_sum_mpi_rgen(Var1,dummy,1)
+       VarOut=VarIn
+    ENDIF
+
+#endif
+  END SUBROUTINE reduce_sum_mpi_r
+
+  SUBROUTINE reduce_sum_mpi_r1(VarIn, VarOut)
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+       CALL orch_reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+
+#endif
+  END SUBROUTINE reduce_sum_mpi_r1
+
+  SUBROUTINE reduce_sum_mpi_r2(VarIn, VarOut)
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+       CALL orch_reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+
+#endif
+  END SUBROUTINE reduce_sum_mpi_r2
+
+  SUBROUTINE reduce_sum_mpi_r3(VarIn, VarOut)
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+       CALL orch_reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+
+#endif
+  END SUBROUTINE reduce_sum_mpi_r3
+
+  SUBROUTINE reduce_sum_mpi_r4(VarIn, VarOut)
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL(r_std),DIMENSION(1) :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_mpi_root) THEN
+       CALL orch_reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+       CALL orch_reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+
+#endif
+  END SUBROUTINE reduce_sum_mpi_r4
+
+
+END MODULE mod_orchidee_mpi_transfert
+
+#ifdef CPP_PARA
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE orch_bcast_mpi_cgen(var,nb)
+  USE mod_orchidee_para_var
+  USE timer
+
+  IMPLICIT NONE
+
+  CHARACTER(LEN=*),DIMENSION(nb),INTENT(INOUT) :: Var
+  INTEGER(i_std),INTENT(IN) :: nb
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std) :: 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,*) "orch_bcast_mpi_cgen before bcast Var",Var    
+  IF (flag) CALL suspend_timer(timer_mpi)
+  CALL MPI_BCAST(Var,nb*LEN(Var(1)),MPI_CHARACTER,mpi_rank_root,MPI_COMM_ORCH,ierr)
+  IF (flag) CALL resume_timer(timer_mpi)
+  IF (check) &
+       WRITE(numout,*) "orch_bcast_mpi_cgen after bcast Var",Var
+
+END SUBROUTINE orch_bcast_mpi_cgen
+
+SUBROUTINE orch_bcast_mpi_igen(var,nb)
+  USE mod_orchidee_para_var
+  USE timer
+  IMPLICIT NONE
+
+  INTEGER(i_std),DIMENSION(nb),INTENT(INOUT) :: Var
+  INTEGER(i_std),INTENT(IN) :: nb
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std) :: 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,*) "orch_bcast_mpi_igen before bcast Var",Var
+  CALL MPI_BCAST(Var,nb,MPI_INT_ORCH,mpi_rank_root,MPI_COMM_ORCH,ierr)
+  IF (flag) CALL resume_timer(timer_mpi)
+  IF (check) &
+       WRITE(numout,*) "orch_bcast_mpi_igen after bcast Var",Var    
+
+END SUBROUTINE orch_bcast_mpi_igen
+
+SUBROUTINE orch_bcast_mpi_rgen(var,nb)
+  USE mod_orchidee_para_var
+  USE timer
+
+  IMPLICIT NONE
+
+  REAL(r_std),DIMENSION(nb),INTENT(INOUT) :: Var
+  INTEGER(i_std),INTENT(IN) :: nb
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std) :: 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,*) "orch_bcast_mpi_rgen before bcast Var",Var
+  IF (flag) CALL suspend_timer(timer_mpi)
+  CALL MPI_BCAST(Var,nb,MPI_REAL_ORCH,mpi_rank_root,MPI_COMM_ORCH,ierr)
+  IF (flag) CALL resume_timer(timer_mpi)
+  IF (check) &
+       WRITE(numout,*) "orch_bcast_mpi_rgen after bcast Var",Var
+
+END SUBROUTINE orch_bcast_mpi_rgen
+
+SUBROUTINE orch_bcast_mpi_lgen(var,nb)
+  USE mod_orchidee_para_var
+  USE timer
+
+  IMPLICIT NONE
+
+  LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var
+  INTEGER(i_std),INTENT(IN) :: nb
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std) :: 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,*) "orch_bcast_mpi_lgen before bcast Var",Var
+  IF (flag) CALL suspend_timer(timer_mpi)
+  CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_rank_root,MPI_COMM_ORCH,ierr)
+  IF (flag) CALL resume_timer(timer_mpi)
+  IF (check) &
+       WRITE(numout,*) "orch_bcast_mpi_lgen after bcast Var",Var
+
+END SUBROUTINE orch_bcast_mpi_lgen
+
+
+SUBROUTINE orch_scatter_mpi_igen(VarIn, VarOut, nbp, dimsize)
+  USE mod_orchidee_para_var
+  USE timer
+
+  IMPLICIT NONE
+
+  INTEGER(i_std),INTENT(IN) :: nbp
+  INTEGER(i_std),INTENT(IN) :: dimsize
+  INTEGER(i_std),INTENT(IN),DIMENSION(nbp,dimsize) :: VarIn
+  INTEGER(i_std),INTENT(OUT),DIMENSION(nbp_mpi,dimsize) :: VarOut
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std),DIMENSION(0:mpi_size-1) :: displs
+  INTEGER(i_std),DIMENSION(0:mpi_size-1) :: counts
+  INTEGER(i_std),DIMENSION(dimsize*nbp_glo) :: VarTmp
+
+  INTEGER(i_std) :: nb,i,index_para,rank
+  INTEGER(i_std) :: 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_mpi_root) THEN
+     Index_Para=1
+     DO rank=0,mpi_size-1
+        nb=nbp_mpi_para(rank)
+        displs(rank)=Index_Para-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+           VarTmp(Index_para:Index_para+nb-1)=VarIn(nbp_mpi_para_begin(rank):nbp_mpi_para_end(rank),i)
+           Index_para=Index_para+nb
+        ENDDO
+     ENDDO
+     IF (check) THEN
+        WRITE(numout,*) "orch_scatter_mpi_igen VarIn",VarIn
+        WRITE(numout,*) "orch_scatter_mpi_igen VarTmp",VarTmp
+     ENDIF
+  ENDIF
+
+  CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_INT_ORCH,VarOut,nbp_mpi*dimsize,   &
+       MPI_INT_ORCH,mpi_rank_root, MPI_COMM_ORCH,ierr)
+  IF (flag) CALL resume_timer(timer_mpi)
+  IF (check) &
+       WRITE(numout,*) "orch_scatter_mpi_igen VarOut",VarOut
+
+END SUBROUTINE orch_scatter_mpi_igen
+
+SUBROUTINE orch_scatter_mpi_rgen(VarIn, VarOut, nbp, dimsize)
+  USE mod_orchidee_para_var
+  USE timer
+
+  IMPLICIT NONE
+
+  INTEGER(i_std),INTENT(IN) :: dimsize
+  INTEGER(i_std),INTENT(IN) :: nbp
+  REAL(r_std),INTENT(IN),DIMENSION(nbp,dimsize) :: VarIn
+  REAL(r_std),INTENT(OUT),DIMENSION(nbp_mpi,dimsize) :: VarOut
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std),DIMENSION(0:mpi_size-1) :: displs
+  INTEGER(i_std),DIMENSION(0:mpi_size-1) :: counts
+  REAL(r_std),DIMENSION(dimsize*nbp_glo) :: VarTmp
+
+  INTEGER(i_std) :: nb,i,index_para,rank
+  INTEGER(i_std) :: 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_mpi_root) THEN
+     Index_para=1
+     DO rank=0,mpi_size-1
+        nb=nbp_mpi_para(rank)
+        displs(rank)=Index_para-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+           VarTmp(Index_para:Index_para+nb-1)=VarIn(nbp_mpi_para_begin(rank):nbp_mpi_para_end(rank),i)
+           Index_para=Index_para+nb
+        ENDDO
+     ENDDO
+     IF (check) THEN
+        WRITE(numout,*) "orch_scatter_mpi_rgen VarIn",VarIn
+        WRITE(numout,*) "orch_scatter_mpi_rgen VarTmp",VarTmp
+     ENDIF
+  ENDIF
+
+  CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_REAL_ORCH,VarOut,nbp_mpi*dimsize,   &
+       MPI_REAL_ORCH,mpi_rank_root, MPI_COMM_ORCH,ierr)
+
+  IF (flag) CALL resume_timer(timer_mpi)
+  IF (check) &
+       WRITE(numout,*) "orch_scatter_mpi_rgen VarOut",VarOut
+
+END SUBROUTINE orch_scatter_mpi_rgen
+
+SUBROUTINE orch_scatter_mpi_lgen(VarIn, VarOut, nbp, dimsize)
+  USE mod_orchidee_para_var
+  USE timer
+
+  IMPLICIT NONE
+
+  INTEGER(i_std),INTENT(IN) :: dimsize
+  INTEGER(i_std),INTENT(IN) :: nbp
+  LOGICAL,INTENT(IN),DIMENSION(nbp,dimsize) :: VarIn
+  LOGICAL,INTENT(OUT),DIMENSION(nbp_mpi,dimsize) :: VarOut
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std),DIMENSION(0:mpi_size-1) :: displs
+  INTEGER(i_std),DIMENSION(0:mpi_size-1) :: counts
+  LOGICAL,DIMENSION(dimsize*nbp_glo) :: VarTmp
+
+  INTEGER(i_std) :: nb,i,index_para,rank
+  INTEGER(i_std) :: 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_mpi_root) THEN
+     Index_para=1
+     DO rank=0,mpi_size-1
+        nb=nbp_mpi_para(rank)
+        displs(rank)=Index_para-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+           VarTmp(Index_para:Index_para+nb-1)=VarIn(nbp_mpi_para_begin(rank):nbp_mpi_para_end(rank),i)
+           Index_para=Index_para+nb
+        ENDDO
+     ENDDO
+     IF (check) THEN
+        WRITE(numout,*) "orch_scatter_mpi_lgen VarIn",VarIn
+        WRITE(numout,*) "orch_scatter_mpi_lgen VarTmp",VarTmp
+     ENDIF
+  ENDIF
+
+  CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_LOGICAL,VarOut,nbp_mpi*dimsize,   &
+       MPI_LOGICAL,mpi_rank_root, MPI_COMM_ORCH,ierr)
+  IF (flag) CALL resume_timer(timer_mpi)
+  IF (check) &
+       WRITE(numout,*) "orch_scatter_mpi_lgen VarOut",VarOut
+
+END SUBROUTINE orch_scatter_mpi_lgen
+
+SUBROUTINE orch_gather_mpi_igen(VarIn, VarOut, nbp, dimsize)
+  USE mod_orchidee_para_var
+  USE timer
+
+  IMPLICIT NONE
+
+  INTEGER(i_std),INTENT(IN) :: dimsize
+  INTEGER(i_std),INTENT(IN) :: nbp
+  INTEGER(i_std),INTENT(IN),DIMENSION(nbp_mpi,dimsize) :: VarIn
+  INTEGER(i_std),INTENT(OUT),DIMENSION(nbp,dimsize) :: VarOut
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std),DIMENSION(0:mpi_size-1) :: displs
+  INTEGER(i_std),DIMENSION(0:mpi_size-1) :: counts
+  INTEGER(i_std),DIMENSION(dimsize*nbp_glo) :: VarTmp
+
+  INTEGER(i_std) :: nb,i,index_para,rank
+  INTEGER(i_std) :: 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_mpi_root) THEN
+     Index_para=1
+     DO rank=0,mpi_size-1
+        nb=nbp_mpi_para(rank)
+        displs(rank)=Index_para-1
+        counts(rank)=nb*dimsize
+	Index_para=Index_para+nb*dimsize
+     ENDDO
+     IF (check) &
+          WRITE(numout,*) "orch_gather_mpi_igen nbp_mpi_para, displs, counts,Index_Para-1",nbp_mpi_para, displs, counts,Index_Para-1
+
+  ENDIF
+
+  CALL MPI_GATHERV(VarIn,nbp_mpi*dimsize,MPI_INT_ORCH,VarTmp,counts,displs,   &
+       MPI_INT_ORCH,mpi_rank_root, MPI_COMM_ORCH,ierr)
+
+
+  IF (is_mpi_root) THEN
+     Index_para=1
+     DO rank=0,mpi_size-1
+        nb=nbp_mpi_para(rank)
+        DO i=1,dimsize
+           VarOut(nbp_mpi_para_begin(rank):nbp_mpi_para_end(rank),i)=VarTmp(Index_para:Index_para+nb-1)
+           Index_para=Index_para+nb
+        ENDDO
+     ENDDO
+  ENDIF
+  IF (check) &
+       WRITE(numout,*) "orch_gather_mpi_igen VarOut=",VarOut
+  IF (flag) CALL resume_timer(timer_mpi)
+
+END SUBROUTINE orch_gather_mpi_igen
+
+SUBROUTINE orch_gather_mpi_rgen(VarIn, VarOut, nbp, dimsize)
+  USE mod_orchidee_para_var
+  USE timer
+
+  IMPLICIT NONE
+
+  INTEGER(i_std),INTENT(IN) :: dimsize
+  INTEGER(i_std),INTENT(IN) :: nbp
+  REAL(r_std),INTENT(IN),DIMENSION(nbp_mpi,dimsize) :: VarIn
+  REAL(r_std),INTENT(OUT),DIMENSION(nbp,dimsize) :: VarOut
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std),DIMENSION(0:mpi_size-1) :: displs
+  INTEGER(i_std),DIMENSION(0:mpi_size-1) :: counts
+  REAL(r_std),DIMENSION(dimsize*nbp_glo) :: VarTmp
+
+  INTEGER(i_std) :: nb,i,index_para,rank
+  INTEGER(i_std) :: 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_mpi_root) THEN
+     Index_para=1
+     DO rank=0,mpi_size-1
+        nb=nbp_mpi_para(rank)
+        displs(rank)=Index_para-1
+        counts(rank)=nb*dimsize
+	Index_para=Index_para+nb*dimsize
+     ENDDO
+     IF (check) &
+          WRITE(numout,*) "orch_gather_mpi_rgen nbp_mpi_para, displs, counts,Index_Para-1",nbp_mpi_para, displs, counts,Index_Para-1
+
+  ENDIF
+
+  IF (check) &
+       WRITE(numout,*) "orch_gather_mpi_rgen VarIn=",VarIn    
+  CALL MPI_GATHERV(VarIn,nbp_mpi*dimsize,MPI_REAL_ORCH,VarTmp,counts,displs,   &
+       MPI_REAL_ORCH,mpi_rank_root, MPI_COMM_ORCH,ierr)
+  IF (check) &
+       WRITE(numout,*) "orch_gather_mpi_rgen dimsize,VarTmp=",dimsize,VarTmp
+
+  IF (is_mpi_root) THEN
+     Index_para=1
+     DO rank=0,mpi_size-1
+        nb=nbp_mpi_para(rank)
+        DO i=1,dimsize
+           VarOut(nbp_mpi_para_begin(rank):nbp_mpi_para_end(rank),i)=VarTmp(Index_para:Index_para+nb-1)
+           Index_para=Index_para+nb
+        ENDDO
+     ENDDO
+  ENDIF
+  IF (check) &
+       WRITE(numout,*) "orch_gather_mpi_rgen VarOut=",VarOut
+  IF (flag) CALL resume_timer(timer_mpi)
+
+END SUBROUTINE orch_gather_mpi_rgen
+
+SUBROUTINE orch_gather_mpi_lgen(VarIn, VarOut, nbp, dimsize)
+  USE mod_orchidee_para_var
+  USE timer
+
+  IMPLICIT NONE
+
+  INTEGER(i_std),INTENT(IN) :: dimsize
+  INTEGER(i_std),INTENT(IN) :: nbp
+  LOGICAL,INTENT(IN),DIMENSION(nbp_mpi,dimsize) :: VarIn
+  LOGICAL,INTENT(OUT),DIMENSION(nbp,dimsize) :: VarOut
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std),DIMENSION(0:mpi_size-1) :: displs
+  INTEGER(i_std),DIMENSION(0:mpi_size-1) :: counts
+  LOGICAL,DIMENSION(dimsize*nbp_glo) :: VarTmp
+
+  INTEGER(i_std) :: nb,i,index_para,rank
+  INTEGER(i_std) :: 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_mpi_root) THEN
+     Index_para=1
+     DO rank=0,mpi_size-1
+        nb=nbp_mpi_para(rank)
+        displs(rank)=Index_para-1
+        counts(rank)=nb*dimsize
+	Index_para=Index_para+nb*dimsize
+     ENDDO
+     IF (check) &
+          WRITE(numout,*) "orch_gather_mpi_lgen nbp_mpi_para, displs, counts,Index_Para-1",nbp_mpi_para, displs, counts,Index_Para-1
+  ENDIF
+
+  IF (check) &
+       WRITE(numout,*) "orch_gather_mpi_lgen VarIn=",VarIn    
+  CALL MPI_GATHERV(VarIn,nbp_mpi*dimsize,MPI_LOGICAL,VarTmp,counts,displs,   &
+       MPI_LOGICAL,mpi_rank_root, MPI_COMM_ORCH,ierr)
+  IF (check) &
+       WRITE(numout,*) "orch_gather_mpi_lgen dimsize,VarTmp=",dimsize,VarTmp
+
+  IF (is_mpi_root) THEN
+     Index_para=1
+     DO rank=0,mpi_size-1
+        nb=nbp_mpi_para(rank)
+        DO i=1,dimsize
+           VarOut(nbp_mpi_para_begin(rank):nbp_mpi_para_end(rank),i)=VarTmp(Index_para:Index_para+nb-1)
+           Index_para=Index_para+nb
+        ENDDO
+     ENDDO
+  ENDIF
+  IF (check) &
+       WRITE(numout,*) "orch_gather_mpi_lgen VarOut=",VarOut
+  IF (flag) CALL resume_timer(timer_mpi)
+
+END SUBROUTINE orch_gather_mpi_lgen
+
+
+SUBROUTINE orch_scatter2D_mpi_igen(VarIn, VarOut, nbp2D, dimsize)
+  USE mod_orchidee_para_var, iim=>iim_g,jjm=>jjm_g
+  USE timer
+
+  IMPLICIT NONE
+
+  INTEGER(i_std),INTENT(IN) :: dimsize
+  INTEGER(i_std),INTENT(IN) :: nbp2D
+  INTEGER(i_std),INTENT(IN),DIMENSION(nbp2D,dimsize) :: VarIn
+  INTEGER(i_std),INTENT(OUT),DIMENSION(iim*jj_nb,dimsize) :: VarOut
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std),DIMENSION(0:mpi_size-1)      :: displs
+  INTEGER(i_std),DIMENSION(0:mpi_size-1)      :: counts
+  INTEGER(i_std),DIMENSION(dimsize*iim*jjm)   :: VarTmp1
+  INTEGER(i_std),DIMENSION(ij_nb,dimsize)     :: VarTmp2
+
+  INTEGER(i_std) :: nb,i,ij,index_para,rank
+  INTEGER(i_std) :: 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_mpi_root) 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,*) "orch_scatter2D_mpi_igen VarIn",VarIn
+        WRITE(numout,*) "orch_scatter2D_mpi_igen VarTmp1",VarTmp1
+     ENDIF
+  ENDIF
+
+  CALL MPI_SCATTERV(VarTmp1,counts,displs,MPI_INT_ORCH,VarTmp2,ij_nb*dimsize,   &
+       MPI_INT_ORCH,mpi_rank_root, MPI_COMM_ORCH,ierr)
+  IF (check) &
+       WRITE(numout,*) "orch_scatter2D_mpi_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,*) "orch_scatter2D_mpi_igen VarOut",VarOut
+
+END SUBROUTINE orch_scatter2D_mpi_igen
+
+SUBROUTINE orch_scatter2D_mpi_rgen(VarIn, VarOut, nbp2D, dimsize)
+  USE mod_orchidee_para_var, iim=>iim_g,jjm=>jjm_g
+  USE timer
+
+  IMPLICIT NONE
+
+  INTEGER(i_std),INTENT(IN) :: dimsize
+  INTEGER(i_std),INTENT(IN) :: nbp2D
+  REAL(r_std),INTENT(IN),DIMENSION(nbp2D,dimsize) :: VarIn
+  REAL(r_std),INTENT(INOUT),DIMENSION(iim*jj_nb,dimsize) :: VarOut
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std),DIMENSION(0:mpi_size-1)      :: displs
+  INTEGER(i_std),DIMENSION(0:mpi_size-1)      :: counts
+  REAL(r_std),DIMENSION(dimsize*iim*jjm)   :: VarTmp1
+  REAL(r_std),DIMENSION(ij_nb,dimsize)     :: VarTmp2
+
+  INTEGER(i_std) :: nb,i,ij,index_para,rank
+  INTEGER(i_std) :: 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_mpi_root) 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,*) "orch_scatter2D_mpi_rgen VarIn",VarIn
+        WRITE(numout,*) "orch_scatter2D_mpi_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,mpi_rank_root, MPI_COMM_ORCH,ierr)
+  IF (check) &
+       WRITE(numout,*) "orch_scatter2D_mpi_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,*) "orch_scatter2D_mpi_rgen VarOut",VarOut
+
+END SUBROUTINE orch_scatter2D_mpi_rgen
+
+SUBROUTINE orch_scatter2D_mpi_lgen(VarIn, VarOut, nbp2D, dimsize)
+  USE mod_orchidee_para_var, iim=>iim_g,jjm=>jjm_g
+  USE timer
+
+  IMPLICIT NONE
+
+  INTEGER(i_std),INTENT(IN) :: dimsize
+  INTEGER(i_std),INTENT(IN) :: nbp2D
+  LOGICAL,INTENT(IN),DIMENSION(nbp2D,dimsize) :: VarIn
+  LOGICAL,INTENT(INOUT),DIMENSION(iim*jj_nb,dimsize) :: VarOut
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std),DIMENSION(0:mpi_size-1)      :: displs
+  INTEGER(i_std),DIMENSION(0:mpi_size-1)      :: counts
+  LOGICAL,DIMENSION(dimsize*iim*jjm)   :: VarTmp1
+  LOGICAL,DIMENSION(ij_nb,dimsize)     :: VarTmp2
+
+  INTEGER(i_std) :: nb,i,ij,index_para,rank
+  INTEGER(i_std) :: 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_mpi_root) 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,*) "orch_scatter2D_mpi_lgen VarIn",VarIn
+        WRITE(numout,*) "orch_scatter2D_mpi_lgen VarTmp1",VarTmp1
+     ENDIF
+  ENDIF
+
+  CALL MPI_SCATTERV(VarTmp1,counts,displs,MPI_LOGICAL,VarTmp2,ij_nb*dimsize,   &
+       MPI_LOGICAL,mpi_rank_root, MPI_COMM_ORCH,ierr)
+  IF (check) &
+       WRITE(numout,*) "orch_scatter2D_mpi_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,*) "orch_scatter2D_mpi_lgen VarOut",VarOut
+
+END SUBROUTINE orch_scatter2D_mpi_lgen
+
+
+SUBROUTINE orch_gather2D_mpi_igen(VarIn, VarOut, nbp2D, dimsize)
+  USE mod_orchidee_para_var, iim=>iim_g,jjm=>jjm_g
+  USE timer
+
+  IMPLICIT NONE
+
+  INTEGER(i_std),INTENT(IN) :: dimsize
+  INTEGER(i_std),INTENT(IN) :: nbp2D
+  INTEGER(i_std),INTENT(IN),DIMENSION(iim*jj_nb,dimsize)  :: VarIn
+  INTEGER(i_std),INTENT(OUT),DIMENSION(nbp2D,dimsize) :: VarOut
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std),DIMENSION(0:mpi_size-1)    :: displs
+  INTEGER(i_std),DIMENSION(0:mpi_size-1)    :: counts
+  INTEGER(i_std),DIMENSION(ij_nb,dimsize)   :: VarTmp1
+  INTEGER(i_std),DIMENSION(dimsize*iim*jjm) :: VarTmp2
+
+  INTEGER(i_std) :: nb,i,ij,index_para,rank
+  INTEGER(i_std) :: 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_mpi_root) THEN
+     Index_para=1
+
+     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,*) "orch_gather2D_mpi_igen nbp_mpi_para, displs, counts,Index_Para-1",nbp_mpi_para, 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,*) "orch_gather2D_mpi_igen VarIn=",VarIn    
+     WRITE(numout,*) "orch_gather2D_mpi_igen VarTmp1=",VarTmp1
+  ENDIF
+  CALL MPI_GATHERV(VarTmp1,ij_nb*dimsize,MPI_INT_ORCH,VarTmp2,counts,displs,   &
+       MPI_INT_ORCH,mpi_rank_root, MPI_COMM_ORCH,ierr)
+  IF (check) &
+       WRITE(numout,*) "orch_gather2D_mpi_igen VarTmp2=",VarTmp2
+
+  IF (is_mpi_root) 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,*) "orch_gather2D_mpi_igen VarOut=",VarOut
+
+END SUBROUTINE orch_gather2D_mpi_igen
+
+SUBROUTINE orch_gather2D_mpi_rgen(VarIn, VarOut, nbp2D,dimsize)
+  USE mod_orchidee_para_var, iim=>iim_g,jjm=>jjm_g
+  USE timer
+
+  IMPLICIT NONE
+
+  INTEGER(i_std),INTENT(IN) :: dimsize
+  INTEGER(i_std),INTENT(IN) :: nbp2D
+  REAL(r_std),INTENT(IN),DIMENSION(iim*jj_nb,dimsize)  :: VarIn
+  REAL(r_std),INTENT(OUT),DIMENSION(nbp2D,dimsize) :: VarOut
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std),DIMENSION(0:mpi_size-1)    :: displs
+  INTEGER(i_std),DIMENSION(0:mpi_size-1)    :: counts
+  REAL(r_std),DIMENSION(ij_nb,dimsize)   :: VarTmp1
+  REAL(r_std),DIMENSION(dimsize*iim*jjm) :: VarTmp2
+
+  INTEGER(i_std) :: nb,i,ij,index_para,rank
+  INTEGER(i_std) :: 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_mpi_root) THEN
+     Index_para=1
+
+     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,*) "orch_gather2D_mpi_rgen nbp_mpi_para, displs, counts,Index_Para-1",nbp_mpi_para, 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,*) "orch_gather2D_mpi_rgen VarIn=",VarIn    
+     WRITE(numout,*) "orch_gather2D_mpi_rgen VarTmp1=",VarTmp1
+  ENDIF
+  CALL MPI_GATHERV(VarTmp1,ij_nb*dimsize,MPI_REAL_ORCH,VarTmp2,counts,displs,   &
+       MPI_REAL_ORCH,mpi_rank_root, MPI_COMM_ORCH,ierr)
+  IF (check) &
+       WRITE(numout,*) "orch_gather2D_mpi_rgen VarTmp2=",VarTmp2
+
+  IF (is_mpi_root) 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,*) "orch_gather2D_mpi_rgen VarOut=",VarOut
+
+END SUBROUTINE orch_gather2D_mpi_rgen
+
+SUBROUTINE orch_gather2D_mpi_lgen(VarIn, VarOut, nbp2D, dimsize)
+  USE mod_orchidee_para_var, iim=>iim_g,jjm=>jjm_g
+  USE timer
+
+  IMPLICIT NONE
+
+  INTEGER(i_std),INTENT(IN) :: dimsize
+  INTEGER(i_std),INTENT(IN) :: nbp2D
+  LOGICAL,INTENT(IN),DIMENSION(iim*jj_nb,dimsize)  :: VarIn
+  LOGICAL,INTENT(OUT),DIMENSION(nbp2D,dimsize) :: VarOut
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std),DIMENSION(0:mpi_size-1)    :: displs
+  INTEGER(i_std),DIMENSION(0:mpi_size-1)    :: counts
+  LOGICAL,DIMENSION(ij_nb,dimsize)   :: VarTmp1
+  LOGICAL,DIMENSION(dimsize*iim*jjm) :: VarTmp2
+
+  INTEGER(i_std) :: nb,i,ij,index_para,rank
+  INTEGER(i_std) :: 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_mpi_root) THEN
+     Index_para=1
+
+     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,*) "orch_gather2D_mpi_lgen nbp_mpi_para, displs, counts,Index_Para-1",nbp_mpi_para, 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,*) "orch_gather2D_mpi_lgen VarIn=",VarIn    
+     WRITE(numout,*) "orch_gather2D_mpi_lgen VarTmp1=",VarTmp1
+  ENDIF
+  CALL MPI_GATHERV(VarTmp1,ij_nb*dimsize,MPI_LOGICAL,VarTmp2,counts,displs,   &
+       MPI_LOGICAL,mpi_rank_root, MPI_COMM_ORCH,ierr)
+  IF (check) &
+       WRITE(numout,*) "orch_gather2D_mpi_lgen VarTmp2=",VarTmp2
+
+  IF (is_mpi_root) 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,*) "orch_gather2D_mpi_lgen VarOut=",VarOut
+
+END SUBROUTINE orch_gather2D_mpi_lgen
+
+SUBROUTINE orch_reduce_sum_mpi_igen(VarIn,VarOut,nb)
+  USE mod_orchidee_para_var
+  USE timer
+
+  IMPLICIT NONE
+
+  INTEGER(i_std),DIMENSION(nb),INTENT(IN) :: VarIn
+  INTEGER(i_std),DIMENSION(nb),INTENT(OUT) :: VarOut    
+  INTEGER(i_std),INTENT(IN) :: nb
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std) :: 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,*) "orch_reduce_sum_mpi_igen VarIn",VarIn
+  IF (flag) CALL suspend_timer(timer_mpi)
+
+  CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_INT_ORCH,MPI_SUM,mpi_rank_root,MPI_COMM_ORCH,ierr)
+
+  IF (flag) CALL resume_timer(timer_mpi)
+  IF (check) &
+       WRITE(numout,*) "orch_reduce_sum_mpi_igen VarOut",VarOut
+
+END SUBROUTINE orch_reduce_sum_mpi_igen
+
+SUBROUTINE orch_reduce_sum_mpi_rgen(VarIn,VarOut,nb)
+  USE mod_orchidee_para_var
+  USE timer
+
+  IMPLICIT NONE
+
+  REAL(r_std),DIMENSION(nb),INTENT(IN) :: VarIn
+  REAL(r_std),DIMENSION(nb),INTENT(OUT) :: VarOut    
+  INTEGER(i_std),INTENT(IN) :: nb
+
+  INCLUDE 'mpif.h'
+
+  INTEGER(i_std) :: 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,*) "orch_reduce_sum_mpi_rgen VarIn",VarIn
+  IF (flag) CALL suspend_timer(timer_mpi)
+
+  CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_REAL_ORCH,MPI_SUM,mpi_rank_root,MPI_COMM_ORCH,ierr)
+
+  IF (flag) CALL resume_timer(timer_mpi)
+  IF (check) &
+       WRITE(numout,*) "orch_reduce_sum_mpi_rgen VarOut",VarOut
+
+END SUBROUTINE orch_reduce_sum_mpi_rgen
+
+#endif
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_omp_data.F90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_omp_data.F90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_omp_data.F90	(revision 7236)
@@ -0,0 +1,224 @@
+! Definition and allocation of parallel datas for OpenMP.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/Attic/mod_orchidee_omp_data.F90,v 1.1.2.3 2008/11/05 10:08:25 ssipsl Exp $
+!- 
+
+MODULE mod_orchidee_omp_data
+
+!-
+  USE defprec
+  USE ioipsl
+  USE mod_orchidee_para_var
+
+  IMPLICIT NONE
+
+CONTAINS
+
+    SUBROUTINE barrier2_omp()
+
+    IMPLICIT NONE
+
+!$OMP BARRIER
+!$OMP BARRIER
+
+  END SUBROUTINE barrier2_omp
+
+
+
+  
+  SUBROUTINE Init_orchidee_omp
+  IMPLICIT NONE
+  
+#ifdef CPP_OMP
+    IF (is_omp_root) THEN
+        is_ok_omp=.TRUE.
+    ENDIF
+#else    
+    is_ok_omp=.FALSE.
+#endif
+
+
+    IF (is_ok_omp) THEN
+      STOP 'Open MP is not yet implemented for driver'
+    ELSE
+      omp_size=1
+      omp_rank=0
+      is_omp_root=.TRUE.
+    ENDIF
+
+  END SUBROUTINE Init_orchidee_omp
+
+  SUBROUTINE Init_numout_omp(numout)
+    INTEGER, INTENT(in) :: numout
+    numout_omp=numout
+  END SUBROUTINE Init_numout_omp
+
+
+  SUBROUTINE Init_orchidee_omp_data(arg_omp_size,arg_omp_rank,arg_nbp_omp,arg_offset_omp)
+    IMPLICIT NONE
+    INTEGER, INTENT(IN) :: arg_omp_size
+    INTEGER, INTENT(IN) :: arg_omp_rank
+    INTEGER, INTENT(IN) :: arg_nbp_omp
+    INTEGER, INTENT(IN) :: arg_offset_omp
+    
+    INTEGER    :: i
+    
+    
+    IF (arg_omp_rank==0) THEN
+      is_omp_root=.TRUE.
+    ELSE
+      is_omp_root=.FALSE.
+    ENDIF
+    
+#ifdef CPP_OMP
+    IF (is_omp_root) THEN
+        is_ok_omp=.TRUE.
+    ENDIF
+#else    
+    is_ok_omp=.FALSE.
+#endif
+
+    IF (is_omp_root) omp_size=arg_omp_size
+
+    CALL barrier2_omp()
+
+     omp_rank=arg_omp_rank
+    
+    IF (is_omp_root) THEN 
+      ALLOCATE(nbp_omp_para_nb(0:omp_size-1))
+      ALLOCATE(nbp_omp_para_begin(0:omp_size-1))
+      ALLOCATE(nbp_omp_para_end(0:omp_size-1))
+    ENDIF
+    
+    CALL barrier2_omp()
+    nbp_omp_para_nb(omp_rank)=arg_nbp_omp
+    CALL barrier2_omp()
+    
+    IF (is_omp_root) THEN
+
+      nbp_omp_para_begin(0)=1
+      nbp_omp_para_end(0)=nbp_omp_para_nb(0)
+
+      DO i=1,omp_size-1
+        nbp_omp_para_begin(i)=nbp_omp_para_end(i-1)+1
+        nbp_omp_para_end(i)=nbp_omp_para_begin(i)+nbp_omp_para_nb(i)-1
+      ENDDO
+
+    ENDIF
+
+    CALL barrier2_omp()
+     
+    nbp_omp=nbp_omp_para_nb(omp_rank)
+    nbp_omp_begin=nbp_omp_para_begin(omp_rank)
+    nbp_omp_end=nbp_omp_para_end(omp_rank)
+    
+    offset_omp=arg_offset_omp          
+    CALL Print_omp_data
+    
+    CALL Init_synchro_omp()
+    
+  END SUBROUTINE Init_orchidee_omp_data
+
+  SUBROUTINE print_omp_data
+  IMPLICIT NONE
+
+!$OMP CRITICAL  
+  PRINT *,'--------> ORCHIDEE TASK ',omp_rank
+  PRINT *,'omp_size =',omp_size
+  PRINT *,'omp_rank =',omp_rank
+  PRINT *,'is_omp_root =',is_omp_root
+  PRINT *,'offset_omp',offset_omp
+  PRINT *,'nbp_omp_para_nb =',nbp_omp_para_nb
+  PRINT *,'nbp_omp_para_begin =',nbp_omp_para_begin
+  PRINT *,'nbp_omp_para_end =',nbp_omp_para_end    
+  PRINT *,'nbp_omp =',nbp_omp
+  PRINT *,'nbp_omp_begin =',nbp_omp_begin
+  PRINT *,'nbp_omp_end =',nbp_omp_end    
+!$OMP END CRITICAL
+
+  END SUBROUTINE print_omp_data
+
+  SUBROUTINE Init_synchro_omp
+  IMPLICIT NONE
+    
+    IF (is_omp_root) THEN
+      ALLOCATE(proc_synchro_omp(0:omp_size-1))
+      proc_synchro_omp(:)=.FALSE.
+
+      IF ( check_all_transfert ) THEN
+         ALLOCATE(omp_function(0:omp_size-1))
+         omp_function(:)=-1
+      ENDIF
+    ENDIF
+    CALL barrier2_omp()
+
+  END SUBROUTINE Init_Synchro_omp
+  
+  SUBROUTINE Synchro_omp
+  IMPLICIT NONE
+    INTEGER iter
+    LOGICAL, PARAMETER :: check=.TRUE.
+    INTEGER, PARAMETER :: iter_max=1
+    INTEGER, PARAMETER :: print_iter=1
+
+    proc_synchro_omp(omp_rank)=.TRUE.
+    CALL barrier2_omp()
+
+    iter=0
+    DO WHILE (.NOT. ALL(proc_synchro_omp))
+       iter=iter+1
+       IF ( mod(iter,print_iter) == 0 ) THEN
+          IF (numout_omp > 0) THEN
+             WRITE(numout_omp,*) "ORCHIDEE SYNCHRO OMP : iter ",iter," rank ",omp_rank," wait for ",proc_synchro_omp
+          ELSE
+             WRITE(*,*) "ORCHIDEE SYNCHRO OMP : iter ",iter," rank ",omp_rank," wait for ",proc_synchro_omp
+          ENDIF
+       ENDIF
+       IF (check) THEN
+          IF (iter > iter_max) THEN
+             IF (numout_omp > 0) THEN
+                WRITE(numout_omp,*) "TOO MUCH WAIT in Synchro_Omp !! iter ",iter," rank ",omp_rank," wait for ",proc_synchro_omp
+                WRITE(numout_omp,*) "We stop here"
+                WRITE(numout_omp,*) "omp_function : ",omp_function(:)
+             ELSE
+                WRITE(*,*) "TOO MUCH WAIT in Synchro_Omp !! iter ",iter," rank ",omp_rank," wait for ",proc_synchro_omp
+                WRITE(*,*) "We stop here"
+                WRITE(*,*) "omp_function : ",omp_function(:)
+             ENDIF
+#ifdef CPP_PARA
+             CALL MPI_ABORT(4)
+#endif     
+             STOP 'Fatal error from ORCHIDEE : Synchro_Omp failed'
+          ENDIF
+       ENDIF
+    CALL barrier2_omp()
+    ENDDO
+    CALL barrier2_omp()
+    proc_synchro_omp(omp_rank)=.FALSE.
+    CALL barrier2_omp()
+
+   END SUBROUTINE Synchro_omp
+
+   SUBROUTINE print_omp_function ()
+
+     IF ( check_all_transfert ) THEN
+        CALL barrier2_omp()
+        IF (numout_omp > 0) THEN
+           WRITE(numout_omp,*) omp_rank,&
+                " : ",omp_fct_name(omp_previous),'->',omp_fct_name(omp_function(omp_rank))
+           IF (MINVAL(omp_function(:)).LT.MAXVAL(omp_function(:))) &
+                WRITE(numout_omp,*) "!!! OMP ERROR : NO MORE SYNCHRO  !!!  ",omp_function(:)
+        ELSE
+           WRITE(*,*) omp_rank,&
+                " : ",omp_fct_name(omp_previous),'->',omp_fct_name(omp_function(omp_rank))
+           IF (MINVAL(omp_function(:)).LT.MAXVAL(omp_function(:))) &
+                WRITE(*,*) "!!! OMP ERROR : NO MORE SYNCHRO  !!!  ",omp_function(:)
+        ENDIF
+        CALL barrier2_omp()
+     ENDIF
+
+  END SUBROUTINE print_omp_function
+
+
+END MODULE mod_orchidee_omp_data
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_omp_transfert.F90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_omp_transfert.F90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_omp_transfert.F90	(revision 7236)
@@ -0,0 +1,2114 @@
+! Low level OpenMP parallel communication encapsulations for ORCHIDEE.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/Attic/mod_orchidee_omp_transfert.F90,v 1.1.2.2 2008/08/29 14:01:40 ssipsl Exp $
+!-
+
+MODULE mod_orchidee_omp_transfert
+  !-
+  USE defprec
+  USE mod_orchidee_omp_data
+  USE ioipsl
+  !-
+  IMPLICIT NONE
+
+  PRIVATE
+  
+#ifdef CPP_OMP
+  ! Check OpenMP buffer sizes increase.
+  LOGICAL, PARAMETER :: check_size = .FALSE.
+
+  INTEGER,PARAMETER :: grow_factor=1.5
+  INTEGER,PARAMETER :: size_min=1024
+  PUBLIC size_min
+
+  INTEGER(i_std),SAVE,ALLOCATABLE,DIMENSION(:) :: omp_ibuffer
+  INTEGER,SAVE                            :: size_i=0
+  LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: omp_lbuffer
+  INTEGER,SAVE                            :: size_l=0
+  REAL(r_std),SAVE,ALLOCATABLE,DIMENSION(:) :: omp_rbuffer
+  INTEGER,SAVE                            :: size_r=0
+  CHARACTER(len=size_min), SAVE,ALLOCATABLE,DIMENSION(:) :: omp_cbuffer
+  INTEGER,SAVE                            :: size_c=0
+
+#endif
+
+  INTERFACE bcast_omp
+     MODULE PROCEDURE bcast_omp_c, bcast_omp_c1,                                       &
+          bcast_omp_i,bcast_omp_i1,bcast_omp_i2,bcast_omp_i3,bcast_omp_i4, &
+          bcast_omp_r,bcast_omp_r1,bcast_omp_r2,bcast_omp_r3,bcast_omp_r4, &
+          bcast_omp_l,bcast_omp_l1,bcast_omp_l2,bcast_omp_l3,bcast_omp_l4
+  END INTERFACE
+
+  INTERFACE scatter_omp
+     MODULE PROCEDURE scatter_omp_i,scatter_omp_i1,scatter_omp_i2,scatter_omp_i3, &
+          scatter_omp_r,scatter_omp_r1,scatter_omp_r2,scatter_omp_r3, &
+          scatter_omp_l,scatter_omp_l1,scatter_omp_l2,scatter_omp_l3
+  END INTERFACE
+
+
+  INTERFACE gather_omp
+     MODULE PROCEDURE gather_omp_i0,gather_omp_i,gather_omp_i1,gather_omp_i2,gather_omp_i3, &
+          gather_omp_r0,gather_omp_r,gather_omp_r1,gather_omp_r2,gather_omp_r3, &
+          gather_omp_l0,gather_omp_l,gather_omp_l1,gather_omp_l2,gather_omp_l3  
+  END INTERFACE
+
+
+  INTERFACE reduce_sum_omp
+     MODULE PROCEDURE reduce_sum_omp_i,reduce_sum_omp_i1,reduce_sum_omp_i2,reduce_sum_omp_i3,reduce_sum_omp_i4, &
+          reduce_sum_omp_r,reduce_sum_omp_r1,reduce_sum_omp_r2,reduce_sum_omp_r3,reduce_sum_omp_r4
+  END INTERFACE
+
+  PUBLIC  bcast_omp,scatter_omp,gather_omp,reduce_sum_omp
+
+CONTAINS
+
+  SUBROUTINE check_buffer_c(buff_size)
+    IMPLICIT NONE
+    INTEGER :: buff_size
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)= 72 
+      CALL print_omp_function()
+    ENDIF
+#ifdef CPP_OMP
+    CALL barrier2_omp()
+    IF (is_omp_root) THEN
+       IF (buff_size>size_c) THEN
+          IF ( check_size ) THEN
+             IF (numout_omp > 0) THEN
+               WRITE(numout_omp,*) "ORCHIDEE OMP; buffer for strings : old_size, new_size"
+             ELSE
+               WRITE(*,*) "ORCHIDEE OMP; buffer for strings : old_size, new_size"
+             ENDIF
+             IF (ALLOCATED(omp_cbuffer)) THEN
+                IF (numout_omp > 0) THEN
+                  WRITE(numout_omp,*) SIZE(omp_cbuffer)
+                ELSE
+                  WRITE(*,*) SIZE(omp_cbuffer)
+                ENDIF
+             ELSE
+                IF (numout_omp > 0) THEN
+                  WRITE(numout_omp,*) 0
+                ELSE
+                  WRITE(*,*) 0
+                ENDIF
+             ENDIF
+          ENDIF
+          IF (ALLOCATED(omp_cbuffer)) DEALLOCATE(omp_cbuffer)
+          size_c=MAX(size_min,INT(grow_factor*buff_size))
+          IF ( check_size ) THEN
+             IF (numout_omp > 0) THEN
+               WRITE(numout_omp,*) size_c
+             ELSE
+               WRITE(*,*) size_c
+             ENDIF
+          ENDIF
+          ALLOCATE(omp_cbuffer(size_c))
+       ENDIF
+    ENDIF
+    CALL barrier2_omp()
+
+#endif
+
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE check_buffer_c
+
+  SUBROUTINE check_buffer_i(buff_size)
+    IMPLICIT NONE
+    INTEGER :: buff_size
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)= 1 
+      CALL print_omp_function()
+    ENDIF
+#ifdef CPP_OMP
+    CALL barrier2_omp()
+
+    IF (is_omp_root) THEN
+       IF (buff_size>size_i) THEN
+          IF ( check_size ) THEN
+             IF (numout_omp > 0) THEN
+               WRITE(numout_omp,*) "ORCHIDEE OMP; buffer for integers : old_size, new_size"
+             ELSE
+               WRITE(*,*) "ORCHIDEE OMP; buffer for integers : old_size, new_size"
+             ENDIF
+             IF (ALLOCATED(omp_ibuffer)) THEN
+                IF (numout_omp > 0) THEN
+                  WRITE(numout_omp,*) SIZE(omp_ibuffer)
+                ELSE
+                  WRITE(*,*) SIZE(omp_ibuffer)
+                ENDIF
+             ELSE
+                IF (numout_omp > 0) THEN
+                  WRITE(numout_omp,*) 0
+                ELSE
+                  WRITE(*,*) 0
+                ENDIF
+             ENDIF
+          ENDIF
+          IF (ALLOCATED(omp_ibuffer)) DEALLOCATE(omp_ibuffer)
+          size_i=MAX(size_min,INT(grow_factor*buff_size))
+          IF ( check_size ) THEN
+             IF (numout_omp > 0) THEN
+               WRITE(numout_omp,*) size_i
+             ELSE
+               WRITE(*,*) size_i
+             ENDIF
+          ENDIF
+          ALLOCATE(omp_ibuffer(size_i))
+       ENDIF
+    ENDIF
+    CALL barrier2_omp()
+
+#endif
+
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE check_buffer_i
+  
+  SUBROUTINE check_buffer_r(buff_size)
+    IMPLICIT NONE
+    INTEGER :: buff_size
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)= 2
+      CALL print_omp_function()
+    ENDIF
+#ifdef CPP_OMP
+    CALL barrier2_omp()
+
+    IF (is_omp_root) THEN
+       IF (buff_size>size_r) THEN
+          IF ( check_size ) THEN
+             IF (numout_omp > 0) THEN
+               WRITE(numout_omp,*) "ORCHIDEE OMP; buffer for reals : old_size, new_size"
+             ELSE
+               WRITE(*,*) "ORCHIDEE OMP; buffer for reals : old_size, new_size"
+             ENDIF
+             IF (ALLOCATED(omp_rbuffer)) THEN
+                IF (numout_omp > 0) THEN
+                  WRITE(numout_omp,*) SIZE(omp_rbuffer)
+                ELSE
+                  WRITE(*,*) SIZE(omp_rbuffer)
+                ENDIF
+             ELSE
+                IF (numout_omp > 0) THEN
+                  WRITE(numout_omp,*) 0
+                ELSE
+                  WRITE(*,*) 0
+                ENDIF
+             ENDIF
+          ENDIF
+          IF (ALLOCATED(omp_rbuffer)) DEALLOCATE(omp_rbuffer)
+          size_r=MAX(size_min,INT(grow_factor*buff_size))
+          IF ( check_size ) THEN
+             IF (numout_omp > 0) THEN
+               WRITE(numout_omp,*) size_r
+             ELSE
+               WRITE(*,*) size_r
+             ENDIF
+          ENDIF
+          ALLOCATE(omp_rbuffer(size_r))
+       ENDIF
+    ENDIF
+    CALL barrier2_omp()
+
+#endif
+
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE check_buffer_r
+  
+  SUBROUTINE check_buffer_l(buff_size)
+    IMPLICIT NONE
+    INTEGER :: buff_size
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)= 3
+      CALL print_omp_function()
+    ENDIF
+#ifdef CPP_OMP
+    CALL barrier2_omp()
+
+    IF (is_omp_root) THEN
+       IF (buff_size>size_l) THEN
+          IF ( check_size ) THEN
+             IF (numout_omp > 0) THEN
+               WRITE(numout_omp,*) "ORCHIDEE OMP; buffer for logicals : old_size, new_size"
+             ELSE
+               WRITE(*,*) "ORCHIDEE OMP; buffer for logicals : old_size, new_size"
+             ENDIF
+             IF (ALLOCATED(omp_lbuffer)) THEN
+                IF (numout_omp > 0) THEN
+                  WRITE(numout_omp,*) SIZE(omp_lbuffer)
+                ELSE
+                  WRITE(*,*) SIZE(omp_lbuffer)
+                ENDIF
+             ELSE
+                IF (numout_omp > 0) THEN
+                  WRITE(numout_omp,*) 0
+                ELSE
+                  WRITE(*,*) 0
+                ENDIF
+             ENDIF
+          ENDIF
+          IF (ALLOCATED(omp_lbuffer)) DEALLOCATE(omp_lbuffer)
+          size_l=MAX(size_min,INT(grow_factor*buff_size))
+          IF ( check_size ) THEN
+             IF (numout_omp > 0) THEN
+               WRITE(numout_omp,*) size_l
+             ELSE
+               WRITE(*,*) size_l
+             ENDIF
+          ENDIF
+          ALLOCATE(omp_lbuffer(size_l))
+       ENDIF
+    ENDIF
+    CALL barrier2_omp()
+
+#endif
+
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE check_buffer_l
+    
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Broadcast --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  !! -- Les chaine de charactère -- !!
+
+  SUBROUTINE bcast_omp_c(Var)
+    IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+    CHARACTER(LEN=len(Var)),DIMENSION(1) :: Var1
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)= 4
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    IF (is_omp_root) &
+         Var1(1)=Var
+    CALL check_buffer_c(1)
+    CALL orch_bcast_omp_cgen(Var1,1,omp_cbuffer)
+    Var=Var1(1)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_c
+
+  SUBROUTINE bcast_omp_c1(Var)
+    IMPLICIT NONE
+    CHARACTER(LEN=*),DIMENSION(:),INTENT(INOUT) :: Var
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)= 4
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    CALL check_buffer_c(size(Var))
+    CALL orch_bcast_omp_cgen(Var,size(Var),omp_cbuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_c1
+
+  !! -- Les entiers -- !!
+
+  SUBROUTINE bcast_omp_i(var1)
+    IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var1
+
+    INTEGER,DIMENSION(1) :: Var
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)= 5
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    IF (is_omp_root) &
+         Var(1)=Var1
+    CALL check_buffer_i(1)
+    CALL orch_bcast_omp_igen(Var,1,omp_ibuffer)
+    Var1=Var(1)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_i
+
+  SUBROUTINE bcast_omp_i1(var)
+    IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)= 6
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    CALL check_buffer_i(size(Var))
+    CALL orch_bcast_omp_igen(Var,SIZE(Var),omp_ibuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_i1
+
+  SUBROUTINE bcast_omp_i2(var)
+    IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)= 7
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    CALL check_buffer_i(size(Var))
+    CALL orch_bcast_omp_igen(Var,SIZE(Var),omp_ibuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_i2
+
+  SUBROUTINE bcast_omp_i3(var)
+    IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)= 8
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    CALL check_buffer_i(size(Var))
+    CALL orch_bcast_omp_igen(Var,SIZE(Var),omp_ibuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_i3
+
+  SUBROUTINE bcast_omp_i4(var)
+    IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)= 9
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    CALL check_buffer_i(size(Var))
+    CALL orch_bcast_omp_igen(Var,SIZE(Var),omp_ibuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_i4
+
+
+  !! -- Les reels -- !!
+
+  SUBROUTINE bcast_omp_r(var)
+    IMPLICIT NONE
+    REAL(r_std),INTENT(INOUT) :: Var
+
+    REAL(r_std),DIMENSION(1) :: Var1
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=10
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    IF (is_omp_root) &
+         Var1(1)=Var
+    CALL check_buffer_r(1)
+    CALL orch_bcast_omp_rgen(Var1,1,omp_rbuffer)
+    Var=Var1(1)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_r
+
+  SUBROUTINE bcast_omp_r1(var)
+    IMPLICIT NONE
+    REAL(r_std),INTENT(INOUT) :: Var(:)
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=11
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    CALL check_buffer_r(size(Var))
+    CALL orch_bcast_omp_rgen(Var,SIZE(Var),omp_rbuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_r1
+
+  SUBROUTINE bcast_omp_r2(var)
+    IMPLICIT NONE
+    REAL(r_std),INTENT(INOUT) :: Var(:,:)
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=12
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    CALL check_buffer_r(size(Var))
+    CALL orch_bcast_omp_rgen(Var,SIZE(Var),omp_rbuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_r2
+
+  SUBROUTINE bcast_omp_r3(var)
+    IMPLICIT NONE
+    REAL(r_std),INTENT(INOUT) :: Var(:,:,:)
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=13
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    CALL check_buffer_r(size(Var))
+    CALL orch_bcast_omp_rgen(Var,SIZE(Var),omp_rbuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_r3
+
+  SUBROUTINE bcast_omp_r4(var)
+    IMPLICIT NONE
+    REAL(r_std),INTENT(INOUT) :: Var(:,:,:,:)
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=14
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    CALL check_buffer_r(size(Var))
+    CALL orch_bcast_omp_rgen(Var,SIZE(Var),omp_rbuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_r4
+
+  !! -- Les booleans -- !!
+
+  SUBROUTINE bcast_omp_l(var)
+    IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+
+    LOGICAL,DIMENSION(1) :: Var1
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=15
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    IF (is_omp_root) &
+         Var1(1)=Var
+    CALL check_buffer_l(1)
+    CALL orch_bcast_omp_lgen(Var1,1,omp_lbuffer)
+    Var=Var1(1)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_l
+
+  SUBROUTINE bcast_omp_l1(var)
+    IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=16
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    CALL check_buffer_l(size(Var))
+    CALL orch_bcast_omp_lgen(Var,SIZE(Var),omp_lbuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_l1
+
+  SUBROUTINE bcast_omp_l2(var)
+    IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=17
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    CALL check_buffer_l(size(Var))
+    CALL orch_bcast_omp_lgen(Var,SIZE(Var),omp_lbuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_l2
+
+  SUBROUTINE bcast_omp_l3(var)
+    IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=18
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    CALL check_buffer_l(size(Var))
+    CALL orch_bcast_omp_lgen(Var,SIZE(Var),omp_lbuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_l3
+
+  SUBROUTINE bcast_omp_l4(var)
+    IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=19
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    RETURN
+#else
+    CALL check_buffer_l(size(Var))
+    CALL orch_bcast_omp_lgen(Var,SIZE(Var),omp_lbuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE bcast_omp_l4
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_omp_i(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=20
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+    CALL check_buffer_i(size(VarIn))   
+    CALL orch_scatter_omp_igen(VarIn,Varout,1,omp_ibuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE scatter_omp_i
+
+  SUBROUTINE scatter_omp_i1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=21
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+    CALL check_buffer_i(size(VarIn))   
+    CALL orch_scatter_omp_igen(VarIn,Varout,SIZE(VarOut,2),omp_ibuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE scatter_omp_i1
+
+  SUBROUTINE scatter_omp_i2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=22
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else    
+    CALL check_buffer_i(size(VarIn))   
+    CALL orch_scatter_omp_igen(VarIn,Varout,SIZE(VarOut,2)*SIZE(VarOut,3),omp_ibuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE scatter_omp_i2
+
+  SUBROUTINE scatter_omp_i3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=23
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else    
+    CALL check_buffer_i(size(VarIn))   
+    CALL orch_scatter_omp_igen(VarIn,Varout,SIZE(VarOut,2)*SIZE(VarOut,3)*SIZE(VarOut,4),omp_ibuffer)
+#endif  
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE scatter_omp_i3
+
+
+  SUBROUTINE scatter_omp_r(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=24
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+    CALL check_buffer_r(size(VarIn))   
+    CALL orch_scatter_omp_rgen(VarIn,Varout,1,omp_rbuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE scatter_omp_r
+
+  SUBROUTINE scatter_omp_r1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=25
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+    CALL check_buffer_r(size(VarIn))   
+    CALL orch_scatter_omp_rgen(VarIn,Varout,SIZE(VarOut,2),omp_rbuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE scatter_omp_r1
+
+  SUBROUTINE scatter_omp_r2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=26
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+    CALL check_buffer_r(size(VarIn))   
+    CALL orch_scatter_omp_rgen(VarIn,Varout,SIZE(VarOut,2)*SIZE(VarOut,3),omp_rbuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE scatter_omp_r2
+
+  SUBROUTINE scatter_omp_r3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=27
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+    CALL check_buffer_r(size(VarIn))   
+    CALL orch_scatter_omp_rgen(VarIn,Varout,SIZE(VarOut,2)*SIZE(VarOut,3)*SIZE(VarOut,4),omp_rbuffer)
+#endif  
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE scatter_omp_r3
+
+
+  SUBROUTINE scatter_omp_l(VarIn, VarOut)
+
+    IMPLICIT NONE
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=28
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+    CALL check_buffer_l(size(VarIn))   
+    CALL orch_scatter_omp_lgen(VarIn,Varout,1,omp_lbuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE scatter_omp_l
+
+  SUBROUTINE scatter_omp_l1(VarIn, VarOut)
+
+    IMPLICIT NONE
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=29
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+    CALL check_buffer_l(size(VarIn))   
+    CALL orch_scatter_omp_lgen(VarIn,Varout,SIZE(VarOut,2),omp_lbuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE scatter_omp_l1
+
+  SUBROUTINE scatter_omp_l2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=30
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+    CALL check_buffer_l(size(VarIn))   
+    CALL orch_scatter_omp_lgen(VarIn,Varout,SIZE(VarOut,2)*SIZE(VarOut,3),omp_lbuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE scatter_omp_l2
+
+  SUBROUTINE scatter_omp_l3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=31
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+    CALL check_buffer_l(size(VarIn))   
+    CALL orch_scatter_omp_lgen(VarIn,Varout,SIZE(VarOut,2)*SIZE(VarOut,3)*SIZE(VarOut,4),omp_lbuffer)
+#endif  
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE scatter_omp_l3
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE gather_omp_i0(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN)               :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=32
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:)=VarIn
+    RETURN
+#else
+    CALL check_buffer_i(size(VarOut))   
+    CALL orch_gather_omp_simple_igen(VarIn,Varout,omp_ibuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE gather_omp_i0
+
+!!!!! --> Les entiers
+
+  SUBROUTINE gather_omp_i(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=33
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+    CALL check_buffer_i(size(VarOut))   
+    CALL orch_gather_omp_igen(VarIn,Varout,1,omp_ibuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE gather_omp_i
+
+
+  SUBROUTINE gather_omp_i1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=34
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+    CALL check_buffer_i(size(VarOut))   
+    CALL orch_gather_omp_igen(VarIn,Varout,SIZE(VarIn,2),omp_ibuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE gather_omp_i1
+
+
+  SUBROUTINE gather_omp_i2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=35
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+    CALL check_buffer_i(size(VarOut))   
+    CALL orch_gather_omp_igen(VarIn,Varout,SIZE(VarIn,2)*SIZE(VarIn,3),omp_ibuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE gather_omp_i2
+
+
+  SUBROUTINE gather_omp_i3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=36
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+    CALL check_buffer_i(size(VarOut))   
+    CALL orch_gather_omp_igen(VarIn,Varout,SIZE(VarIn,2)*SIZE(VarIn,3)*SIZE(VarIn,4),omp_ibuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE gather_omp_i3
+
+!!!!! --> Les reels
+
+  SUBROUTINE gather_omp_r0(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN)               :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=37
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:)=VarIn
+    RETURN
+#else
+    CALL check_buffer_r(size(VarOut))   
+    CALL orch_gather_omp_simple_rgen(VarIn,Varout,omp_rbuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE gather_omp_r0
+
+  SUBROUTINE gather_omp_r(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=38
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+    CALL check_buffer_r(size(VarOut))   
+    CALL orch_gather_omp_rgen(VarIn,Varout,1,omp_rbuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE gather_omp_r
+
+
+  SUBROUTINE gather_omp_r1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=39
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+    CALL check_buffer_r(size(VarOut))   
+    CALL orch_gather_omp_rgen(VarIn,Varout,SIZE(VarIn,2),omp_rbuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE gather_omp_r1
+
+
+  SUBROUTINE gather_omp_r2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=40
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+    CALL check_buffer_r(size(VarOut))   
+    CALL orch_gather_omp_rgen(VarIn,Varout,SIZE(VarIn,2)*SIZE(VarIn,3),omp_rbuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE gather_omp_r2
+
+
+  SUBROUTINE gather_omp_r3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=41
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+    CALL check_buffer_r(size(VarOut))   
+    CALL orch_gather_omp_rgen(VarIn,Varout,SIZE(VarIn,2)*SIZE(VarIn,3)*SIZE(VarIn,4),omp_rbuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE gather_omp_r3
+
+!!!!! --> Les booleen
+
+  SUBROUTINE gather_omp_l0(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN)               :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=42
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:)=VarIn
+    RETURN
+#else
+    CALL check_buffer_l(size(VarOut))   
+    CALL orch_gather_omp_simple_lgen(VarIn,Varout,omp_lbuffer)
+#endif
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE gather_omp_l0
+
+  SUBROUTINE gather_omp_l(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=43
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+    CALL check_buffer_l(size(VarOut))   
+    CALL orch_gather_omp_lgen(VarIn,Varout,1,omp_lbuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE gather_omp_l
+
+
+  SUBROUTINE gather_omp_l1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=44
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+    CALL check_buffer_l(size(VarOut))   
+    CALL orch_gather_omp_lgen(VarIn,Varout,SIZE(VarIn,2),omp_lbuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE gather_omp_l1
+
+
+  SUBROUTINE gather_omp_l2(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=45
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+    CALL check_buffer_l(size(VarOut))   
+    CALL orch_gather_omp_lgen(VarIn,Varout,SIZE(VarIn,2)*SIZE(VarIn,3),omp_lbuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE gather_omp_l2
+
+
+  SUBROUTINE gather_omp_l3(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=46
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+    CALL check_buffer_l(size(VarOut))   
+    CALL orch_gather_omp_lgen(VarIn,Varout,SIZE(VarIn,2)*SIZE(VarIn,3)*SIZE(VarIn,4),omp_lbuffer)
+#endif    
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE gather_omp_l3
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des reduce_sum   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE reduce_sum_omp_i(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=47
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut=VarIn
+    RETURN
+#else
+    CALL check_buffer_i(1)   
+    CALL orch_reduce_sum_omp_igen(VarIn,Varout,1,omp_ibuffer)
+#endif  
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE reduce_sum_omp_i
+
+  SUBROUTINE reduce_sum_omp_i1(VarIn, VarOut)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=48
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+    CALL check_buffer_i(size(VarIn))   
+    CALL orch_reduce_sum_omp_igen(VarIn,Varout,SIZE(VarIn),omp_ibuffer)
+#endif   
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE reduce_sum_omp_i1
+
+  SUBROUTINE reduce_sum_omp_i2(VarIn, VarOut)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=49
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+    CALL check_buffer_i(size(VarIn))   
+    CALL orch_reduce_sum_omp_igen(VarIn,Varout,SIZE(VarIn),omp_ibuffer)
+#endif  
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE reduce_sum_omp_i2
+
+  SUBROUTINE reduce_sum_omp_i3(VarIn, VarOut)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=50
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+    CALL check_buffer_i(size(VarIn))   
+    CALL orch_reduce_sum_omp_igen(VarIn,Varout,SIZE(VarIn),omp_ibuffer)
+#endif  
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE reduce_sum_omp_i3
+
+  SUBROUTINE reduce_sum_omp_i4(VarIn, VarOut)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=51
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+    CALL check_buffer_i(size(VarIn))   
+    CALL orch_reduce_sum_omp_igen(VarIn,Varout,SIZE(VarIn),omp_ibuffer)
+#endif  
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE reduce_sum_omp_i4
+
+
+  SUBROUTINE reduce_sum_omp_r(VarIn, VarOut)
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN)  :: VarIn
+    REAL(r_std),INTENT(OUT) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=52
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut=VarIn
+    RETURN
+#else
+    CALL check_buffer_r(1)   
+    CALL orch_reduce_sum_omp_rgen(VarIn,Varout,1,omp_rbuffer)
+#endif  
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE reduce_sum_omp_r
+
+  SUBROUTINE reduce_sum_omp_r1(VarIn, VarOut)
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=53
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+    CALL check_buffer_r(size(VarIn))   
+    CALL orch_reduce_sum_omp_rgen(VarIn,Varout,SIZE(VarIn),omp_rbuffer)
+#endif   
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE reduce_sum_omp_r1
+
+  SUBROUTINE reduce_sum_omp_r2(VarIn, VarOut)
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=54
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+    CALL check_buffer_r(size(VarIn))   
+    CALL orch_reduce_sum_omp_rgen(VarIn,Varout,SIZE(VarIn),omp_rbuffer)
+#endif  
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE reduce_sum_omp_r2
+
+  SUBROUTINE reduce_sum_omp_r3(VarIn, VarOut)
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=55
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+    CALL check_buffer_r(size(VarIn))   
+    CALL orch_reduce_sum_omp_rgen(VarIn,Varout,SIZE(VarIn),omp_rbuffer)
+#endif  
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE reduce_sum_omp_r3
+
+  SUBROUTINE reduce_sum_omp_r4(VarIn, VarOut)
+    IMPLICIT NONE
+
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    IF ( check_all_transfert ) THEN
+      omp_previous=omp_function(omp_rank)
+      omp_function(omp_rank)=56
+      CALL print_omp_function()
+    ENDIF
+#ifndef CPP_OMP
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+    CALL check_buffer_r(size(VarIn))   
+    CALL orch_reduce_sum_omp_rgen(VarIn,Varout,SIZE(VarIn),omp_rbuffer)
+#endif  
+    IF ( check_all_transfert ) &
+        omp_function(omp_rank)=omp_previous
+  END SUBROUTINE reduce_sum_omp_r4
+
+END MODULE mod_orchidee_omp_transfert
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+#ifdef CPP_OMP
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE orch_bcast_omp_cgen(Var,Nb,Buff)
+  USE mod_orchidee_omp_data
+  USE mod_orchidee_omp_transfert, ONLY : size_min
+
+  IMPLICIT NONE
+  INTEGER,INTENT(IN)              :: Nb 
+  CHARACTER(LEN=*),DIMENSION(Nb),INTENT(INOUT) :: Var
+  CHARACTER(LEN=*),DIMENSION(Nb),INTENT(INOUT) :: Buff
+  INTEGER :: i
+  LOGICAL, PARAMETER :: check=.FALSE.
+
+  IF ( check_all_transfert ) THEN
+    omp_previous=omp_function(omp_rank)
+    omp_function(omp_rank)=57
+    CALL print_omp_function()
+  ENDIF
+
+  IF (check) THEN
+     IF (numout_omp > 0) THEN
+        WRITE(numout_omp,*) "orch_bcast_omp_cgen before bcast Var",Var
+     ELSE
+        WRITE(*,*) "orch_bcast_omp_cgen before bcast Var",Var
+     ENDIF
+  ENDIF
+
+  IF (is_omp_root) THEN
+     IF ( len(Var) > size_min ) &
+          CALL ipslerr (3,'orch_bcast_omp_cgen', &
+          &          'Error with omp_cbuffer.', 'len(Var) > size_min', &
+          &          '(Increase size_min in mod_orchidee_omp_transfert.)')
+     DO i=1,Nb
+        Buff(i)=TRIM(Var(i))
+     ENDDO
+  ENDIF
+
+  CALL barrier2_omp()
+
+  DO i=1,Nb
+     Var(i)=Buff(i)
+  ENDDO
+  CALL barrier2_omp()
+      
+  IF (check) THEN
+     IF (numout_omp > 0) THEN
+        WRITE(numout_omp,*) "orch_bcast_omp_cgen after bcast Var",Var
+     ELSE
+        WRITE(*,*) "orch_bcast_omp_cgen after bcast Var",Var
+     ENDIF
+  ENDIF
+
+  IF ( check_all_transfert ) &
+      omp_function(omp_rank)=omp_previous
+END SUBROUTINE orch_bcast_omp_cgen
+
+
+
+SUBROUTINE orch_bcast_omp_igen(Var,Nb,Buff)
+  USE mod_orchidee_omp_data
+
+  IMPLICIT NONE
+
+  INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Var
+  INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Buff
+  INTEGER,INTENT(IN) :: Nb  
+
+  INTEGER :: i
+
+  IF ( check_all_transfert ) THEN
+    omp_previous=omp_function(omp_rank)
+    omp_function(omp_rank)=58
+    CALL print_omp_function()
+  ENDIF
+
+  IF (is_omp_root) THEN
+     DO i=1,Nb
+        Buff(i)=Var(i)
+     ENDDO
+  ENDIF
+
+  CALL barrier2_omp()
+
+
+  DO i=1,Nb
+     Var(i)=Buff(i)
+  ENDDO
+
+  CALL barrier2_omp()
+
+  IF ( check_all_transfert ) &
+      omp_function(omp_rank)=omp_previous
+END SUBROUTINE orch_bcast_omp_igen
+
+
+
+SUBROUTINE orch_bcast_omp_rgen(Var,Nb,Buff)
+  USE mod_orchidee_omp_data
+
+  IMPLICIT NONE
+
+  REAL(r_std),DIMENSION(Nb),INTENT(INOUT) :: Var
+  REAL(r_std),DIMENSION(Nb),INTENT(INOUT) :: Buff
+  INTEGER,INTENT(IN) :: Nb
+
+  INTEGER :: i
+
+  IF ( check_all_transfert ) THEN
+    omp_previous=omp_function(omp_rank)
+    omp_function(omp_rank)=59
+    CALL print_omp_function()
+  ENDIF
+
+  IF (is_omp_root) THEN
+     DO i=1,Nb
+        Buff(i)=Var(i)
+     ENDDO
+  ENDIF
+
+  CALL barrier2_omp()
+
+  DO i=1,Nb
+     Var(i)=Buff(i)
+  ENDDO
+
+  CALL barrier2_omp()
+
+  IF ( check_all_transfert ) &
+      omp_function(omp_rank)=omp_previous
+END SUBROUTINE orch_bcast_omp_rgen
+
+
+
+SUBROUTINE orch_bcast_omp_lgen(Var,Nb,Buff)
+  USE mod_orchidee_omp_data
+
+  IMPLICIT NONE
+
+  LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Var
+  LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
+  INTEGER,INTENT(IN) :: Nb
+
+  INTEGER :: i
+
+  IF ( check_all_transfert ) THEN
+    omp_previous=omp_function(omp_rank)
+    omp_function(omp_rank)=60
+    CALL print_omp_function()
+  ENDIF
+
+  IF (is_omp_root) THEN
+     DO i=1,Nb
+        Buff(i)=Var(i)
+     ENDDO
+  ENDIF
+
+  CALL barrier2_omp()
+
+  DO i=1,Nb
+     Var(i)=Buff(i)
+  ENDDO
+
+  CALL barrier2_omp()
+
+  IF ( check_all_transfert ) &
+      omp_function(omp_rank)=omp_previous
+END SUBROUTINE orch_bcast_omp_lgen
+
+
+
+SUBROUTINE orch_scatter_omp_igen(VarIn,VarOut,dimsize,Buff)
+  USE mod_orchidee_omp_data
+  USE mod_orchidee_para_var, ONLY : nbp_mpi 
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: dimsize
+  INTEGER,INTENT(IN),DIMENSION(nbp_mpi,dimsize) :: VarIn
+  INTEGER,INTENT(OUT),DIMENSION(nbp_omp,dimsize) :: VarOut
+  INTEGER,INTENT(INOUT),DIMENSION(nbp_mpi,dimsize) :: Buff
+
+  INTEGER :: i,ij
+
+  IF ( check_all_transfert ) THEN
+    omp_previous=omp_function(omp_rank)
+    omp_function(omp_rank)=61
+    CALL print_omp_function()
+  ENDIF
+
+  IF (is_omp_root) THEN
+     DO i=1,dimsize
+        DO ij=1,nbp_mpi
+           Buff(ij,i)=VarIn(ij,i)
+        ENDDO
+     ENDDO
+  ENDIF
+
+  CALL barrier2_omp()
+
+  DO i=1,dimsize
+     DO ij=1,nbp_omp
+        VarOut(ij,i)=Buff(nbp_omp_begin-1+ij,i)
+     ENDDO
+  ENDDO
+
+  CALL barrier2_omp()
+
+  IF ( check_all_transfert ) &
+      omp_function(omp_rank)=omp_previous
+END SUBROUTINE orch_scatter_omp_igen
+
+
+SUBROUTINE orch_scatter_omp_rgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_orchidee_omp_data
+
+  USE mod_orchidee_para_var, ONLY : nbp_mpi 
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: dimsize
+  REAL(r_std),INTENT(IN),DIMENSION(nbp_mpi,dimsize) :: VarIn
+  REAL(r_std),INTENT(OUT),DIMENSION(nbp_omp,dimsize) :: VarOut
+  REAL(r_std),INTENT(INOUT),DIMENSION(nbp_mpi,dimsize) :: Buff
+
+  INTEGER :: i,ij
+
+  IF ( check_all_transfert ) THEN
+    omp_previous=omp_function(omp_rank)
+    omp_function(omp_rank)=62
+    CALL print_omp_function()
+  ENDIF
+
+  IF (is_omp_root) THEN
+     DO i=1,dimsize
+        DO ij=1,nbp_mpi
+           Buff(ij,i)=VarIn(ij,i)
+        ENDDO
+     ENDDO
+  ENDIF
+
+  CALL barrier2_omp()
+
+  DO i=1,dimsize
+     DO ij=1,nbp_omp
+        VarOut(ij,i)=Buff(nbp_omp_begin-1+ij,i)
+     ENDDO
+  ENDDO
+
+  CALL barrier2_omp()
+
+  IF ( check_all_transfert ) &
+      omp_function(omp_rank)=omp_previous
+END SUBROUTINE orch_scatter_omp_rgen
+
+
+SUBROUTINE orch_scatter_omp_lgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_orchidee_omp_data
+
+  USE mod_orchidee_para_var, ONLY : nbp_mpi 
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: dimsize
+  LOGICAL,INTENT(IN),DIMENSION(nbp_mpi,dimsize) :: VarIn
+  LOGICAL,INTENT(OUT),DIMENSION(nbp_omp,dimsize) :: VarOut
+  LOGICAL,INTENT(INOUT),DIMENSION(nbp_mpi,dimsize) :: Buff
+
+  INTEGER :: i,ij
+
+  IF ( check_all_transfert ) THEN
+    omp_previous=omp_function(omp_rank)
+    omp_function(omp_rank)=63
+    CALL print_omp_function()
+  ENDIF
+
+  IF (is_omp_root) THEN
+     DO i=1,dimsize
+        DO ij=1,nbp_mpi
+           Buff(ij,i)=VarIn(ij,i)
+        ENDDO
+     ENDDO
+  ENDIF
+
+  CALL barrier2_omp()
+
+  DO i=1,dimsize
+     DO ij=1,nbp_omp
+        VarOut(ij,i)=Buff(nbp_omp_begin-1+ij,i)
+     ENDDO
+  ENDDO
+
+  CALL barrier2_omp()
+
+  IF ( check_all_transfert ) &
+      omp_function(omp_rank)=omp_previous
+END SUBROUTINE orch_scatter_omp_lgen
+
+
+
+SUBROUTINE orch_gather_omp_simple_igen(VarIn,VarOut,Buff)
+  USE mod_orchidee_omp_data
+
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN)                            :: VarIn
+  INTEGER,INTENT(OUT),DIMENSION(0:omp_size-1)   :: VarOut
+  INTEGER,INTENT(INOUT),DIMENSION(0:omp_size-1) :: Buff
+
+  Buff(omp_rank)=VarIn
+
+  IF ( check_all_transfert ) THEN
+    omp_previous=omp_function(omp_rank)
+    omp_function(omp_rank)=64
+    CALL print_omp_function()
+  ENDIF
+
+  CALL barrier2_omp()
+
+  IF (is_omp_root) THEN
+     VarOut(0:omp_size-1)=Buff(0:omp_size-1)
+  ENDIF
+
+  CALL barrier2_omp()
+
+  IF ( check_all_transfert ) &
+      omp_function(omp_rank)=omp_previous
+END SUBROUTINE orch_gather_omp_simple_igen
+
+SUBROUTINE orch_gather_omp_igen(VarIn,VarOut,dimsize,Buff)
+  USE mod_orchidee_omp_data
+
+  USE mod_orchidee_para_var, ONLY : nbp_mpi 
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: dimsize
+  INTEGER,INTENT(IN),DIMENSION(nbp_omp,dimsize) :: VarIn
+  INTEGER,INTENT(OUT),DIMENSION(nbp_mpi,dimsize) :: VarOut
+  INTEGER,INTENT(INOUT),DIMENSION(nbp_mpi,dimsize) :: Buff
+
+  INTEGER :: i,ij
+
+  IF ( check_all_transfert ) THEN
+    omp_previous=omp_function(omp_rank)
+    omp_function(omp_rank)=65
+    CALL print_omp_function()
+  ENDIF
+
+  DO i=1,dimsize
+     DO ij=1,nbp_omp
+        Buff(nbp_omp_begin-1+ij,i)=VarIn(ij,i)
+     ENDDO
+  ENDDO
+
+  CALL barrier2_omp()
+
+  IF (is_omp_root) THEN
+     DO i=1,dimsize
+        DO ij=1,nbp_mpi
+           VarOut(ij,i)=Buff(ij,i)
+        ENDDO
+     ENDDO
+  ENDIF
+
+  CALL barrier2_omp()
+
+  IF ( check_all_transfert ) &
+      omp_function(omp_rank)=omp_previous
+END SUBROUTINE orch_gather_omp_igen
+
+
+SUBROUTINE orch_gather_omp_simple_rgen(VarIn,VarOut,Buff)
+  USE mod_orchidee_omp_data
+
+  IMPLICIT NONE
+
+  REAL(r_std),INTENT(IN)                            :: VarIn
+  REAL(r_std),INTENT(OUT),DIMENSION(0:omp_size-1)   :: VarOut
+  REAL(r_std),INTENT(INOUT),DIMENSION(0:omp_size-1) :: Buff
+
+  IF ( check_all_transfert ) THEN
+    omp_previous=omp_function(omp_rank)
+    omp_function(omp_rank)=66
+    CALL print_omp_function()
+  ENDIF
+
+  Buff(omp_rank)=VarIn
+
+  CALL barrier2_omp()
+
+  IF (is_omp_root) THEN
+     VarOut(0:omp_size-1)=Buff(0:omp_size-1)
+  ENDIF
+
+  CALL barrier2_omp()
+
+  IF ( check_all_transfert ) &
+      omp_function(omp_rank)=omp_previous
+END SUBROUTINE orch_gather_omp_simple_rgen
+
+
+SUBROUTINE orch_gather_omp_rgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_orchidee_omp_data
+
+  USE mod_orchidee_para_var, ONLY : nbp_mpi 
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: dimsize
+  REAL(r_std),INTENT(IN),DIMENSION(nbp_omp,dimsize) :: VarIn
+  REAL(r_std),INTENT(OUT),DIMENSION(nbp_mpi,dimsize) :: VarOut
+  REAL(r_std),INTENT(INOUT),DIMENSION(nbp_mpi,dimsize) :: Buff
+
+  INTEGER :: i,ij
+
+  IF ( check_all_transfert ) THEN
+    omp_previous=omp_function(omp_rank)
+    omp_function(omp_rank)=67
+    CALL print_omp_function()
+  ENDIF
+
+  DO i=1,dimsize
+     DO ij=1,nbp_omp
+        Buff(nbp_omp_begin-1+ij,i)=VarIn(ij,i)
+     ENDDO
+  ENDDO
+
+  CALL barrier2_omp()
+
+  IF (is_omp_root) THEN
+     DO i=1,dimsize
+        DO ij=1,nbp_mpi
+           VarOut(ij,i)=Buff(ij,i)
+        ENDDO
+     ENDDO
+  ENDIF
+
+  CALL barrier2_omp()
+
+  IF ( check_all_transfert ) &
+      omp_function(omp_rank)=omp_previous
+END SUBROUTINE orch_gather_omp_rgen
+
+
+SUBROUTINE orch_gather_omp_simple_lgen(VarIn,VarOut,Buff)
+  USE mod_orchidee_omp_data
+
+  IMPLICIT NONE
+
+  LOGICAL,INTENT(IN)                            :: VarIn
+  LOGICAL,INTENT(OUT),DIMENSION(0:omp_size-1)   :: VarOut
+  LOGICAL,INTENT(INOUT),DIMENSION(0:omp_size-1) :: Buff
+
+  IF ( check_all_transfert ) THEN
+    omp_previous=omp_function(omp_rank)
+    omp_function(omp_rank)=68
+    CALL print_omp_function()
+  ENDIF
+
+  Buff(omp_rank)=VarIn
+
+  CALL barrier2_omp()
+
+  IF (is_omp_root) THEN
+     VarOut(0:omp_size-1)=Buff(0:omp_size-1)
+  ENDIF
+
+  CALL barrier2_omp()
+
+  IF ( check_all_transfert ) &
+      omp_function(omp_rank)=omp_previous
+END SUBROUTINE orch_gather_omp_simple_lgen
+
+
+SUBROUTINE orch_gather_omp_lgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_orchidee_omp_data
+
+  USE mod_orchidee_para_var, ONLY : nbp_mpi 
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: dimsize
+  LOGICAL,INTENT(IN),DIMENSION(nbp_omp,dimsize) :: VarIn
+  LOGICAL,INTENT(OUT),DIMENSION(nbp_mpi,dimsize) :: VarOut
+  LOGICAL,INTENT(INOUT),DIMENSION(nbp_mpi,dimsize) :: Buff
+
+  INTEGER :: i,ij
+
+  IF ( check_all_transfert ) THEN
+    omp_previous=omp_function(omp_rank)
+    omp_function(omp_rank)=69
+    CALL print_omp_function()
+  ENDIF
+
+  DO i=1,dimsize
+     DO ij=1,nbp_omp
+        Buff(nbp_omp_begin-1+ij,i)=VarIn(ij,i)
+     ENDDO
+  ENDDO
+
+  CALL barrier2_omp()
+
+  IF (is_omp_root) THEN
+     DO i=1,dimsize
+        DO ij=1,nbp_mpi
+           VarOut(ij,i)=Buff(ij,i)
+        ENDDO
+     ENDDO
+  ENDIF
+
+  CALL barrier2_omp()
+
+  IF ( check_all_transfert ) &
+      omp_function(omp_rank)=omp_previous
+END SUBROUTINE orch_gather_omp_lgen
+
+
+
+SUBROUTINE orch_reduce_sum_omp_igen(VarIn,VarOut,dimsize,Buff)
+  USE mod_orchidee_omp_data
+
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: dimsize
+  INTEGER,INTENT(IN),DIMENSION(dimsize) :: VarIn
+  INTEGER,INTENT(OUT),DIMENSION(dimsize) :: VarOut
+  INTEGER,INTENT(INOUT),DIMENSION(dimsize) :: Buff
+
+  INTEGER :: i
+
+  IF ( check_all_transfert ) THEN
+    omp_previous=omp_function(omp_rank)
+    omp_function(omp_rank)=70
+    CALL print_omp_function()
+  ENDIF
+
+  IF (is_omp_root) Buff(:)=0
+
+  CALL barrier2_omp()
+
+!$OMP CRITICAL     
+  DO i=1,dimsize
+     Buff(i)=Buff(i)+VarIn(i)
+  ENDDO
+!$OMP END CRITICAL
+
+  CALL barrier2_omp()
+
+  IF (is_omp_root) THEN
+     DO i=1,dimsize
+        VarOut(i)=Buff(i)
+     ENDDO
+  ENDIF
+
+  CALL barrier2_omp()
+
+  IF ( check_all_transfert ) &
+      omp_function(omp_rank)=omp_previous
+END SUBROUTINE orch_reduce_sum_omp_igen
+
+
+SUBROUTINE orch_reduce_sum_omp_rgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_orchidee_omp_data
+
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: dimsize
+  REAL(r_std),INTENT(IN),DIMENSION(dimsize) :: VarIn
+  REAL(r_std),INTENT(OUT),DIMENSION(dimsize) :: VarOut
+  REAL(r_std),INTENT(INOUT),DIMENSION(dimsize) :: Buff
+
+  INTEGER :: i
+
+  IF ( check_all_transfert ) THEN
+    omp_previous=omp_function(omp_rank)
+    omp_function(omp_rank)=71
+    CALL print_omp_function()
+  ENDIF
+
+  IF (is_omp_root) Buff(:)=0
+
+  CALL barrier2_omp()
+
+!$OMP CRITICAL     
+  DO i=1,dimsize
+     Buff(i)=Buff(i)+VarIn(i)
+  ENDDO
+!$OMP END CRITICAL
+
+  CALL barrier2_omp()
+
+  IF (is_omp_root) THEN
+     DO i=1,dimsize
+        VarOut(i)=Buff(i)
+     ENDDO
+  ENDIF
+
+  CALL barrier2_omp()
+
+  IF ( check_all_transfert ) &
+      omp_function(omp_rank)=omp_previous
+END SUBROUTINE orch_reduce_sum_omp_rgen
+
+#endif
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_para.F90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_para.F90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_para.F90	(revision 7236)
@@ -0,0 +1,263 @@
+! Initialization of parallel for MPI and OpenMP.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/Attic/mod_orchidee_para.F90,v 1.1.2.4 2008/11/05 10:14:05 ssipsl Exp $
+!- 
+
+MODULE mod_orchidee_para
+
+  USE mod_orchidee_para_var
+  USE mod_orchidee_mpi_data
+  USE mod_orchidee_omp_data
+  USE mod_orchidee_transfert_para
+    
+CONTAINS
+    
+  SUBROUTINE Init_orchidee_para(communicator)
+    IMPLICIT NONE
+    INTEGER,OPTIONAL,INTENT(in) :: communicator	
+
+    CALL Init_orchidee_omp
+
+
+    IF ( PRESENT(communicator) ) THEN
+       CALL Init_orchidee_mpi(communicator)
+    ELSE
+       CALL Init_orchidee_mpi
+    ENDIF
+
+
+    IF (is_mpi_root .AND. is_omp_root) THEN
+       is_root_prc=.TRUE.
+    ELSE
+       is_root_prc=.FALSE.
+    ENDIF
+  END SUBROUTINE Init_orchidee_para
+    
+  
+  SUBROUTINE Init_orchidee_data_para_driver(nbp,kindex_glo)
+
+    IMPLICIT NONE
+    INTEGER,INTENT(IN) :: nbp
+    INTEGER,INTENT(IN) :: kindex_glo(nbp)
+      
+    INTEGER :: first_point
+    INTEGER :: last_point
+    INTEGER :: nbp_loc
+    INTEGER :: nbp_loc_para(0:mpi_size-1)
+    INTEGER,ALLOCATABLE :: kindex_loc(:)
+    INTEGER :: offset
+    INTEGER :: i
+    
+      
+    last_point=0
+    
+    CALL read_load_balance(nbp,nbp_loc_para)    
+    
+    DO i=0,mpi_rank
+       nbp_loc=nbp_loc_para(i)
+       First_point=last_point+1
+       Last_point=last_point+nbp_loc
+    ENDDO
+      
+    ALLOCATE(kindex_loc(nbp_loc))
+    DO i=1,nbp_loc
+       kindex_loc(i)=kindex_glo(i+First_Point-1)
+    ENDDO
+    
+    IF (mpi_rank==0) THEN
+       offset=0
+    ELSE
+       offset=kindex_glo(First_point-1)-MOD(kindex_glo(First_point-1),iim_g)
+    ENDIF
+    
+    kindex_loc(:)=kindex_loc(:)-offset
+    
+    CALL Init_orchidee_data_para(nbp_loc,kindex_loc,offset,omp_size,omp_rank,MPI_COMM_ORCH)
+    CALL Set_stdout_file('out_orchidee')
+    CALL ipslnlf(new_number=numout)
+    !    
+  END SUBROUTINE Init_orchidee_data_para_driver
+    
+  
+  SUBROUTINE Init_orchidee_data_para(nbp,kindex,arg_offset,arg_omp_size,arg_omp_rank,COMM)
+
+    IMPLICIT NONE
+    INTEGER,INTENT(IN)     :: nbp
+    INTEGER,INTENT(IN)     :: kindex(nbp)
+    INTEGER,INTENT(IN)     :: arg_offset
+    INTEGER,INTENT(IN)     :: arg_omp_size
+    INTEGER,INTENT(IN)     :: arg_omp_rank
+    INTEGER,INTENT(IN)     :: COMM
+    
+    INTEGER,SAVE              :: arg_nbp_mpi
+    INTEGER,ALLOCATABLE,SAVE  :: kindex_mpi(:)
+    
+    offset=arg_offset 
+    CALL init_orchidee_omp_data(arg_omp_size,arg_omp_rank,nbp,offset)
+    
+    IF (is_omp_root) THEN
+       arg_nbp_mpi=SUM(nbp_omp_para_nb(:))
+       ALLOCATE(kindex_mpi(arg_nbp_mpi))
+    ENDIF
+
+    CALL barrier2_omp()
+    kindex_mpi(nbp_omp_begin:nbp_omp_end)=kindex(:)+offset
+    CALL barrier2_omp()
+      
+    IF (is_omp_root) THEN      
+       kindex_mpi(:)=kindex_mpi(:)-offset
+       CALL init_orchidee_mpi_data(arg_nbp_mpi,kindex_mpi,offset,COMM)
+       nbp_glo=SUM(nbp_mpi_para(:))
+    ENDIF
+    CALL barrier2_omp()
+
+    nbp_loc=nbp
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+       is_root_prc=.TRUE.
+    ELSE
+       is_root_prc=.FALSE.
+    ENDIF
+    
+    CALL Test_orchidee_para
+    
+  END SUBROUTINE Init_orchidee_data_para
+
+  SUBROUTINE set_grid_glo(arg_nbp_lon,arg_nbp_lat,arg_nbp_glo)
+    IMPLICIT NONE
+
+    INTEGER(i_std), INTENT(IN) :: arg_nbp_lon
+    INTEGER(i_std), INTENT(IN) :: arg_nbp_lat
+    INTEGER(i_std), INTENT(IN),OPTIONAL :: arg_nbp_glo
+    iim_g=arg_nbp_lon
+    jjm_g=arg_nbp_lat
+    IF (PRESENT(arg_nbp_glo)) nbp_glo=arg_nbp_glo
+  END SUBROUTINE set_grid_glo
+  
+  SUBROUTINE Allocate_grid_glo
+    IMPLICIT NONE
+  
+    ALLOCATE(resolution_g(nbp_glo,2),area_g(nbp_glo),lalo_g(nbp_glo,2), &
+         &   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))
+  
+  END SUBROUTINE Allocate_grid_glo
+  
+    
+  SUBROUTINE Set_stdout_file(filename)
+
+    IMPLICIT NONE
+
+    CHARACTER(len=*), INTENT(IN) :: filename
+    CHARACTER(len=255) :: fileout
+    CHARACTER(len=4)  :: num_mpi
+    CHARACTER(len=4)  :: num_omp
+!++++++++TEST+++++++++
+!	    INTEGER,PARAMETER :: base_numout=6
+	    INTEGER,PARAMETER :: base_numout=100
+!++++++++++++++++++++
+	    
+    INTEGER           :: ierr
+
+    IF (is_ok_mpi) THEN
+       WRITE(num_mpi,'(I4.4)') mpi_rank
+    ENDIF
+    
+    IF (is_ok_omp) THEN
+       WRITE(num_omp,'(I4.4)') omp_rank
+    ENDIF
+    
+     
+    IF (is_ok_mpi .AND. is_ok_omp) THEN
+       fileout=TRIM(filename)//'_'//num_mpi//'.'//num_omp
+       numout=base_numout+omp_rank
+    ELSE IF (is_ok_mpi .AND. (.NOT. is_ok_omp)) THEN
+       fileout=TRIM(filename)//'_'//num_mpi
+       numout=base_numout
+    ELSE IF ((.NOT. is_ok_mpi) .AND. is_ok_omp) THEN
+       fileout=TRIM(filename)//'_'//num_omp
+       numout=base_numout+omp_rank
+    ELSE
+       fileout=TRIM(filename)
+       numout=base_numout
+    ENDIF
+!$OMP CRITICAL  
+    WRITE(*,*) "Set_stdout_file (rank ",mpi_rank,omp_rank,"), id output :",numout
+!$OMP END CRITICAL
+    
+    OPEN(UNIT=numout,FILE=TRIM(fileout),ACTION='write',STATUS='unknown',FORM='formatted',IOSTAT=ierr) 
+    IF (ierr /= 0) THEN
+#ifdef CPP_PARA
+       CALL MPI_FINALIZE(ierr)
+#endif
+       WRITE(*,*) "In Set_stdout_file : Erreur can't open file ", filename
+       STOP 1
+    ENDIF
+ 
+!$OMP CRITICAL  
+    WRITE(numout,*) "Set_stdout_file (rank ",mpi_rank,omp_rank,"), id output :",numout
+!$OMP END CRITICAL
+
+    CALL Init_numout_omp(numout)
+
+  END SUBROUTINE Set_stdout_file
+      
+      
+  SUBROUTINE Test_orchidee_para
+
+    IMPLICIT NONE
+
+    INTEGER,PARAMETER :: dimsize=3
+    REAL(r_std) :: Array(nbp_loc,dimsize)
+    REAL(r_std) :: Array_glo(nbp_glo,dimsize)
+    REAL(r_std) :: Array_glo_tmp(nbp_glo,dimsize)
+    REAL(r_std) :: Array2D_loc(iim_g,jj_nb)
+    REAL(r_std) :: Array2D_glo(iim_g,jjm_g)
+    REAL(r_std) :: sum1,sum2,sum3
+    
+    INTEGER :: i,j
+    
+    DO j=1,dimsize
+       DO i=1,nbp_loc
+          Array(i,j)=10*j+omp_rank+i*1000
+       ENDDO
+    ENDDO
+      
+    CALL gather(Array,Array_glo)
+    CALL bcast(Array_glo)
+    CALL scatter(Array_glo,array)
+    CALL gather(array,array_glo_tmp)
+    CALL bcast(array_glo_tmp)    
+    WRITE(*,*) "Test parallelism (rank ",mpi_rank,omp_rank,"), Should be 0 :",SUM(array_glo-array_glo_tmp)
+
+    sum1=SUM(array)
+    CALL reduce_sum(sum1,sum2)
+    CALL bcast(sum2)
+    sum3=SUM(array_glo)
+    WRITE(*,*) "Test parallelism (rank ",mpi_rank,omp_rank,"), Should be 0 :",sum3-sum2
+    
+    IF (is_omp_root) THEN
+       DO j=1,jjm_g
+          DO i=1,iim_g
+             Array2D_glo(i,j)=(j-1)*iim_g+i
+          ENDDO
+       ENDDO
+        
+       array2D_loc(:,:)=0
+       CALL scatter2D_mpi(array2D_glo,array2D_loc)
+       array2D_glo(:,:)=0
+       CALL gather2D_mpi(array2D_loc,array2D_glo)
+       CALL bcast_mpi(array2D_glo)
+       sum1=SUM(array2D_glo)
+       sum2=SUM(array2D_loc)
+       CALL reduce_sum_mpi(sum2,sum3)
+       CALL bcast_mpi(sum3)
+       
+       WRITE(*,*) "Test parallelism (rank ",mpi_rank,omp_rank,"), Should be 0 :",sum3-sum1
+    ENDIF
+    CALL barrier2_omp()
+
+  END SUBROUTINE  Test_orchidee_para
+  
+END MODULE mod_orchidee_para
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_para_var.F90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_para_var.F90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_para_var.F90	(revision 7236)
@@ -0,0 +1,232 @@
+! ================================================================================================================================
+!  MODULE       : mod_orchidee_para_var
+!
+!  CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+!  LICENCE      : IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF   This module contains public variables for parallelization and domain decomposition 
+!!
+!!\n DESCRIPTION: \n
+!!
+!! REFERENCE(S)	: None
+!!
+!! SVN          :
+!! $HeadURL: $
+!! $Date: $
+!! $Revision: $
+!! \n
+!_ ================================================================================================================================
+
+MODULE mod_orchidee_para_var
+
+  USE defprec
+
+  !
+  ! 1. Variables related to the MPI parallelization and the MPI horizontal domain decompostion. 
+  !    These variables were previously declared in mod_orchidee_mpi_data
+  !
+
+  ! Unit for output messages
+  INTEGER(i_std), SAVE :: numout = 6
+  !$OMP THREADPRIVATE(numout)
+
+  INTEGER,SAVE :: mpi_size                                            !! Number of parallel processes
+  INTEGER,SAVE :: mpi_rank                                            !! my rank num
+  INTEGER,SAVE :: mpi_rank_root                                       !! rank of MPI root
+  LOGICAL,SAVE :: is_mpi_root                                         !! Only MPI root proc is true
+  LOGICAL,SAVE :: is_ok_mpi                                           
+
+  INTEGER(i_std),SAVE              :: nbp_mpi                         !! number of local continental points in each mpi group
+  INTEGER(i_std),SAVE              :: nbp_glo                         !! number of global continental points
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: nbp_mpi_para
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: nbp_mpi_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: nbp_mpi_para_end 
+
+  INTEGER,SAVE :: nbp_mpi_begin
+  INTEGER,SAVE :: nbp_mpi_end
+
+
+  INTEGER(i_std),SAVE              :: iim_g                           !! Dimension of global fields for longitude
+  INTEGER(i_std),SAVE              :: jjm_g                           !! Dimension of global fields for latitude
+  ! 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
+
+  INTEGER,SAVE :: MPI_COMM_ORCH
+  INTEGER,SAVE :: MPI_REAL_ORCH
+  INTEGER,SAVE :: MPI_INT_ORCH
+  LOGICAL, SAVE :: cpl_lmdz
+
+  INTEGER,SAVE,ALLOCATABLE :: kindex_mpi (:)
+  INTEGER,SAVE             :: offset_mpi
+
+
+  !
+  ! 2. Variables related to the OpenMP paralelization and OpenMP horizontal domain decomposition 
+  !    These variables were previously declared in mod_orchidee_omp_data
+  !
+
+  ! Check all OpenMP transferts in ORCHIDEE : use this flag to debug synchronism with OpenMP 
+  LOGICAL, PARAMETER :: check_all_transfert=.FALSE.
+
+
+  INTEGER(i_std),SAVE :: omp_size
+  INTEGER(i_std),SAVE :: omp_rank
+  LOGICAL,SAVE :: is_omp_root
+  LOGICAL,SAVE :: is_ok_omp
+  !$OMP  THREADPRIVATE(omp_rank,is_omp_root)
+
+  INTEGER(i_std),SAVE,DIMENSION(:),ALLOCATABLE :: nbp_omp_para_nb
+  INTEGER(i_std),SAVE,DIMENSION(:),ALLOCATABLE :: nbp_omp_para_begin
+  INTEGER(i_std),SAVE,DIMENSION(:),ALLOCATABLE :: nbp_omp_para_end    
+
+  INTEGER(i_std),SAVE :: nbp_omp
+  INTEGER(i_std),SAVE :: nbp_omp_begin
+  INTEGER(i_std),SAVE :: nbp_omp_end
+  INTEGER(i_std),SAVE :: offset_omp
+  !$OMP  THREADPRIVATE(nbp_omp,nbp_omp_begin,nbp_omp_end,offset_omp)
+
+  ! Flag for each OMP process for ORCHIDEE to verify synchronization if function Synchro_Omp is used
+  LOGICAL,SAVE,ALLOCATABLE :: proc_synchro_omp(:)
+
+  INTEGER, SAVE :: numout_omp = -1
+  !$OMP  THREADPRIVATE(numout_omp)
+
+  ! For debugging OpenMP processes : id of OMP function for each task.
+  ! If one task is not in the same function, we can see it.
+  INTEGER(i_std),SAVE,ALLOCATABLE,DIMENSION(:) :: omp_function
+  ! It is not SHARED.
+  ! List of values :
+  CHARACTER(LEN=28), PARAMETER :: omp_fct_name(-1:72) = (/ &
+       "Initialization              ", &
+       "Synchro_Omp                 ", &
+       "check_buffer_i              ", &
+       "check_buffer_r              ", &
+       "check_buffer_l              ", &
+       "bcast_omp_c                 ", &
+       "bcast_omp_i                 ", &
+       "bcast_omp_i1                ", &
+       "bcast_omp_i2                ", &
+       "bcast_omp_i3                ", &
+       "bcast_omp_i4                ", &
+       "bcast_omp_r                 ", &
+       "bcast_omp_r1                ", &
+       "bcast_omp_r2                ", &
+       "bcast_omp_r3                ", &
+       "bcast_omp_r4                ", &
+       "bcast_omp_l                 ", &
+       "bcast_omp_l1                ", &
+       "bcast_omp_l2                ", &
+       "bcast_omp_l3                ", &
+       "bcast_omp_l4                ", &
+       "scatter_omp_i               ", &
+       "scatter_omp_i1              ", &
+       "scatter_omp_i2              ", &
+       "scatter_omp_i3              ", &
+       "scatter_omp_r               ", &
+       "scatter_omp_r1              ", &
+       "scatter_omp_r2              ", &
+       "scatter_omp_r3              ", &
+       "scatter_omp_l               ", &
+       "scatter_omp_l1              ", &
+       "scatter_omp_l2              ", &
+       "scatter_omp_l3              ", &
+       "gather_omp_i0               ", &
+       "gather_omp_i                ", &
+       "gather_omp_i1               ", &
+       "gather_omp_i2               ", &
+       "gather_omp_i3               ", &
+       "gather_omp_r0               ", &
+       "gather_omp_r                ", &
+       "gather_omp_r1               ", &
+       "gather_omp_r2               ", &
+       "gather_omp_r3               ", &
+       "gather_omp_l0               ", &
+       "gather_omp_l                ", &
+       "gather_omp_l1               ", &
+       "gather_omp_l2               ", &
+       "gather_omp_l3               ", &
+       "reduce_sum_omp_i            ", &
+       "reduce_sum_omp_i1           ", &
+       "reduce_sum_omp_i2           ", &
+       "reduce_sum_omp_i3           ", &
+       "reduce_sum_omp_i4           ", &
+       "reduce_sum_omp_r            ", &
+       "reduce_sum_omp_r1           ", &
+       "reduce_sum_omp_r2           ", &
+       "reduce_sum_omp_r3           ", &
+       "reduce_sum_omp_r4           ", &
+       "orch_bcast_omp_cgen         ", &
+       "orch_bcast_omp_igen         ", &
+       "orch_bcast_omp_rgen         ", &
+       "orch_bcast_omp_lgen         ", &
+       "orch_scatter_omp_igen       ", &
+       "orch_scatter_omp_rgen       ", &
+       "orch_scatter_omp_lgen       ", &
+       "orch_gather_omp_simple_igen ", &
+       "orch_gather_omp_igen        ", &
+       "orch_gather_omp_simple_rgen ", &
+       "orch_gather_omp_rgen        ", &
+       "orch_gather_omp_simple_lgen ", &
+       "orch_gather_omp_lgen        ", &
+       "orch_reduce_sum_omp_igen    ", &
+       "orch_reduce_sum_omp_rgen    ", &
+       "check_buffer_c              " /)
+
+  ! Previous value for own omp_function
+  INTEGER, SAVE :: omp_previous
+  !$OMP  THREADPRIVATE(omp_previous)
+
+  ! 
+  !! 3. Variables previously declared in mod_orchide_para
+  !
+
+  INTEGER,SAVE :: nbp_loc                                             !! number of local continental points
+  !$OMP THREADPRIVATE(nbp_loc)
+  INTEGER,SAVE :: offset
+  !$OMP THREADPRIVATE(offset)
+
+  LOGICAL,SAVE :: is_root_prc = .FALSE.                               !! Only root proc for MPI and OpenMP is true
+  !$OMP THREADPRIVATE(is_root_prc)
+
+  !! 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  
+
+
+END MODULE mod_orchidee_para_var
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_transfert_para.F90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_transfert_para.F90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mod_orchidee_transfert_para.F90	(revision 7236)
@@ -0,0 +1,763 @@
+! High level MPI/OpenMP parallel communication encapsulations for ORCHIDEE.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/Attic/mod_orchidee_transfert_para.F90,v 1.1.2.2 2008/08/29 14:01:40 ssipsl Exp $
+!-
+
+MODULE mod_orchidee_transfert_para
+
+  USE mod_orchidee_para_var
+  USE mod_orchidee_mpi_transfert
+  USE mod_orchidee_omp_transfert 
+  
+
+
+  INTERFACE bcast
+    MODULE PROCEDURE bcast_c, bcast_c1,                           &
+                     bcast_i,bcast_i1,bcast_i2,bcast_i3,bcast_i4, &
+                     bcast_r,bcast_r1,bcast_r2,bcast_r3,bcast_r4, &
+		     bcast_l,bcast_l1,bcast_l2,bcast_l3,bcast_l4
+  END INTERFACE
+
+  INTERFACE scatter
+    MODULE PROCEDURE scatter_i,scatter_i1,scatter_i2,scatter_i3, &
+                     scatter_r,scatter_r1,scatter_r2,scatter_r3, &
+		     scatter_l,scatter_l1,scatter_l2,scatter_l3
+  END INTERFACE
+
+  
+  INTERFACE gather
+    MODULE PROCEDURE gather_i,gather_i1,gather_i2,gather_i3, &
+                     gather_r,gather_r1,gather_r2,gather_r3, &
+		     gather_l,gather_l1,gather_l2,gather_l3  
+  END INTERFACE
+  
+
+  INTERFACE reduce_sum
+    MODULE PROCEDURE reduce_sum_i,reduce_sum_i1,reduce_sum_i2,reduce_sum_i3,reduce_sum_i4, &
+                     reduce_sum_r,reduce_sum_r1,reduce_sum_r2,reduce_sum_r3,reduce_sum_r4
+  END INTERFACE 
+
+   
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Broadcast --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! -- Les chaine de charactère -- !!
+
+  SUBROUTINE bcast_c(var)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+   
+    
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_c
+
+  SUBROUTINE bcast_c1(var)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var(:)
+   
+    
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_c1
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_i(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var
+    
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i
+
+  SUBROUTINE bcast_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+   
+    
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i1
+
+
+  SUBROUTINE bcast_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+    
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i2
+
+
+  SUBROUTINE bcast_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+   
+    
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i3
+
+
+  SUBROUTINE bcast_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i4
+
+ 
+!! -- Les reels -- !!
+  
+  SUBROUTINE bcast_r(var)
+  IMPLICIT NONE
+    REAL(r_std),INTENT(INOUT) :: Var
+
+    
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r
+
+  SUBROUTINE bcast_r1(var)
+  IMPLICIT NONE
+    REAL(r_std),INTENT(INOUT) :: Var(:)
+   
+    
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r1
+
+
+  SUBROUTINE bcast_r2(var)
+  IMPLICIT NONE
+    REAL(r_std),INTENT(INOUT) :: Var(:,:)
+   
+    
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r2
+
+
+  SUBROUTINE bcast_r3(var)
+  IMPLICIT NONE
+    REAL(r_std),INTENT(INOUT) :: Var(:,:,:)
+   
+    
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r3
+
+
+  SUBROUTINE bcast_r4(var)
+  IMPLICIT NONE
+    REAL(r_std),INTENT(INOUT) :: Var(:,:,:,:)
+    
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r4 
+
+
+!! -- Les booleens -- !!
+  
+  SUBROUTINE bcast_l(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+    
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l
+
+  SUBROUTINE bcast_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l1
+
+
+  SUBROUTINE bcast_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+    
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l2
+
+
+  SUBROUTINE bcast_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+    
+    IF (is_omp_root) CALL bcast_mpi(Var)
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l3
+
+
+  SUBROUTINE bcast_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+     
+    IF (is_omp_root) CALL bcast_mpi(Var)
+
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l4
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_i(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER,DIMENSION(nbp_mpi) :: Var_tmp
+    
+    
+    IF (is_omp_root) CALL scatter_mpi(VarIn,Var_tmp)
+    CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_i
+
+
+  SUBROUTINE scatter_i1(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    INTEGER,DIMENSION(nbp_mpi,SIZE(Varout,2)) :: Var_tmp
+
+    
+    IF (is_omp_root) CALL scatter_mpi(VarIn,Var_tmp)
+    CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_i1
+
+
+  SUBROUTINE scatter_i2(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(nbp_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp
+
+    
+    IF (is_omp_root) CALL scatter_mpi(VarIn,Var_tmp)
+    CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_i2
+
+
+  SUBROUTINE scatter_i3(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(nbp_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp
+
+    
+    IF (is_omp_root) CALL scatter_mpi(VarIn,Var_tmp)
+    CALL scatter_omp(Var_tmp,VarOut)
+    
+  END SUBROUTINE scatter_i3
+
+
+  SUBROUTINE scatter_r(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    REAL(r_std),INTENT(IN),DIMENSION(:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL(r_std),DIMENSION(nbp_mpi) :: Var_tmp
+    
+    IF (is_omp_root) CALL scatter_mpi(VarIn,Var_tmp)
+    CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_r
+
+
+  SUBROUTINE scatter_r1(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    REAL(r_std),INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    REAL(r_std),DIMENSION(nbp_mpi,SIZE(Varout,2)) :: Var_tmp
+
+    
+    IF (is_omp_root) CALL scatter_mpi(VarIn,Var_tmp)
+    CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_r1
+
+
+  SUBROUTINE scatter_r2(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL(r_std),DIMENSION(nbp_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp
+
+    
+    IF (is_omp_root) CALL scatter_mpi(VarIn,Var_tmp)
+    CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_r2
+
+
+  SUBROUTINE scatter_r3(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    REAL(r_std),DIMENSION(nbp_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp
+
+    
+    IF (is_omp_root) CALL scatter_mpi(VarIn,Var_tmp)
+    CALL scatter_omp(Var_tmp,VarOut)
+    
+  END SUBROUTINE scatter_r3
+  
+  
+
+  SUBROUTINE scatter_l(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL,DIMENSION(nbp_mpi) :: Var_tmp
+    
+    
+    IF (is_omp_root) CALL scatter_mpi(VarIn,Var_tmp)
+    CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_l
+
+
+  SUBROUTINE scatter_l1(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    LOGICAL,DIMENSION(nbp_mpi,SIZE(Varout,2)) :: Var_tmp
+
+    
+    IF (is_omp_root) CALL scatter_mpi(VarIn,Var_tmp)
+    CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_l1
+
+
+  SUBROUTINE scatter_l2(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(nbp_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp
+
+    
+    IF (is_omp_root) CALL scatter_mpi(VarIn,Var_tmp)
+    CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_l2
+
+
+  SUBROUTINE scatter_l3(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    LOGICAL,DIMENSION(nbp_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp
+
+    
+    IF (is_omp_root) CALL scatter_mpi(VarIn,Var_tmp)
+    CALL scatter_omp(Var_tmp,VarOut)
+    
+  END SUBROUTINE scatter_l3
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+!!!!! --> Les entiers
+
+  SUBROUTINE gather_i(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    INTEGER, DIMENSION(nbp_mpi) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL gather_mpi(Var_tmp,Varout)
+  
+  END SUBROUTINE gather_i
+
+
+  SUBROUTINE gather_i1(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER, DIMENSION(nbp_mpi,SIZE(VarIn,2)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL gather_mpi(Var_tmp,Varout)
+
+  
+  END SUBROUTINE gather_i1
+
+
+  SUBROUTINE gather_i2(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER, DIMENSION(nbp_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL gather_mpi(Var_tmp,VarOut)
+  
+  END SUBROUTINE gather_i2
+
+
+  SUBROUTINE gather_i3(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER, DIMENSION(nbp_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL gather_mpi(Var_tmp,VarOut)
+
+  
+  END SUBROUTINE gather_i3
+
+
+!!!!! --> Les reels
+
+  SUBROUTINE gather_r(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    REAL(r_std),INTENT(IN),DIMENSION(:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    REAL(r_std), DIMENSION(nbp_mpi) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL gather_mpi(Var_tmp,VarOut)
+ 
+  END SUBROUTINE gather_r
+
+
+  SUBROUTINE gather_r1(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    REAL(r_std),INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL(r_std), DIMENSION(nbp_mpi,SIZE(VarIn,2)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL gather_mpi(Var_tmp,VarOut)
+  
+  END SUBROUTINE gather_r1
+
+
+  SUBROUTINE gather_r2(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL(r_std), DIMENSION(nbp_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL gather_mpi(Var_tmp,VarOut)
+  
+  END SUBROUTINE gather_r2
+
+
+  SUBROUTINE gather_r3(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL(r_std), DIMENSION(nbp_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL gather_mpi(Var_tmp,VarOut)
+  
+  END SUBROUTINE gather_r3
+
+
+!!!!! --> Les booleens
+
+  SUBROUTINE gather_l(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    LOGICAL, DIMENSION(nbp_mpi) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL gather_mpi(Var_tmp,VarOut)
+  
+  END SUBROUTINE gather_l
+
+
+  SUBROUTINE gather_l1(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL, DIMENSION(nbp_mpi,SIZE(VarIn,2)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL gather_mpi(Var_tmp,VarOut)
+  
+  END SUBROUTINE gather_l1
+
+
+  SUBROUTINE gather_l2(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL, DIMENSION(nbp_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+    IF (is_omp_root) CALL gather_mpi(Var_tmp,VarOut)
+  
+  END SUBROUTINE gather_l2
+
+
+  SUBROUTINE gather_l3(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL, DIMENSION(nbp_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL gather_mpi(Var_tmp,VarOut)
+  
+  END SUBROUTINE gather_l3
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des reduce_sum   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Les entiers
+
+  SUBROUTINE reduce_sum_i(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    
+    INTEGER             :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL reduce_sum_mpi(Var_tmp,VarOut)
+  
+  END SUBROUTINE reduce_sum_i  
+
+
+  SUBROUTINE reduce_sum_i1(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn))   :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL reduce_sum_mpi(Var_tmp,VarOut)
+  
+  END SUBROUTINE reduce_sum_i1  
+
+
+  SUBROUTINE reduce_sum_i2(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL reduce_sum_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE reduce_sum_i2  
+  
+
+  SUBROUTINE reduce_sum_i3(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL reduce_sum_mpi(Var_tmp,VarOut)
+  
+  END SUBROUTINE reduce_sum_i3  
+
+
+  SUBROUTINE reduce_sum_i4(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL reduce_sum_mpi(Var_tmp,VarOut)
+  
+  END SUBROUTINE reduce_sum_i4  
+
+
+! Les reels
+
+  SUBROUTINE reduce_sum_r(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    REAL(r_std),INTENT(IN)  :: VarIn
+    REAL(r_std),INTENT(OUT) :: VarOut
+    
+    REAL(r_std)             :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL reduce_sum_mpi(Var_tmp,VarOut)
+  END SUBROUTINE reduce_sum_r  
+
+
+  SUBROUTINE reduce_sum_r1(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    REAL(r_std),INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    REAL(r_std),DIMENSION(SIZE(VarIn))   :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL reduce_sum_mpi(Var_tmp,VarOut)
+  END SUBROUTINE reduce_sum_r1  
+
+
+  SUBROUTINE reduce_sum_r2(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    REAL(r_std),INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL(r_std),DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL reduce_sum_mpi(Var_tmp,VarOut)
+  END SUBROUTINE reduce_sum_r2  
+  
+
+  SUBROUTINE reduce_sum_r3(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL(r_std),DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL reduce_sum_mpi(Var_tmp,VarOut)
+  END SUBROUTINE reduce_sum_r3  
+
+
+  SUBROUTINE reduce_sum_r4(VarIn, VarOut)
+  IMPLICIT NONE
+  
+    REAL(r_std),INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL(r_std),INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL(r_std),DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+    
+    IF (is_omp_root) CALL reduce_sum_mpi(Var_tmp,VarOut)
+  END SUBROUTINE reduce_sum_r4  
+
+   
+END MODULE mod_orchidee_transfert_para
+
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mpi_dummy.h
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mpi_dummy.h	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/mpi_dummy.h	(revision 7236)
@@ -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: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/orch_write_field.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/orch_write_field.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/orch_write_field.f90	(revision 7236)
@@ -0,0 +1,285 @@
+! Yann Meurdesoif functions for sequentiel tests.
+
+!-
+!< $HeadURL$ 
+!< $Date$
+!< $Author$
+!< $Revision$
+!-
+
+module orch_Write_Field
+  
+  USE mod_orchidee_para
+
+  IMPLICIT NONE
+
+  integer, parameter :: MaxWriteField = 100
+  integer, dimension(MaxWriteField),save :: FieldId
+  integer, dimension(MaxWriteField),save :: FieldVarId
+  integer, dimension(MaxWriteField),save :: FieldIndex
+  character(len=255), dimension(MaxWriteField) ::  FieldName
+  
+  integer, save,dimension(:), allocatable :: Index_Write_Field
+  integer,save :: iim
+  integer,save :: jjm
+  integer,save :: NbPoint
+  real(r_std), 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(r_std), dimension(:,:,:) :: Field 
+      integer, dimension(3) :: Dim
+      integer,dimension(4) :: Dim_tmp
+      integer :: i
+      
+      real(r_std), 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(r_std), dimension(:,:) :: Field 
+      integer, dimension(2) :: Dim
+      integer,dimension(3) :: Dim_tmp
+      integer :: i
+      
+      real(r_std), 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(r_std), dimension(:) :: Field 
+      integer, dimension(1) :: Dim
+      integer,dimension(2) :: Dim_tmp
+      integer :: i
+      
+      real(r_std), 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(r_std), 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(r_std), 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(r_std), 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(r_std), 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)
+#ifdef __NAGFOR
+  USE F90_UNIX_IO
+#endif
+    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(r_std),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: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/orch_write_field_p.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/orch_write_field_p.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/orch_write_field_p.f90	(revision 7236)
@@ -0,0 +1,153 @@
+! Yann Meurdesoif functions for parallel tests.
+
+!-
+!< $HeadURL$ 
+!< $Date$
+!< $Author$
+!< $Revision$
+!-
+
+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
+  USE mod_orchidee_para
+  USE Write_Field, only : Init_WriteField
+  IMPLICIT NONE
+    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 mod_orchidee_para
+    USE Write_field, only : WriteField
+    IMPLICIT NONE
+      CHARACTER(len=*) :: name
+      REAL(r_std), DIMENSION(:,:,:,:) :: Field 
+      INTEGER, DIMENSION(4) :: Dim
+      
+      REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:,:) :: Field_g
+      
+      Dim=shape(Field)
+      
+      ALLOCATE(Field_g(iim_g,jjm_g,Dim(3),Dim(4)))
+      CALL Gather2D_mpi(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 mod_orchidee_para
+    USE Write_field, only : WriteField
+    IMPLICIT NONE
+      CHARACTER(len=*) :: name
+      REAL(r_std), DIMENSION(:,:,:) :: Field 
+      INTEGER, DIMENSION(3) :: Dim
+      
+      REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: Field_g
+      
+      
+      Dim=shape(Field)
+      
+      ALLOCATE(Field_g(iim_g,jjm_g,Dim(3)))
+      CALL Gather2D_mpi(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 mod_orchidee_para
+    USE Write_field, only : WriteField
+    IMPLICIT NONE
+      CHARACTER(len=*) :: name
+      REAL(r_std), DIMENSION(:,:) :: Field 
+      INTEGER, DIMENSION(2) :: Dim
+      
+      REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: Field_g
+      
+      
+      Dim=shape(Field)
+      
+      ALLOCATE(Field_g(iim_g,jjm_g))
+      CALL Gather2D_mpi(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 mod_orchidee_para
+    USE Write_field, only : WriteFieldI
+    IMPLICIT NONE
+      CHARACTER(len=*) :: name
+      REAL(r_std), DIMENSION(:,:,:) :: Field 
+      INTEGER, DIMENSION(3) :: Dim
+      
+      REAL(r_std), 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 mod_orchidee_para
+    USE Write_field, only : WriteFieldI
+    IMPLICIT NONE
+      CHARACTER(len=*) :: name
+      REAL(r_std), DIMENSION(:,:) :: Field 
+      INTEGER, DIMENSION(2) :: Dim
+      
+      REAL(r_std), 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 mod_orchidee_para
+    USE Write_field, only : WriteFieldI
+    IMPLICIT NONE
+      CHARACTER(len=*) :: name
+      REAL(r_std), DIMENSION(:) :: Field 
+      INTEGER, DIMENSION(1) :: Dim
+      
+      REAL(r_std), 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: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/src_parallel.h
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/src_parallel.h	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/src_parallel.h	(revision 7236)
@@ -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: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/timer.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/timer.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/timer.f90	(revision 7236)
@@ -0,0 +1,177 @@
+! Timer functions to calculate MPI use speed up.
+
+!-
+!< $HeadURL$ 
+!< $Date$
+!< $Author$
+!< $Revision$
+!-
+
+MODULE timer
+
+  USE mod_orchidee_para_var, ONLY : numout
+  
+  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: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/tools_para.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/tools_para.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/tools_para.f90	(revision 7236)
@@ -0,0 +1,24 @@
+! Obsolete parallel tools : Barrier
+
+!-
+!< $HeadURL$ 
+!< $Date$
+!< $Author$
+!< $Revision$
+!-
+
+MODULE tools_para
+!-
+  USE mod_orchidee_para_var, ONLY : MPI_COMM_ORCH
+!-
+#include "src_parallel.h"
+!-
+CONTAINS
+
+  SUBROUTINE barrier_para()
+#ifdef CPP_PARA
+    CALL MPI_BARRIER(MPI_COMM_ORCH,ierr)
+#endif
+  END SUBROUTINE barrier_para
+
+END MODULE tools_para
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/write_field.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/write_field.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/write_field.f90	(revision 7236)
@@ -0,0 +1,12 @@
+! Yann Meurdesoif module for sequentiel tests.
+
+!-
+!< $HeadURL$ 
+!< $Date$
+!< $Author$
+!< $Revision$
+!-
+
+MODULE Write_Field
+  USE Orch_Write_Field
+END MODULE Write_Field
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/write_field_p.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/write_field_p.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/write_field_p.f90	(revision 7236)
@@ -0,0 +1,12 @@
+! Yann Meurdesoif module for parallel tests.
+
+!-
+!< $HeadURL$ 
+!< $Date$
+!< $Author$
+!< $Revision$
+!-
+
+MODULE Write_field_p
+  USE Orch_Write_Field_p
+END MODULE Write_field_p
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parallel/xios_orchidee.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parallel/xios_orchidee.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parallel/xios_orchidee.f90	(revision 7236)
@@ -0,0 +1,699 @@
+! ================================================================================================================================
+!  MODULE       : xios_orchidee
+!
+!  CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+!  LICENCE      : IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF   This module contains the initialization and interface to the XIOS code.
+!!
+!!\n DESCRIPTION: This module contains the interface for the use of the XIOS code. All call to XIOS is done in this module.
+!!
+!!                Summury of subroutines
+!!                      xios_orchidee_comm_init       : First call to XIOS to get the MPI communicator 
+!!                      xios_orchidee_init            : Initialize variables needed for use of XIOS 
+!!                                                      Deactivation of fields not calculated due specific run options
+!!                      xios_orchidee_update_calendar : Update the calandar in XIOS
+!!                      xios_orchidee_finalize        : Last call to XIOS for finalization
+!!                      xios_orchidee_send_field      : Interface to send fields with 1, 2 or 3 dimensions to XIOS
+!!                      xios_orchidee_send_field_r1d  : Internal subroutine for 1D(array) fields
+!!                      xios_orchidee_send_field_r2d  : Internal subroutine for 2D fields
+!!                      xios_orchidee_send_field_r3d  : Internal subroutine for 3D fields
+!!
+!!                Note that compilation must be done with the preporcessing key XIOS and CPP_PARA. Compiling without these 
+!!                keys makes it impossible to activate XIOS. To activate run using XIOS, the flag XIOS_ORCHIDEE_OK=y must 
+!!                be set in run.def and the file iodef.xml must exist.  
+!!
+!! RECENT CHANGE(S): Created by Arnaud Caubel(LSCE), Josefine Ghattas (IPSL) 2013
+!!
+!! REFERENCE(S) : None
+!!
+!! SVN          :
+!! $HeadURL: $
+!! $Date: $
+!! $Revision: $
+!! \n
+!_ ================================================================================================================================
+
+MODULE xios_orchidee
+
+#ifdef XIOS
+  USE xios
+#endif
+  USE defprec
+  USE pft_parameters_var, ONLY : nvm
+  USE constantes_var, ONLY : nlai, nnobio, control_type, long_print, almaoutput, dt_sechiba
+  USE constantes_soil_var, ONLY : ngrnd, nstm, nslm, check_waterbal
+  USE IOIPSL, ONLY : ioget_calendar, ju2ymds, getin
+  USE mod_orchidee_para_var
+  USE mod_orchidee_transfert_para
+  USE ioipsl_para
+
+  IMPLICIT NONE
+  PRIVATE
+  PUBLIC :: xios_orchidee_comm_init, xios_orchidee_init, xios_orchidee_change_context, &
+            xios_orchidee_update_calendar, xios_orchidee_context_finalize, xios_orchidee_finalize, &
+            xios_orchidee_send_field
+
+  !
+  !! Declaration of public variables
+  !
+  LOGICAL, PUBLIC, SAVE           :: xios_orchidee_ok=.FALSE.     !! Use XIOS for diagnostic files
+  !$OMP THREADPRIVATE(xios_orchidee_ok)
+
+  !
+  !! Declaration of internal variables
+  !
+#ifdef XIOS
+  TYPE(xios_context)              :: ctx_hdl_orchidee      !! Handel for ORCHIDEE
+  !$OMP THREADPRIVATE(ctx_hdl_orchidee)
+#endif
+  CHARACTER(len=*),PARAMETER      :: id="client"           !! Id for initialization of ORCHIDEE in XIOS
+
+
+
+  !! ==============================================================================================================================
+  !! INTERFACE   : xios_orchidee_send_field
+  !!
+  !>\BRIEF         Send a field to XIOS.
+  !!
+  !! DESCRIPTION  :\n Send a field to XIOS. The field can have 1, 2 or 3 dimensions.
+  !!                  This interface should be called at each time-step for each output varaiables.
+  !!
+  !! \n
+  !_ ================================================================================================================================
+  INTERFACE xios_orchidee_send_field
+     MODULE PROCEDURE xios_orchidee_send_field_r1d, xios_orchidee_send_field_r2d, xios_orchidee_send_field_r3d
+  END INTERFACE
+
+
+CONTAINS
+  !! ==============================================================================================================================
+  !! SUBROUTINE   : xios_orchidee_comm_init 
+  !!
+  !>\BRIEF         Get the MPI communicator.
+  !!
+  !! DESCRIPTION  :\n First call to XIOS to get the MPI communicator. 
+  !!                  Note that it is XIOS that initialize the MPI communicator.
+  !!                  This subroutine is only called in ORCHIDEE offline mode. When running in coupled mode, the 
+  !!                  atmospheric model must initlialize XIOS at the same time as initializing MPI. 
+  !! \n
+  !_ ================================================================================================================================
+  SUBROUTINE xios_orchidee_comm_init(comm_local)
+    !
+    !! 0. Variable and parameter declaration
+    !
+    !!    Output variables
+    INTEGER, INTENT(OUT) :: comm_local
+
+    !_ ================================================================================================================================
+
+    IF (is_omp_root) THEN
+#ifdef XIOS
+       CALL xios_initialize(id,return_comm=comm_local)
+#else
+       ! Write error messages and stop the model
+       WRITE(numout,*) 'Preprocessing key XIOS is missing to run ORCHIDEE with XIOS'
+       WRITE(numout,*) 'Recompile with preprocessing flag XIOS or set XIOS_ORCHIDEE_OK=n in run.def'
+       WRITE(numout,*) 'Fatal error from ORCHIDEE. STOP in xios_orchidee_comm_init'
+#ifdef CPP_PARA
+       CALL MPI_ABORT(3)
+#endif     
+       
+#endif
+    
+    END IF
+  END SUBROUTINE xios_orchidee_comm_init
+
+
+  !! ==============================================================================================================================
+  !! SUBROUTINE   : xios_orchidee_init 
+  !!
+  !>\BRIEF         Initialize variables needed for use of XIOS.
+  !!
+  !! DESCRIPTION  :\n Initialization of specific varaiables needed to use XIOS such as model domain and time step. 
+  !!
+  !!                  In this subroutine also a section containg deactivation of some fields is found. The variables are 
+  !!                  deactivated of not according to the corresponding control flag. For exemple the variables cacluated by the 
+  !!                  routing scheme will be deactivated if the routing is deactivated. This is done to be able to keep the same 
+  !!                  iodef.xml input file for several options without geting empty fields in the output file. Note that a field that
+  !!                  is activated in the code can always be deactivated from the iodef.xml external file. 
+  !!
+  !! \n
+  !_ ================================================================================================================================
+  SUBROUTINE xios_orchidee_init(MPI_COMM_ORCH,               &
+       date0,    year,      month,             day,          &
+       lon_mpi,  lat_mpi,   soilth_lev,        control_flags )
+
+    !
+    !! 0. Variable and parameter declaration
+    !
+    !! 0.1 Input variables
+    !
+    INTEGER(i_std), INTENT(in)                            :: MPI_COMM_ORCH    !! Orchidee MPI communicator (from module mod_orchidee_mpi_data)
+    REAL(r_std), INTENT(in)                               :: date0            !! Julian day at first time step
+    INTEGER(i_std), INTENT(in)                            :: year, month, day !! Current date information
+    REAL(r_std),DIMENSION (iim_g,jj_nb), INTENT(in)       :: lon_mpi, lat_mpi !! Longitudes and latitudes on MPI local domain 2D domain
+    REAL(r_std),DIMENSION (ngrnd), INTENT(in)             :: soilth_lev       !! Vertical soil levels for thermal scheme (m)
+    TYPE(control_type)                                    :: control_flags    !! Flags that activate parts of the model
+
+    !
+    !! 0.2 Local variables
+    !
+#ifdef XIOS
+    TYPE(xios_time)                :: dtime_xios
+    TYPE(xios_fieldgroup)          :: fieldgroup_handle
+    TYPE(xios_field)               :: field_handle
+    TYPE(xios_file)                :: file_handle
+#endif
+    INTEGER(i_std)                 :: i
+    INTEGER(i_std)                 :: year0, month0, day0 !! Time origin date information
+    REAL(r_std)                    :: sec0                !! Time origin date information
+    CHARACTER(LEN=20)              :: calendar_str        !! Name of current calendar
+    CHARACTER(LEN=30)              :: start_str           !! Current date as character string
+    CHARACTER(LEN=30)              :: startorig_str       !! Time origin date as character string
+    !_ ================================================================================================================================
+    
+    
+    IF (long_print) WRITE(numout,*) 'Entering xios_orchidee_init'
+
+    !Config Key   = XIOS_ORCHIDEE_OK
+    !Config Desc  = Use XIOS for writing diagnostics file
+    !Config If    = 
+    !Config Def   = FALSE
+    !Config Help  = 
+    !Config Units = [FLAG]
+    CALL getin_p('XIOS_ORCHIDEE_OK',xios_orchidee_ok)
+    WRITE(numout,*)'In xios_orchidee_init, xios_orchidee_ok=',xios_orchidee_ok
+
+    ! Coherence test between flag and preprocessing key
+#ifndef XIOS
+    IF (xios_orchidee_ok) THEN
+       ! Write error messages and stop the model
+       WRITE(numout,*) 'Preprocessing key XIOS is missing to run ORCHIDEE with XIOS'
+       WRITE(numout,*) 'Recompile with preprocessing flag XIOS or set XIOS_ORCHIDEE_OK=n in run.def'
+       WRITE(numout,*) 'Fatal error from ORCHIDEE. STOP in xios_orchidee_init'
+#ifdef CPP_PARA
+       CALL MPI_ABORT(3)
+#endif     
+    END IF
+#endif
+
+
+    !
+    !! 1. Set date and calendar information on the format needed by XIOS
+    !
+
+    ! Get the calendar from IOIPSL and captialize the string to be readable for XIOS
+    CALL ioget_calendar(calendar_str)
+    IF (calendar_str == 'gregorian') THEN
+       calendar_str='Gregorian'
+    ELSE IF (calendar_str == 'noleap') THEN
+       calendar_str='NoLeap'
+    ELSE IF (calendar_str == '360d') THEN
+       calendar_str='D360'
+    END IF
+
+    ! Transform the time origin from julian days into year, month, day and seconds
+    CALL ju2ymds(date0, year0, month0, day0, sec0)
+
+    ! Transform the current date into character string as XIOS need
+    WRITE(start_str,"(I4.4,'-',I2.2,'-',I2.2,' ',I2.2,':',I2.2,':',I2.2)") year,month,day,0,0,0
+
+    ! Transform the time origin date into character string as XIOS need
+    WRITE(startorig_str,"(I4.4,'-',I2.2,'-',I2.2,' ',I2.2,':',I2.2,':',I2.2)") year0,month0,day0,0,0,0
+
+    IF (long_print) THEN
+       WRITE(numout,*) 'In xios_orchidee_init : calendar_str=', calendar_str
+       WRITE(numout,*) 'In xios_orchidee_init : start_date=',   start_str
+       WRITE(numout,*) 'In xios_orchidee_init : time_origin=',  startorig_str
+    END IF
+
+    IF (xios_orchidee_ok .AND. is_omp_root) THEN
+#ifdef XIOS
+       !
+       !! 2. Context initialization
+       !
+       CALL xios_context_initialize("orchidee",MPI_COMM_ORCH)
+       CALL xios_get_handle("orchidee",ctx_hdl_orchidee)
+       CALL xios_set_current_context(ctx_hdl_orchidee)
+
+       !
+       !! 2. Calendar and date definition
+       !
+       CALL xios_set_context_attr("orchidee",calendar_type=calendar_str)
+       CALL xios_set_context_attr("orchidee",start_date=start_str)
+       CALL xios_set_context_attr("orchidee",time_origin=startorig_str)
+
+       !
+       !! 3. Domain definition
+       !
+       ! Global domain
+       CALL xios_set_domain_attr("domain_landpoints",ni_glo=iim_g, nj_glo=jjm_g)
+
+       ! Local MPI domain
+       CALL xios_set_domain_attr("domain_landpoints",ibegin=1, iend=iim_g, jbegin=jj_begin, jend=jj_end)
+
+       ! Define how data is stored on memory : 1D array for only continental points
+       CALL xios_set_domain_attr("domain_landpoints",data_dim=1, data_ibegin=0, data_ni=nbp_mpi)
+       CALL xios_set_domain_attr("domain_landpoints",data_n_index=nbp_mpi, data_i_index=kindex_mpi)     
+
+       ! Define longitudes and latitudes on local MPI domain
+       CALL xios_set_domain_attr("domain_landpoints",lonvalue=lon_mpi(:,1),latvalue=lat_mpi(1,:))
+
+       !
+       !! 4. Axis definition
+       !
+       CALL xios_set_axis_attr("veget",size=nvm ,VALUE=(/(REAL(i,r_std),i=1,nvm)/))
+       CALL xios_set_axis_attr("laiax", size=nlai+1,VALUE=(/(REAL(i,r_std),i=1,nlai+1)/))
+       CALL xios_set_axis_attr("solth",size=ngrnd ,VALUE=soilth_lev(:))
+       CALL xios_set_axis_attr("soiltyp", size=nstm,VALUE=(/(REAL(i,r_std),i=1,nstm)/))
+       CALL xios_set_axis_attr("nobio", size=nnobio,VALUE=(/(REAL(i,r_std),i=1,nnobio)/))
+       CALL xios_set_axis_attr("albtyp", size=2,VALUE=(/(REAL(i,r_std),i=1,2)/))
+       CALL xios_set_axis_attr("solay", size=nslm,VALUE=(/(REAL(i,r_std),i=1,nslm)/))
+       CALL xios_set_axis_attr("PFT", size=nvm,VALUE=(/(REAL(i,r_std), i=1,nvm)/))
+       CALL xios_set_axis_attr("P10", size=10,VALUE=(/(REAL(i,r_std), i=1,10)/))
+       CALL xios_set_axis_attr("P100", size=100,VALUE=(/(REAL(i,r_std), i=1,100)/))
+       CALL xios_set_axis_attr("P11", size=11,VALUE=(/(REAL(i,r_std), i=1,11)/))
+       CALL xios_set_axis_attr("P101", size=101,VALUE=(/(REAL(i,r_std), i=1,101)/))
+
+       !
+       !! 5. Send the time-step length to XIOS
+       !
+       dtime_xios%second=dt_sechiba
+       CALL xios_set_timestep(dtime_xios) 
+
+       !
+       !! 6. Deactivation of some fields if they are not calculated
+       !
+       IF ( .NOT. control_flags%river_routing ) THEN
+          CALL xios_set_field_attr("basinmap",enabled=.FALSE.)
+          CALL xios_set_field_attr("nbrivers",enabled=.FALSE.)
+          CALL xios_set_field_attr("riversret",enabled=.FALSE.)
+          CALL xios_set_field_attr("hydrographs",enabled=.FALSE.)
+          CALL xios_set_field_attr("fastr",enabled=.FALSE.)
+          CALL xios_set_field_attr("slowr",enabled=.FALSE.)
+          CALL xios_set_field_attr("streamr",enabled=.FALSE.)
+          CALL xios_set_field_attr("lakevol",enabled=.FALSE.)
+          CALL xios_set_field_attr("pondr",enabled=.FALSE.)
+       END IF
+
+
+       IF (control_flags%hydrol_cwrr ) THEN
+          CALL xios_set_field_attr("dss",enabled=.FALSE.)
+          CALL xios_set_field_attr("gqsb",enabled=.FALSE.)
+          CALL xios_set_field_attr("bqsb",enabled=.FALSE.)
+          CALL xios_set_field_attr("rsol",enabled=.FALSE.)
+          CALL xios_set_field_attr("mrsos",enabled=.FALSE.) 
+          CALL xios_set_field_attr("mrso",enabled=.FALSE.) 
+          CALL xios_set_field_attr("mrros",enabled=.FALSE.) 
+          CALL xios_set_field_attr("mrro",enabled=.FALSE.) 
+          CALL xios_set_field_attr("prveg",enabled=.FALSE.) 
+       ELSE
+          CALL xios_set_field_attr("reinf_slope",enabled=.FALSE.)
+          CALL xios_set_field_attr("soilindex",enabled=.FALSE.)
+          CALL xios_set_field_attr("evapnu_soil",enabled=.FALSE.)
+          CALL xios_set_field_attr("drainage_soil",enabled=.FALSE.)
+          CALL xios_set_field_attr("transpir_soil",enabled=.FALSE.)
+          CALL xios_set_field_attr("runoff_soil",enabled=.FALSE.)
+          CALL xios_set_field_attr("humtot",enabled=.FALSE.)
+          CALL xios_set_field_attr("humtot_soil",enabled=.FALSE.)
+          CALL xios_set_field_attr("SWI",enabled=.FALSE.)
+          CALL xios_set_field_attr("njsc",enabled=.FALSE.)
+          CALL xios_set_field_attr("k_litt",enabled=.FALSE.)
+          CALL xios_set_field_attr("SoilMoist",enabled=.FALSE.)
+          CALL xios_set_field_attr("moistc_1",enabled=.FALSE.)
+          CALL xios_set_field_attr("moistc_2",enabled=.FALSE.)
+          CALL xios_set_field_attr("moistc_3",enabled=.FALSE.)
+          CALL xios_set_field_attr("kfactroot_1",enabled=.FALSE.)
+          CALL xios_set_field_attr("kfactroot_2",enabled=.FALSE.)
+          CALL xios_set_field_attr("kfactroot_3",enabled=.FALSE.)
+          CALL xios_set_field_attr("vegetsoil_1",enabled=.FALSE.)
+          CALL xios_set_field_attr("vegetsoil_2",enabled=.FALSE.)
+          CALL xios_set_field_attr("vegetsoil_3",enabled=.FALSE.)
+       END IF
+
+       IF ( .NOT. control_flags%do_floodplains ) THEN
+          CALL xios_set_field_attr("flood_frac",enabled=.FALSE.)
+          CALL xios_set_field_attr("reinfiltration",enabled=.FALSE.)
+          CALL xios_set_field_attr("floodmap",enabled=.FALSE.)
+          CALL xios_set_field_attr("floodh",enabled=.FALSE.)       
+          CALL xios_set_field_attr("floodr",enabled=.FALSE.)       
+          CALL xios_set_field_attr("floodout",enabled=.FALSE.)       
+          CALL xios_set_field_attr("evapflo",enabled=.FALSE.) 
+          CALL xios_set_field_attr("evapflo_alma",enabled=.FALSE.) 
+       END IF
+
+       ! Deactivate some stomate fields. 
+       ! These fields were traditionally added in sechiba_history.nc output file.
+       IF ( .NOT. control_flags%ok_stomate ) THEN
+          CALL xios_set_field_attr("nee",enabled=.FALSE.)
+          CALL xios_set_field_attr("maint_resp",enabled=.FALSE.)
+          CALL xios_set_field_attr("hetero_resp",enabled=.FALSE.)
+          CALL xios_set_field_attr("growth_resp",enabled=.FALSE.)
+          CALL xios_set_field_attr("npp",enabled=.FALSE.)
+       END IF
+
+       IF ( .NOT. control_flags%do_irrigation ) THEN
+          CALL xios_set_field_attr("irrigation",enabled=.FALSE.)
+          CALL xios_set_field_attr("netirrig",enabled=.FALSE.)
+          CALL xios_set_field_attr("irrigation_alma",enabled=.FALSE.)
+          CALL xios_set_field_attr("netirrig_alma",enabled=.FALSE.)
+          CALL xios_set_field_attr("irrigmap",enabled=.FALSE.)
+       END IF
+
+       IF ( .NOT. control_flags%ok_co2)THEN
+          CALL xios_set_field_attr("vbetaco2",enabled=.FALSE.)
+          CALL xios_set_field_attr("cimean",enabled=.FALSE.)
+          CALL xios_set_field_attr("gpp",enabled=.FALSE.)
+       END IF
+
+       IF ( .NOT. control_flags%ok_inca)THEN
+          CALL xios_set_field_attr("PAR",enabled=.FALSE.)
+          CALL xios_set_field_attr("flx_fertil_no",enabled=.FALSE.)
+          CALL xios_set_field_attr("CRF",enabled=.FALSE.)
+          CALL xios_set_field_attr("ptnlev1",enabled=.FALSE.)
+          CALL xios_set_field_attr("flx_iso",enabled=.FALSE.)
+          CALL xios_set_field_attr("flx_mono",enabled=.FALSE.)
+          CALL xios_set_field_attr("flx_ORVOC",enabled=.FALSE.)
+          CALL xios_set_field_attr("flx_MBO",enabled=.FALSE.)
+          CALL xios_set_field_attr("flx_methanol",enabled=.FALSE.)
+          CALL xios_set_field_attr("flx_acetone",enabled=.FALSE.)
+          CALL xios_set_field_attr("flx_acetal",enabled=.FALSE.)
+          CALL xios_set_field_attr("flx_formal",enabled=.FALSE.)
+          CALL xios_set_field_attr("flx_acetic",enabled=.FALSE.)
+          CALL xios_set_field_attr("flx_formic",enabled=.FALSE.)
+          CALL xios_set_field_attr("flx_no_soil",enabled=.FALSE.)
+          CALL xios_set_field_attr("flx_no",enabled=.FALSE.)
+       END IF
+
+       IF ( .NOT. control_flags%ok_radcanopy)THEN
+          CALL xios_set_field_attr("PARsun",enabled=.FALSE.)
+          CALL xios_set_field_attr("PARsh",enabled=.FALSE.)
+          CALL xios_set_field_attr("laisun",enabled=.FALSE.)
+          CALL xios_set_field_attr("laish",enabled=.FALSE.)
+          CALL xios_set_field_attr("Fdf",enabled=.FALSE.)
+          CALL xios_set_field_attr("PARsuntab",enabled=.FALSE.)
+          CALL xios_set_field_attr("PARshtab",enabled=.FALSE.)
+          CALL xios_set_field_attr("Sinang",enabled=.FALSE.)
+          CALL xios_set_field_attr("PARdf",enabled=.FALSE.)
+          CALL xios_set_field_attr("PARdr",enabled=.FALSE.)
+          CALL xios_set_field_attr("Trans",enabled=.FALSE.)
+          CALL xios_set_field_attr("Day",enabled=.FALSE.)
+          CALL xios_set_field_attr("Year_length",enabled=.FALSE.)
+       END IF
+
+       IF ( .NOT. control_flags%ok_bbgfertil_Nox) THEN
+          CALL xios_set_field_attr("flx_co2_bbg_year",enabled=.FALSE.)
+       END IF
+
+       IF ( .NOT. control_flags%ok_cropsfertil_Nox) THEN
+          CALL xios_set_field_attr("N_qt_WRICE_year",enabled=.FALSE.)
+          CALL xios_set_field_attr("N_qt_OTHER_year",enabled=.FALSE.)
+       END IF
+
+       IF (.NOT. check_waterbal) THEN
+          CALL xios_set_field_attr("TotWater",enabled=.FALSE.)
+          CALL xios_set_field_attr("TotWaterFlux",enabled=.FALSE.)
+       END IF
+
+
+       !
+       !! 7. Close context
+       !
+       CALL xios_close_context_definition()      
+
+       !
+       !! 8. Activate almaoutput if needed 
+       !! Some extra calculations have to be done for the variables tot_watsoil_end("RootMoist"), 
+       !! delsoilmoist("DelSoilMoist"), delintercept, delswe("DelSWE") and soilwet("SoilWet").
+       !! Set almaoutput=true if at least one of these variables are defined in an output file. 
+       !! If not, keep the initial value of almaoutput. 
+       !
+
+       IF (xios_field_is_active("RootMoist") .OR. xios_field_is_active("DelSoilMoist") .OR. &
+            xios_field_is_active("DelIntercept") .OR. xios_field_is_active("DelSWE") .OR. &
+            xios_field_is_active("SoilWet")) THEN
+
+          almaoutput=.TRUE.
+          WRITE(numout,*) 'almaoutput has been set to true in xios_orchidee_init'
+       END IF
+#endif
+    END IF
+
+    IF (xios_orchidee_ok) THEN
+       ! Send variable almaoutput to all processes
+       CALL bcast(almaoutput)
+    END IF
+
+    IF (long_print) WRITE(numout,*) 'Exit xios_orchidee_init'
+  END SUBROUTINE xios_orchidee_init
+
+
+  !! ==============================================================================================================================
+  !! SUBROUTINE   : xios_orchidee_change_context
+  !!
+  !>\BRIEF         Use this subroutine to switch between different context.
+  !!               This subroutine must be called when running in coupled mode at each time ORCHIDEE is called, in the
+  !!               begining and end of intersurf_gathered. First call is done after xios_orchidee_init is done. 
+  !!
+  !! DESCRIPTION  :\n 
+  !!                  
+  !! \n
+  !_ ================================================================================================================================
+  SUBROUTINE xios_orchidee_change_context(new_context)
+    !
+    !! 0. Variable and parameter declaration
+    !
+    !!    Input variable
+    CHARACTER(LEN=*),INTENT(IN)              :: new_context
+
+    !! Local variables
+#ifdef XIOS
+    TYPE(xios_context) :: ctx_hdl
+#endif
+    !_ ================================================================================================================================
+
+    IF (xios_orchidee_ok .AND. is_omp_root) THEN
+#ifdef XIOS
+       CALL xios_get_handle(new_context,ctx_hdl)
+       CALL xios_set_current_context(ctx_hdl)
+#endif
+    END IF
+    
+  END SUBROUTINE xios_orchidee_change_context
+
+  !! ==============================================================================================================================
+  !! SUBROUTINE   : xios_orchidee_update_calendar
+  !!
+  !>\BRIEF          Update the calandar in XIOS.
+  !!
+  !! DESCRIPTION  :\n Update the calendar in XIOS : let XIOS know that ORCHIDEE avanced one time-step.
+  !!                  This subroutine should be called in the beginning of each time-step. The first 
+  !!                  time-step in a new execution should always start at 1. Therefore, first calculate
+  !!                  an offset that is substracted to the current time step in sechiba. 
+  !!
+  !! \n
+  !_ ================================================================================================================================
+  SUBROUTINE xios_orchidee_update_calendar(itau_sechiba)
+    !
+    !! 0. Variable and parameter declaration
+    !
+    !! 0.1 Input variables
+    !
+    INTEGER(i_std), INTENT(IN) :: itau_sechiba    !! Current time step of the model
+    !
+    !! 0.2 Local variables
+    !
+    LOGICAL, SAVE         :: first=.TRUE.         !! Flag for first entering in subroutine
+    INTEGER(i_std), SAVE  :: offset               !! Offset to substract from itau_sechiba
+    INTEGER(i_std)        :: itau_xios            !! Current time step for XIOS
+
+    !_ ================================================================================================================================
+
+    IF (xios_orchidee_ok .AND. is_omp_root) THEN
+#ifdef XIOS
+       ! Calculate the offset
+       IF (first) THEN
+          offset=itau_sechiba-1
+          first=.FALSE.
+       END IF
+
+       ! Substract the offset to the current time step in sechiba
+       itau_xios=itau_sechiba-offset
+
+       ! Send the new time step to XIOS
+       IF (long_print) WRITE(numout,*) 'xios_orchidee_update_calendar: itau_sechiba, itau_xios=',itau_sechiba,itau_xios
+       CALL xios_update_calendar(itau_xios)
+#endif
+    END IF
+  END SUBROUTINE xios_orchidee_update_calendar
+  !! ==============================================================================================================================
+  !! SUBROUTINE   : xios_orchidee_context_finalize
+  !!
+  !>\BRIEF         Finalize orchidee context.
+  !!
+  !! DESCRIPTION  :\n This subroutine finalizes the orchidee context without finalizing XIOS. In coupled mode, the atmospheric
+  !!                  modele must finalize XIOS. This subroutine is called in the end of the execution of ORCHIDEE only in 
+  !!                  coupeld mode.
+  !!                  
+  !! \n
+  !_ ================================================================================================================================
+  SUBROUTINE xios_orchidee_context_finalize
+
+    !_ ================================================================================================================================
+
+    IF (xios_orchidee_ok .AND. is_omp_root) THEN
+       IF (long_print) WRITE(numout,*) 'Entering xios_orchidee_context_finalize'
+#ifdef XIOS
+       CALL xios_context_finalize()
+#endif
+    END IF
+  END SUBROUTINE xios_orchidee_context_finalize
+
+
+  !! ==============================================================================================================================
+  !! SUBROUTINE   : xios_orchidee_finalize
+  !!
+  !>\BRIEF         Last call to XIOS for finalization.
+  !!
+  !! DESCRIPTION  :\n Last call to XIOS for finalization of the orchidee context and XIOS.
+  !!                  This subroutine is called only when ORCHIDEE is run in offline mode. In coupled mode it is the atmospheric
+  !!                  model that finalizes XIOS. In that case, the context orchidee must be finalized using the 
+  !!                  subroutine xios_orchidee_context_finalize
+  !!                  
+  !! \n
+  !_ ================================================================================================================================
+  SUBROUTINE xios_orchidee_finalize
+
+    !_ ================================================================================================================================
+
+    IF (xios_orchidee_ok .AND. is_omp_root) THEN
+       IF (long_print) WRITE(numout,*) 'Entering xios_orchidee_finalize'
+#ifdef XIOS
+       CALL xios_context_finalize()
+       CALL xios_finalize()
+#endif
+    END IF
+  END SUBROUTINE xios_orchidee_finalize
+
+
+  !! ==============================================================================================================================
+  !! SUBROUTINE   : xios_orchidee_send_field_r1d
+  !!
+  !>\BRIEF          Subroutine for sending 1D (array) fields to XIOS.
+  !!
+  !! DESCRIPTION  :\n Send one field to XIOS. This is the interface for 1D fields (array).
+  !!                  NB! This subroutine should not be called directly. Use interface xios_orchidee_send_field.
+  !!
+  !! \n
+  !_ ================================================================================================================================
+  SUBROUTINE xios_orchidee_send_field_r1d(field_id,field)
+    !
+    !! 0. Variable and parameter declaration
+    !
+    !! 0.1 Input variables
+    !
+    CHARACTER(len=*), INTENT(IN)          :: field_id
+    REAL(r_std), DIMENSION(:), INTENT(IN) :: field
+
+    !! 0.2 Local variables
+    REAL(r_std), DIMENSION(nbp_mpi) :: field_mpi
+
+    !_ ================================================================================================================================
+    IF (xios_orchidee_ok) THEN
+       IF (long_print) WRITE(numout,*) 'Entering xios_orchidee_send_field_r1d, field_id=',field_id
+
+       ! Gather all omp domains on the mpi domains
+       CALL gather_omp(field, field_mpi)
+
+       ! All master threads send the field to XIOS
+       IF (is_omp_root) THEN
+#ifdef XIOS
+          CALL xios_send_field(field_id,field_mpi)
+#endif
+       END IF
+    END IF
+  END SUBROUTINE xios_orchidee_send_field_r1d
+
+
+  !! ==============================================================================================================================
+  !! SUBROUTINE   : xios_orchidee_send_field_r2d
+  !!
+  !>\BRIEF          Subroutine for sending 2D fields to XIOS.
+  !!
+  !! DESCRIPTION  :\n Send one field to XIOS. This is the interface for 2D fields.
+  !!                  NB! This subroutine should not be called directly. Use interface xios_orchidee_send_field.
+  !!
+  !! \n
+  !_ ================================================================================================================================
+  SUBROUTINE xios_orchidee_send_field_r2d(field_id,field)
+    !
+    !! 0. Variable and parameter declaration
+    !
+    !! 0.1 Input variables
+    !
+    CHARACTER(len=*), INTENT(IN)            :: field_id
+    REAL(r_std), DIMENSION(:,:), INTENT(IN) :: field
+
+    !! 0.2 Local variables
+    REAL(r_std), DIMENSION(nbp_mpi,size(field,2)) :: field_mpi
+
+    !_ ================================================================================================================================
+    IF (xios_orchidee_ok) THEN
+       IF (long_print) WRITE(numout,*) 'Entering xios_orchidee_send_field_r2d, field_id=',field_id
+
+       ! Gather all omp domains on the mpi domains
+       CALL gather_omp(field, field_mpi)
+
+       ! All master threads send the field to XIOS
+       IF (is_omp_root) THEN
+#ifdef XIOS
+          CALL xios_send_field(field_id,field_mpi)
+#endif
+       END IF
+    END IF
+  END SUBROUTINE xios_orchidee_send_field_r2d
+
+
+  !! ==============================================================================================================================
+  !! SUBROUTINE   : xios_orchidee_send_field_r3d
+  !!
+  !>\BRIEF          Subroutine for sending 3D fields to XIOS. 
+  !!
+  !! DESCRIPTION  :\n Send one field to XIOS. This is the interface for 3D fields.
+  !!                  NB! This subroutine should not be called directly. Use interface xios_orchidee_send_field.
+  !!
+  !! \n
+  !_ ================================================================================================================================
+  SUBROUTINE xios_orchidee_send_field_r3d(field_id,field)
+    !
+    !! 0. Variable and parameter declaration
+    !
+    !! 0.1 Input variables
+    !
+    CHARACTER(len=*), INTENT(IN)              :: field_id
+    REAL(r_std), DIMENSION(:,:,:), INTENT(IN) :: field
+
+    !! 0.2 Local variables
+    REAL(r_std), DIMENSION(nbp_mpi,size(field,2),size(field,3)) :: field_mpi
+
+    !_ ================================================================================================================================
+    IF (xios_orchidee_ok) THEN
+       IF (long_print) WRITE(numout,*) 'Entering xios_orchidee_send_field_r3d, field_id=',field_id
+
+       ! Gather all omp domains on the mpi domains
+       CALL gather_omp(field, field_mpi)
+
+       ! All master threads send the field to XIOS
+       IF (is_omp_root) THEN
+#ifdef XIOS
+          CALL xios_send_field(field_id,field_mpi)
+#endif
+       END IF
+    END IF
+  END SUBROUTINE xios_orchidee_send_field_r3d
+ 
+END MODULE xios_orchidee
+
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parameters/AA_make
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parameters/AA_make	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parameters/AA_make	(revision 7236)
@@ -0,0 +1,89 @@
+#-
+#- $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_var.f90   \
+	constantes_soil.f90   \
+	constantes_soil_var.f90   \
+	constantes_mtc.f90   \
+	pft_parameters.f90 \
+	pft_parameters_var.f90 \
+	structures.f90   \
+        function_library.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
+	$(A_C) $(ORCHIDEE_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)(pft_parameters.o): \
+  $(MODEL_LIB)(pft_parameters_var.o) \
+  $(MODEL_LIB)(constantes_mtc.o)
+$(MODEL_LIB)(constantes_soil.o): \
+  $(MODEL_LIB)(constantes_soil_var.o) \
+  $(MODEL_LIB)(constantes.o)
+$(MODEL_LIB)(constantes.o): \
+  $(MODEL_LIB)(constantes_var.o) \
+  $(PARALLEL_LIB) \
+  $(IOIPSL_LIB)
+$(MODEL_LIB)(funtion_library.o): \
+  $(MODEL_LIB)(constantes.o) \
+  $(MODEL_LIB)(pft_parameters.o) 
+$(MODEL_LIB)(structures.o): \
+  $(MODEL_LIB)(constantes.o) 
+
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parameters/AA_make.ldef
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parameters/AA_make.ldef	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parameters/AA_make.ldef	(revision 7236)
@@ -0,0 +1,19 @@
+#-
+#- $Id$
+#-
+#---------------------------------------------------------------------
+#- Creation des elements relatifs a PARAMETER
+#---------------------------------------------------------------------
+SHELL = /bin/sh
+#---------------------------------------------------------------------
+LIBDIR = ../../../lib
+BINDIR = ../../../bin
+MODDIR = $(LIBDIR)
+#---------------------------------------------------------------------
+ORCHIDEE_LIB = $(LIBDIR)/liborchidee.a
+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: branches/publications/ORCHIDEE_CAN_NHA/src_parameters/constantes.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parameters/constantes.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parameters/constantes.f90	(revision 7236)
@@ -0,0 +1,2719 @@
+! =================================================================================================================================
+! MODULE       : constantes
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        "constantes" module contains subroutines to initialize most of the exernalized parameters. This module
+!!              also make a use to the module constantes_var where the parameters are declared.
+!!
+!!\n DESCRIPTION: This module contains subroutines to initialize most of the exernalized parameters. This module
+!!                also make a use to the module constantes_var where the parameters are declared.\n
+!!                This module can be used to acces the subroutines and the constantes. The constantes declarations
+!!                can also be used seperatly with "USE constantes_var".
+!!
+!! RECENT CHANGE(S): Didier Solyga : This module contains now all the externalized parameters of ORCHIDEE 
+!!                   listed by modules which are not pft-dependent  
+!!                   Josefine Ghattas 2013 : The declaration part has been extracted and moved to module constates_var
+!!
+!! REFERENCE(S)	: 
+!! - Louis, Jean-Francois (1979), A parametric model of vertical eddy fluxes in the atmosphere. 
+!! Boundary Layer Meteorology, 187-202.
+!!
+!! SVN          :
+!! $HeadURL: $
+!! $Date: 2015-02-22 16:18:16 +0100 (Sun, 22 Feb 2015) $
+!! $Revision: 2555 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE constantes
+
+  USE constantes_var
+  USE defprec
+  USE ioipsl_para, ONLY : getin_p, ipslerr_p
+  USE mod_orchidee_para, ONLY : numout
+
+  IMPLICIT NONE
+
+CONTAINS
+
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : activate_sub_models
+!!
+!>\BRIEF         This subroutine reads the flags in the configuration file to
+!! activate some sub-models like routing, irrigation, fire, herbivory, ...  
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+   SUBROUTINE activate_sub_models(active_flags)
+
+     IMPLICIT NONE
+
+     !! 0. Variables and parameters declaration
+
+     !! 0.1 Input variables
+
+     TYPE(control_type), INTENT(in) :: active_flags     !! What parts of the code are activated ?
+
+     !! 0.4 Local variables
+
+     LOGICAL, SAVE ::  first_call = .TRUE.             !! To keep first call trace (true/false)
+!$OMP THREADPRIVATE(first_call)
+
+!_ ================================================================================================================================
+
+     IF (first_call) THEN 
+           
+        IF (active_flags%ok_stomate) THEN
+
+           !
+           !Config Key   = TREAT_EXPANSION
+           !Config Desc  = treat expansion of PFTs across a grid cell?
+           !Config If    = OK_STOMATE 
+           !Config Def   = n
+           !Config Help  = With this variable, you can determine
+           !Config         whether we treat expansion of PFTs across a
+           !Config         grid cell.
+           !Config Units = [FLAG]
+           CALL getin_p('TREAT_EXPANSION', treat_expansion)
+           !
+           !Config Key   = FIRE_DISABLE
+           !Config Desc  = no fire allowed
+           !Config If    = OK_STOMATE 
+           !Config Def   = n
+           !Config Help  = With this variable, you can allow or not
+           !Config         the estimation of CO2 lost by fire
+           !Config Units = [FLAG]
+           CALL getin_p('FIRE_DISABLE', disable_fire)
+           !
+           !Config Key   = SPINUP_ANALYTIC
+           !Config Desc  = Activation of the analytic resolution of the spinup.
+           !Config If    = OK_STOMATE
+           !Config Def   = y
+           !Config Help  = Activate this option if you want to solve the spinup by the Gauss-Jordan method.
+           !Config Units = BOOLEAN    
+           CALL getin_p('SPINUP_ANALYTIC',spinup_analytic)
+
+        ENDIF
+
+        !
+        ! Check consistency (see later)
+        !
+!!$        IF(.NOT.(ok_routing) .AND. (doirrigation .OR. dofloodplains)) THEN
+!!$           CALL ipslerr_p(2,'activate_sub_models', &
+!!$               &     'Problem :you tried to activate the irrigation and floodplains without activating the routing',&
+!!$               &     'Are you sure ?', &
+!!$               &     '(check your parameters).')
+!!$        ENDIF
+       
+!!$        IF(.NOT.(ok_stomate) .AND. (ok_herbivores .OR. treat_expansion .OR. ok_constant_mortality &
+!!$            & .OR. harvest_agri .OR. disable_fire)) THEN
+!!$          CALL ipslerr_p(2,'activate_sub_models', &
+!!$               &     'Problem : try to activate the following options : herbivory, treat_expansion, fire,',&
+!!$               &     'harvest_agri and constant mortality without stomate activated.',&
+!!$               &     '(check your parameters).')
+!!$        ENDIF
+            
+        first_call =.FALSE.
+
+     ENDIF
+
+   END SUBROUTINE activate_sub_models
+!
+!=
+!
+
+!! ================================================================================================================================
+!! SUBROUTINE   : veget_config
+!!
+!>\BRIEF         This subroutine reads the flags controlling the configuration for
+!! the vegetation : impose_veg, veget_mpa, lai_map, etc...       
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    :
+!! \n
+!_ ================================================================================================================================
+
+   SUBROUTINE veget_config
+
+     IMPLICIT NONE
+
+     !! 0. Variables and parameters declaration
+
+     !! 0.4 Local variables  
+
+     LOGICAL, SAVE ::  first_call = .TRUE.        !! To keep first call trace (true/false)  
+!$OMP THREADPRIVATE(first_call)
+
+!_ ================================================================================================================================
+     
+     IF (first_call) THEN 
+
+        !Config Key   = AGRICULTURE
+        !Config Desc  = agriculture allowed?
+        !Config If    = OK_SECHIBA or OK_STOMATE
+        !Config Def   = y
+        !Config Help  = With this variable, you can determine
+        !Config         whether agriculture is allowed
+        !Config Units = [FLAG]
+        CALL getin_p('AGRICULTURE', agriculture)
+        !
+        !Config Key   = IMPOSE_VEG
+        !Config Desc  = Should the vegetation be prescribed ?
+        !Config If    = OK_SECHIBA or OK_STOMATE
+        !Config Def   = n
+        !Config Help  = This flag allows the user to impose a vegetation distribution
+        !Config         and its characteristics. 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
+        !Config Units = [FLAG]
+        CALL getin_p('IMPOSE_VEG', impveg)
+
+        IF (impveg) THEN
+           !Config Key   = IMPOSE_SOILT
+           !Config Desc  = Should the soil type 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
+           !Config Units = [FLAG]
+           CALL getin_p('IMPOSE_SOILT', impsoilt)     
+        ENDIF
+
+        !Config Key   = LAI_MAP
+        !Config Desc  = Read the LAI map
+        !Config If    = OK_SECHIBA or OK_STOMATE
+        !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.
+        !Config Units = [FLAG]
+        CALL getin_p('LAI_MAP',read_lai)
+
+        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   = n
+           !Config Help  = If you want to recover the old (ie orchidee_1_2 branch) 
+           !Config         "interpolation" of LAI map.
+           !Config Units = [FLAG]
+           CALL getin_p('SLOWPROC_LAI_OLD_INTERPOL',old_lai)
+        ENDIF
+ 
+        !Config Key   = LAND_USE
+        !Config Desc  = Read a land_use vegetation map
+        !Config If    = OK_SECHIBA or OK_STOMATE
+        !Config Def   = y
+        !Config Help  = pft values are needed, max time axis is 293
+        !Config Units = [FLAG]
+        CALL getin_p('LAND_USE',land_use)
+
+        IF(land_use) THEN
+           !Config Key   = VEGET_REINIT
+           !Config Desc  = booleen to indicate that a new LAND USE file will be used.
+           !Config If    = LAND_USE
+           !Config Def   = y
+           !Config Help  = The parameter is used to bypass veget_year count 
+           !Config         and reinitialize it with VEGET_YEAR parameter.
+           !Config         Then it is possible to change LAND USE file.
+           !Config Units = [FLAG] 
+           CALL getin_p('VEGET_REINIT', veget_reinit)
+           !
+!!$           ! MOVED to control-structure
+!!$           !Config Key   = LAND_COVER_CHANGE
+!!$           !Config Desc  = treat land use modifications
+!!$           !Config If    = LAND_USE
+!!$           !Config Def   = n
+!!$           !Config Help  = With this variable, you can use a Land Use map
+!!$           !Config         to simulate anthropic modifications such as 
+!!$           !Config         deforestation.
+!!$           !Config Units = [FLAG] 
+!!$           CALL getin_p('LAND_COVER_CHANGE', lcchange)
+           !
+           !Config Key   = VEGET_YEAR
+           !Config Desc  = Year of the land_use vegetation map to be read
+           !Config If    = LAND_USE
+           !Config Def   = 1
+           !Config Help  = First year for landuse vegetation (2D map by pft).
+           !Config         If VEGET_YEAR is set to 0, this means there is no time axis.
+           !Config Units = [FLAG] 
+           CALL getin_p('VEGET_YEAR', veget_year_orig)
+        ENDIF
+
+        IF(.NOT. impveg .AND. .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   = n
+           !Config Help  = If you want to recover the old (ie orchidee_1_2 branch) 
+           !Config         "interpolation" of vegetation map.
+           !Config Units = [FLAG] 
+           CALL getin_p('SLOWPROC_VEGET_OLD_INTERPOL',old_veget)
+         ENDIF  
+
+         !
+         ! Check consistency
+         !
+         ! 1. You have to activate agriculture and land_use
+         IF ( .NOT. agriculture .AND. land_use ) THEN 
+            CALL ipslerr_p(2,'veget_config', &
+                 &     'Problem with agriculture desactivated and Land Use activated.',&
+                 &     'Are you sure ?', &
+                 &     '(check your parameters).')
+         ENDIF
+
+
+        first_call = .FALSE.
+
+     ENDIF
+
+!!$        ! DS : Add warning in case of a wrong configuration (need to be discussed)
+!!$        ! 2. 
+!!$        IF (.NOT.(read_lai) .AND. old_lai) THEN
+!!$           CALL ipslerr_p(2,'veget_config', &
+!!$               &     'Problem with lai_map desactivated and old_lai activated.',&
+!!$               &     'Are you sure ?', &
+!!$               &     '(check your parameters).')
+!!$        ENDIF
+!!$    
+!!$        ! 3.
+!!$        IF ((impveg .OR. land_use) .AND. old_veget) THEN
+!!$           CALL ipslerr_p(2,'veget_config', &
+!!$                &     'Problem : try to use the old interpolation with a land use map or in impose_veg.',&
+!!$                &     'Are you sure ?', &
+!!$                &     '(check your parameters).')
+!!$        ENDIF
+!!$
+!!$        ! 4.
+!!$        IF ( .NOT.(impveg) .AND. impsoilt) THEN
+!!$           CALL ipslerr_p(2,'veget_config', &
+!!$               &     'Problem : try to activate impose_soilt without activating impose_veg.',&
+!!$               &     'Are you sure ?', &
+!!$               &     '(check your parameters).')
+!!$        ENDIF
+!!$
+!!$        ! 5.
+!!$        IF (.NOT.(land_use) .AND. (veget_reinit)) THEN
+!!$           CALL ipslerr_p(2,'veget_config', &
+!!$                &     'Problem : try to use a land_use map without activating land_use.',&
+!!$                &     'Are you sure ?', &
+!!$                &     '(check your parameters).')        
+!!$        ENDIF
+!!$
+!!$        ! 6.
+!!$        IF (.NOT.(land_use) .AND. lcchange) THEN
+!!$           CALL ipslerr_p(2,'veget_config', &
+!!$                &     'Problem : lcchange is activated without activating land_use.',&
+!!$                &     'Are you sure ?', &
+!!$                &     '(check your parameters).')        
+!!$        ENDIF
+           
+   END SUBROUTINE veget_config
+!
+!=
+!
+
+!! ================================================================================================================================
+!! SUBROUTINE   : veget_config
+!!
+!>\BRIEF         This subroutine reads in the configuration file the imposed values of the parameters for all SECHIBA modules.  
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    :
+!! \n
+!_ ================================================================================================================================
+
+   SUBROUTINE config_sechiba_parameters(active_flags)
+
+     IMPLICIT NONE
+
+     !! 0. Variables and parameters declaration
+
+     !! 0.1 Input variables
+
+     TYPE(control_type), INTENT(in) :: active_flags     !! What parts of the code are activated ?
+
+     !! 0.4 Local variables
+     
+     LOGICAL, SAVE ::  first_call = .TRUE.    !! To keep first call trace (true/false)
+!$OMP THREADPRIVATE(first_call)
+     INTEGER :: ier, ilevel
+
+!_ ================================================================================================================================
+     
+     IF(first_call) THEN 
+        
+        ! Global : parameters used by many modules
+        !
+        !Config Key   = MAXMASS_GLACIER
+        !Config Desc  = The maximum mass of a glacier
+        !Config If    = OK_SECHIBA or HYDROL_CWRR
+        !Config Def   = 3000.
+        !Config Help  = 
+        !Config Units = [kg/m^2]  
+        CALL getin_p('MAXMASS_GLACIER',maxmass_glacier)
+
+!tzjwb : check but maxmass_glacier might be not needeed anymore + first_call ???
+    ! Global : parameters used by many modules
+    !
+    !Config Key   = MAXMASS_SNOW
+    !Config Desc  = The maximum mass of a snow
+    !Config If    = OK_SECHIBA or HYDROL_CWRR
+    !Config Def   = 3000.
+    !Config Help  = 
+    !Config Units = [kg/m^2]  
+    CALL getin_p('MAXMASS_SNOW',maxmass_snow)
+    CALL getin_p('VPD_k1',vpd_k1)
+    CALL getin_p('VPD_b1',vpd_b1)
+    CALL getin_p('RA_max',ra_max)
+    CALL getin_p('MAINT_VAR',maint_var)
+    CALL getin_p('CUT_LIMIT', cut_limit)
+    CALL getin_p('PSILEAF_FAC',psileaf_fac)
+    CALL getin_p('PSIROOT_FAC', psiroot_fac)
+    CALL getin_p('Day_THRESHOLD',day_threshold)
+    CALL getin_p('VERTICAL_LIMIT',vertical_limit)
+    CALL getin_p('MINPSI',minpsi)
+    CALL getin_p('RELAX_COUNTER', relax_counter)
+    CALL getin_p('PSI_SOIL_MIN',psi_soil_min)
+    CALL getin_p('PLC_THRESHOLD',plc_threshold)
+    CALL getin_p('COEF_MAX_DRAIN',coef_max_drain)
+    CALL getin_p('MIN_KFACTROOT', min_kfactroot)
+    CALL getin_p('SUPPLY_FLAG',supply_flag)
+    CALL getin_p('YYT_FLAG_MORTALITY',yyt_flag_mortality)
+    CALL getin_p('NICOLAS_SOLUTION',nicolas_solution)
+    CALL getin_p('PRES_KFACT', pres_kfact)
+    CALL getin_p('PRES_SOIL_POTENTIAL_MIN', pres_soil_potential_min)
+    CALL getin_p('REC_FACTOR',rec_factor)
+    CALL getin_p('ST_CUT_FAC', st_cut_fac)
+    CALL getin_p('PLEAF_K',pleaf_k)
+    CALL getin_p('PLEAF_B',pleaf_b)
+    CALL getin_p('PROOT_K',proot_k)
+    CALL getin_p('PROOT_B',proot_b)
+    CALL getin_p('HUM_LEAF',hum_leaf)
+    CALL getin_p('HUM_ROOT',hum_root)
+    CALL getin_p('HUM_PLC',hum_plc)
+    CALL getin_p('PRECIP_BIAS_CORRECT',precip_bias_correct)
+        !Config Key   = SNOWCRI
+        !Config Desc  = Sets the amount above which only sublimation occures 
+        !Config If    = OK_SECHIBA or HYDROL_CWRR
+        !Config Def   = 1.5
+        !Config Help  = 
+        !Config Units = [kg/m^2]  
+        CALL getin_p('SNOWCRI',snowcri)
+        !
+        !! Initialization of sneige
+        sneige = snowcri/mille
+        !
+        !Config Key   = MIN_WIND
+        !Config Desc  = Minimum wind speed
+        !Config If    = OK_SECHIBA
+        !Config Def   = 0.1
+        !Config Help  = 
+        !Config Units = [m/s]
+        CALL getin_p('MIN_WIND',min_wind)
+        !
+        !Config Key   = MAX_SNOW_AGE
+        !Config Desc  = Maximum period of snow aging 
+        !Config If    = OK_SECHIBA
+        !Config Def   = 50.
+        !Config Help  = 
+        !Config Units = [days?]
+        CALL getin_p('MAX_SNOW_AGE',max_snow_age)
+        !
+        !Config Key   = SNOW_TRANS
+        !Config Desc  = Transformation time constant for snow
+        !Config If    = OK_SECHIBA
+        !Config Def   = 0.3
+        !Config Help  = 
+        !Config Units = [m]   
+        CALL getin_p('SNOW_TRANS',snow_trans)
+ 
+        !-
+        ! condveg
+        !-
+        !
+        !Config Key   = Z0_OVER_HEIGHT
+        !Config Desc  = to get z0 from height 
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 1/16.
+        !Config Help  = 
+        !Config Units = [-]   
+        CALL getin_p('Z0_OVER_HEIGHT',z0_over_height)
+        !
+        !Config Key   = HEIGHT_DISPLACEMENT
+        !Config Desc  = Magic number which relates the height to the displacement height.
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 0.75
+        !Config Help  = 
+        !Config Units = [m]  
+        CALL getin_p('HEIGHT_DISPLACEMENT',height_displacement)
+        !
+        !Config Key   = Z0_BARE
+        !Config Desc  = bare soil roughness length
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 0.01 
+        !Config Help  = 
+        !Config Units = [m]   
+        CALL getin_p('Z0_BARE',z0_bare)
+        !
+        !Config Key   = Z0_ICE
+        !Config Desc  = ice roughness length
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 0.001
+        !Config Help  = 
+        !Config Units = [m]   
+        CALL getin_p('Z0_ICE',z0_ice)
+        !
+        !Config Key   = TCST_SNOWA
+        !Config Desc  = Time constant of the albedo decay of snow
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 5.0 
+        !Config Help  = 
+        !Config Units = [days]
+        CALL getin_p('TCST_SNOWA',tcst_snowa)
+        !
+        !Config Key   = SNOWCRI_ALB
+        !Config Desc  = Critical value for computation of snow albedo
+        !Config If    = OK_SECHIBA
+        !Config Def   = 10. 
+        !Config Help  = 
+        !Config Units = [cm]  
+        CALL getin_p('SNOWCRI_ALB',snowcri_alb)
+        !
+        !
+        !Config Key   = VIS_DRY
+        !Config Desc  = The correspondance table for the soil color numbers and their albedo 
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.27
+        !Config Help  = 
+        !Config Units = [-]  
+        CALL getin_p('VIS_DRY',vis_dry)
+        !
+        !Config Key   = NIR_DRY
+        !Config Desc  = The correspondance table for the soil color numbers and their albedo 
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 0.48, 0.44, 0.40, 0.36, 0.32, 0.28, 0.24, 0.20, 0.55
+        !Config Help  = 
+        !Config Units = [-]   
+        CALL getin_p('NIR_DRY',nir_dry)
+        !
+        !Config Key   = VIS_WET 
+        !Config Desc  = The correspondance table for the soil color numbers and their albedo
+        !Config If    = OK_SECHIBA  
+        !Config Def   = 0.12, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05, 0.15
+        !Config Help  = 
+        !Config Units = [-]   
+        CALL getin_p('VIS_WET',vis_wet)
+        !
+        !Config Key   = NIR_WET
+        !Config Desc  = The correspondance table for the soil color numbers and their albedo 
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.31
+        !Config Help  = 
+        !Config Units = [-]    
+        CALL getin_p('NIR_WET',nir_wet)
+        !
+        !Config Key   = ALBSOIL_VIS
+        !Config Desc  = 
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 0.18, 0.16, 0.16, 0.15, 0.12, 0.105, 0.09, 0.075, 0.25
+        !Config Help  = 
+        !Config Units = [-]  
+        CALL getin_p('ALBSOIL_VIS',albsoil_vis)
+        !
+        !Config Key   = ALBSOIL_NIR 
+        !Config Desc  = 
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 0.36, 0.34, 0.34, 0.33, 0.30, 0.25, 0.20, 0.15, 0.45
+        !Config Help  = 
+        !Config Units = [-]  
+        CALL getin_p('ALBSOIL_NIR',albsoil_nir)
+        !-
+        !
+        !Config Key   = ALB_DEADLEAF 
+        !Config Desc  = albedo of dead leaves, VIS+NIR 
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 0.12, 0.35
+        !Config Help  = 
+        !Config Units = [-]     
+        CALL getin_p('ALB_DEADLEAF',alb_deadleaf)
+        !
+        !Config Key   = ALB_ICE
+        !Config Desc  = albedo of ice, VIS+NIR
+        !Config If    = OK_SECHIBA
+        !Config Def   = 0.60, 0.20
+        !Config Help  = 
+        !Config Units = [-]  
+        CALL getin_p('ALB_ICE',alb_ice)
+        !
+        !Config Key   = mstemp
+        !Config Desc  = global annual mean surface temperature 
+        !Config If    = OK_STOMATE
+        !Config Def   = 13.9
+        !Config Help  = 
+        !Config Units = [-]  
+        CALL getin_p('MSTEMP',mstemp)
+        !
+        !
+        ! Get the fixed snow albedo if needed
+        !
+        !Config Key   = CONDVEG_SNOWA
+        !Config Desc  = The snow albedo used by SECHIBA
+        !Config Def   = 1.E+20
+        !Config if    = OK_SECHIBA
+        !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).
+        !Config Units = [-]
+        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   = n
+        !Config if    = OK_SECHIBA
+        !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.
+        !Config Units = [FLAG]
+        CALL getin_p('ALB_BARE_MODEL',alb_bare_model)
+        !
+        !Config Key   = Z0CDRAG_AVE
+        !Config Desc  = Average method for z0
+        !Config Def   = y
+        !Config if    = OK_SECHIBA
+        !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
+        !Config Units = [FLAG]
+        CALL getin_p('Z0CDRAG_AVE',z0cdrag_ave)
+        !
+        !Config Key   = IMPOSE_AZE
+        !Config Desc  = Should the surface parameters be prescribed
+        !Config Def   = n
+        !Config if    = OK_SECHIBA
+        !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
+        !Config Units = [FLAG]
+        CALL getin_p('IMPOSE_AZE',impaze)
+        !
+        IF(impaze) THEN
+           !
+           !Config Key   = CONDVEG_Z0
+           !Config Desc  = Surface roughness
+           !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.
+           !Config Units = [m]
+           CALL getin_p('CONDVEG_Z0', z0_scal)  
+           !
+           !Config Key   = ROUGHHEIGHT
+           !Config Desc  = Height to be added to the height of the first level
+           !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.
+           !Config Units = [m] 
+           CALL getin_p('ROUGHHEIGHT', roughheight_scal)
+           ! 
+           !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.
+           !Config Units = [-]
+           CALL getin_p('CONDVEG_ALBVIS', 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.
+           !Config Units = [-]  
+           CALL getin_p('CONDVEG_ALBNIR', albedo_scal(inir))
+           !
+           !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.
+           !Config Units = [-] 
+           CALL getin_p('CONDVEG_EMIS', emis_scal)
+
+
+        ENDIF
+
+           !
+           ! Configuration : The number of canopy levels to use in the albedo and energy budget
+           !
+
+!!$           !Config Key   = NLEVELS
+!!$           !Config Desc  = number of canopy levels
+!!$           !Config If    = OK_SECHIBA
+!!$           !Config Def   = 1
+!!$           !Config Help  = The number of canopy levels to be used in the energy budget/albedo
+!!$           !Config Units = [-]
+!!$           !
+!!$           nlevels=1
+!!$           CALL getin_p("NLEVELS",nlevels)
+!!$           WRITE(numout,*)'The number of canopy levels used by the albedo is : ', nlevels
+           !Config Key   = NLEVELS_PHOTO
+           !Config Desc  = number of photosyntheis canopy levels per enegy budget canopy level
+           !Config If    = OK_SECHIBA
+           !Config Def   = 4
+           !Config Help  = The number of canopy levels to be used in photosynthesis
+           !Config Units = [-]
+           !
+           nlevels_photo=20
+           CALL getin_p("NLEVELS_PHOTO",nlevels_photo)
+           WRITE(numout,'(I4,A)') nlevels_photo,' levels are used for each canopy ' &
+                // 'level to calculate photosynthesis.'
+
+           ! This is a variable that we'll pass around for convenience, in particular
+           ! when going into a subroutine.
+           nlevels_tot = nlevels * nlevels_photo
+
+!!$           ALLOCATE(z_level(1:nlevels),stat=ier)
+!!$           IF (ier .NE. 0) THEN
+!!$              WRITE (numout,*) ' error in z_level allocation. We stop. We need nlevels words = ',nlevels
+!!$              CALL ipslerr_p(3,'constantes.f90','config_sechiba_parameters','','')
+!!$           ENDIF
+!!$           IF(nlevels .GT. 1)THEN
+!!$              ! if you are using more than one level, you need to define the bottom of the level heights,
+!!$              ! in meters
+!!$
+!!$              !Config Key   = Z_LEVEL
+!!$              !Config Desc  = Height of the bottom of each level
+!!$              !Config If    = OK_SECHIBA
+!!$              !Config Def   = 0.0
+!!$              !Config Help  = The number of canopy levels to be used in the energy budget/albedo
+!!$              !Config Units = [-]
+!!$              CALL getin_p('Z_LEVEL',z_level(:))
+!!$
+!!$              WRITE(numout,*) 'WARNING: Using more than one canopy level.'
+!!$              WRITE(numout,*) '         Double check the input file to be sure that you give the lower level boundaries'
+!!$              WRITE(numout,*) '         for EACH level, as I cannot verify that myself.'
+!!$
+!!$           ELSE
+!!$              z_level(1)=zero
+!!$           ENDIF
+
+           DO ilevel=1,nlevels
+              WRITE(numout,*) 'Albedo canopy level ',ilevel,' has a lower boundary at ',z_level(ilevel),' meters.'
+           ENDDO
+
+        !
+        !-
+        ! diffuco 
+        !-
+        !
+        !Config Key   = NLEV_TOP
+        !Config Desc  = Maximum number of canopy levels that are 
+        !               used to construct the "top" layer of the 
+        !               canopy. The top layer is used in the 
+        !               calculation transpiration. 
+        !               Should not exceed nlevels_photo
+        !Config If    = OK_SECHIBA
+        !Config Def   = 20
+        !Config Help  = 
+        !Config Units = [-]
+        nlev_top = 20
+        CALL getin_p('NLEV_TOP',nlev_top)        
+        IF(nlev_top .GT. nlevels_photo) THEN
+           nlev_top = nlevels_photo
+           WRITE(numout,*) 'The numbers of levels in the "top" was '
+           WRITE(numout,*) '  larger than the total number of levels'
+           WRITE(numout,*) '  AUTO CORRECT: nlev_top now = ',nlev_top
+        ENDIF
+
+        !Config Key   = NLAI
+        !Config Desc  = Number of LAI levels
+        !Config If    = OK_SECHIBA
+        !Config Def   = 20
+        !Config Help  = 
+        !Config Units = [-]  
+        CALL getin_p('NLAI',nlai)
+        !
+        !Config Key   = LAIMAX
+        !Config Desc  = Maximum LAI
+        !Config If    = OK_SECHIBA
+        !Config Def   = 
+        !Config Help  = 
+        !Config Units = [m^2/m^2]   
+        CALL getin_p('LAIMAX',laimax)
+        !
+        !Config Key   = DEW_VEG_POLY_COEFF
+        !Config Desc  = coefficients of the polynome of degree 5 for the dew
+        !Config If    = OK_SECHIBA
+        !Config Def   = 0.887773, 0.205673, 0.110112, 0.014843, 0.000824, 0.000017 
+        !Config Help  = 
+        !Config Units = [-]   
+        CALL getin_p('DEW_VEG_POLY_COEFF',dew_veg_poly_coeff)
+        !
+        !Config Key   = DOWNREGULATION_CO2
+        !Config Desc  = Activation of CO2 downregulation
+        !Config If    = OK_SECHIBA
+        !Config Def   = n 
+        !Config Help  = 
+        !Config Units = [FLAG]   
+        CALL getin_p('DOWNREGULATION_CO2',downregulation_co2)
+        !
+        !Config Key   = DOWNREGULATION_CO2_BASELEVEL
+        !Config Desc  = CO2 base level
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 280.
+        !Config Help  = 
+        !Config Units = [ppm]   
+        CALL getin_p('DOWNREGULATION_CO2_BASELEVEL',downregulation_co2_baselevel)
+        !-
+        ! slowproc
+        !-
+        !
+        !Config Key   = CLAYFRACTION_DEFAULT
+        !Config Desc  = default fraction of clay
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 0.2 
+        !Config Help  = 
+        !Config Units = [-]   
+        CALL getin_p('CLAYFRACTION_DEFAULT',clayfraction_default)
+        !
+        !Config Key   = MIN_VEGFRAC 
+        !Config Desc  = Minimal fraction of mesh a vegetation type can occupy 
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 0.001 
+        !Config Help  = 
+        !Config Units = [-]  
+        CALL getin_p('MIN_VEGFRAC',min_vegfrac)
+        !
+        !Config Key   = STEMPDIAG_BID 
+        !Config Desc  = only needed for an initial LAI if there is no restart file
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 280.
+        !Config Help  = 
+        !Config Units = [K]
+        CALL getin_p('STEMPDIAG_BID',stempdiag_bid)
+        !
+        !Config Key   = LSCALE_LCC_NOBIO
+        !Config Desc  = Scale new land cover maps to match the nobio fraction of the current one.
+        !Config If    = LAND_USE
+        !Config Def   = n 
+        !Config Help  = This scales every pixel on new land cover maps to match the nobio fraction
+        !               of the current map.  The reason for this is to avoid crashes in land cover
+        !               change due to small differences in nobio fractions.  CAUTION: This flag should
+        !               only be used if you have created and/or checked your land cover maps to
+        !               make sure the nobio fraction does not change!
+        !Config Units = [FLAG]   
+        CALL getin_p('LSCALE_LCC_NOBIO',lscale_lcc_nobio)
+        !
+        !Config Key   = LIGNORE_LCC_STOPS
+        !Config Desc  = Ignore a few STOP statements related to land cover change.
+        !Config If    = LAND_USE
+        !Config Def   = n 
+        !Config Help  = If this is set to TRUE, a few error messages which would ordinarly produce 
+        !               program exists just produce warnings and the code continues.  This is only
+        !               to be used in some very specific circumstances (for example, between
+        !               an analyical and transient spinup where land cover maps have changed slightly).
+        !               If you didn't add this option yourself, you probably shouldn't be using it.
+        CALL getin_p('LIGNORE_LCC_STOPS',lignore_lcc_stops)
+        !
+        !Config Key   = ALBEDO_TYPE
+        !Config Desc  = Specify the albedo type used if not using the standard
+        !Config Def   = standard
+        !Config If    = OK_ALBEDO
+        !Config Help  = There are currently two albedo models supported
+        !Config         'standard' : The standard scheme, with a preset value  
+        !Config         'pinty' : The scheme of Pinty et al 2006, which feedsback into the model 
+        !Config                   and is a two stream method
+        !Config Units = [-]
+        !
+        albedo_type = 'standard'
+        ! If the DOFOCO flag is on, we have a specific albedo type.
+        IF(active_flags%ok_dofoco)THEN
+           ! Note that nothing will be written to the used_run_def because getin_p is not used
+           albedo_type = 'pinty'
+           WRITE(numout,*) "OK_DOFOCO flag has been set.  Ignoring albedo_type in the run.def.  Using ALBEDO_TYPE=pinty."
+        ELSE
+            CALL getin_p('ALBEDO_TYPE',albedo_type)
+        ENDIF
+        SELECTCASE (albedo_type)
+        CASE ('standard', 'Standard','STANDARD')
+           albedo_type = 'standard'
+        CASE ('pinty','Pinty','PINTY')
+           albedo_type = 'pinty'
+        CASE DEFAULT
+           WRITE(numout,*) "Unsupported albedo type. Choose between standard and pinty."
+           CALL ipslerr_p(3,'constantes.f90','intsurf_config','','')
+        ENDSELECT
+        WRITE(numout,*) "Albedo type being used : ",albedo_type
+        !
+        !Config Key   = DO_NEW_SNOW_ALBEDO
+        !Config Desc  = Use the snow albedo calculation from CLM3
+        !Config Def   = n
+        !Config If    = OK_SECHIBA
+        !Config Help  = 
+        !Config Units = [-]
+        !
+        do_new_snow_albedo = .FALSE.
+        ! If the DOFOCO flag is on, the old snow albedo is not consistent.
+        IF(active_flags%ok_dofoco)THEN
+           ! Note that nothing will be written to the used_run_def because getin_p is not used
+           do_new_snow_albedo = .TRUE.
+           WRITE(numout,*) "OK_DOFOCO flag has been set.  Ignoring do_new_snow_albedo in the run.def.  Using DO_NEW_SNOW_ALBEDO=Y."
+        ELSE
+           CALL getin_p('DO_NEW_SNOW_ALBEDO', do_new_snow_albedo)
+        ENDIF
+        WRITE(numout,*) "Using the new snow albedo? : ",do_new_snow_albedo
+
+
+        !
+        !Config Key  = ALBEDO_OPT_STEP_SIZE_MIN
+        !Config Desc = Minimum step size for albedo n-layer optimization (arbitrary)
+        !Config Def   = 0.000001
+        !Config If   = ALBEDO_TYPE == Pinty
+        !Config Help  = 
+        !Config Units = [-]
+        !
+        step_size_min=0.000001_r_std
+        CALL getin_p('ALBEDO_OPT_STEP_SIZE_MIN',step_size_min) 
+        WRITE(numout,*) 'Minimum step size for albedo n-layer optimization: ',step_size_min
+
+        !
+        !Config Key  = ALBEDO_OPT_STEP_SIZE_SCALE
+        !Config Desc = The scale factor for the step size in the albedo n-layer optimization (arbitrary)
+        !Config Def   = 0.5
+        !Config If   = ALBEDO_TYPE == Pinty
+        !Config Help  = 
+        !Config Units = [-]
+        !
+        step_size_scale=0.5_r_std
+        CALL getin_p('ALBEDO_OPT_STEP_SIZE_SCALE',step_size_scale) 
+        WRITE(numout,*) 'The scale factor for the step size in the albedo n-layer optimization (arbitrary): ',step_size_scale
+
+        !
+        !Config Key  = ALBEDO_OPT_CONVERENCE_LIMIT
+        !Config Desc = The value of the optimization function below which we say the process has converged (arbitrary)
+        !Config If   = ALBEDO_TYPE == Pinty
+        !Config Def   = 0.00000001
+        !Config Help  = 
+        !Config Units = [-]
+        !
+        converged_limit=0.00000001_r_std
+        CALL getin_p('ALBEDO_OPT_CONVERENCE_LIMIT',converged_limit) 
+        WRITE(numout,*) 'The value of the optimization function below which we say the process has converged: ',converged_limit
+
+        !
+        !Config Key  = ALBEDO_OPT_NSTEPS_MAX
+        !Config Desc = Maximum number of optimization steps tried for albedo n-layer optimization (arbitrary)
+        !Config If   = ALBEDO_TYPE == Pinty
+        !Config Def   = 10
+        !Config Help  = 
+        !Config Units = [-]
+        !
+        max_steps=10_i_std
+        CALL getin_p('ALBEDO_OPT_NSTEPS_MAX',max_steps) 
+        WRITE(numout,*) 'Maximum number of optimization steps tried for albedo n-layer optimization (arbitrary): ',max_steps
+
+        !
+        !Config Key  = LAIEFF_SOLAR_ANGLE
+        !Config Desc = The solar zenith angle used in the calculation of the effective LAI.  Pinty recommends a value of 60 degrees.
+        !Config If   = ALBEDO_TYPE == Pinty
+        !Config Def   = 60
+        !Config Help  = 
+        !Config Units = [degrees]
+        !
+        laieff_solar_angle=60.0_r_std
+        CALL getin_p('LAIEFF_SOLAR_ANGLE',laieff_solar_angle) 
+        WRITE(numout,*) 'Maximum number of optimization steps tried for albedo n-layer optimization [degrees]: ',laieff_solar_angle
+        laieff_solar_angle=laieff_solar_angle/180.0_r_std*pi ! convert to radians
+
+        !
+        !Config Key  = LAIEFF_ZERO_CUTOFF
+        !Config Desc = This is an arbitrary cutoff to make sure we don't pass zero values of crown diameter and trunk diameter
+        !              to a subroutine that will choke on them
+        !Config If   = ALBEDO_TYPE == Pinty
+        !Config Def   = 0.0000001
+        !Config Help  = 
+        !Config Units = [-]
+        !
+        laieff_zero_cutoff=0.0000001_r_std
+        CALL getin_p('LAIEFF_ZERO_CUTOFF',laieff_zero_cutoff) 
+        WRITE(numout,*) 'A minimum threshold for trunk and crown diameters for numerical stability: ',laieff_zero_cutoff
+
+
+
+       laieff_set_value_upper=0.5_r_std
+       laieff_set_value_lower=0.5_r_std
+        CALL getin_p('LAIEFF_SET_VALUE_LOWER',laieff_set_value_lower) 
+        CALL getin_p('LAIEFF_SET_VALUE_UPPER',laieff_set_value_upper) 
+        WRITE(numout,*) 'Testing: ',laieff_set_value_upper
+        WRITE(numout,*) 'Testing: ',laieff_set_value_lower
+       laieff_theta=0.01_r_std
+        CALL getin_p('LAIEFF_THETA',laieff_theta) 
+        WRITE(numout,*) 'Testing here too: ',laieff_theta
+
+        first_call =.FALSE.
+
+
+
+     ENDIF
+     
+ 
+
+   END SUBROUTINE config_sechiba_parameters
+!
+!=
+!
+
+!! ================================================================================================================================
+!! SUBROUTINE   : config_co2_parameters 
+!!
+!>\BRIEF        This subroutine reads in the configuration file all the parameters 
+!! needed when OK_CO2 is set to true. (ie : when the photosynthesis is activated) 
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): None 
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    :
+!! \n
+!_ ================================================================================================================================
+
+   SUBROUTINE config_co2_parameters
+     
+     IMPLICIT NONE
+
+     !! 0. Variables and parameters declaration
+
+     !! 0.4 Local variables
+     
+     LOGICAL, SAVE ::  first_call = .TRUE.      !! To keep first call trace (true/false)
+!$OMP THREADPRIVATE(first_call)
+
+!_ ================================================================================================================================
+     
+     IF (first_call) THEN
+        
+        !
+        !Config Key   = LAI_LEVEL_DEPTH
+        !Config Desc  = 
+        !Config If    = OK_CO2
+        !Config Def   = 0.15
+        !Config Help  = 
+        !Config Units = [-]  
+        CALL getin_p('LAI_LEVEL_DEPTH',lai_level_depth)
+        !
+        !Config Key   = Oi
+        !Config Desc  = Intercellular oxygen partial pressure
+        !Config If    = OK_CO2
+        !Config Def   = 210000. 
+ 	!Config Help  = See Legend of Figure 6 of Yin et al. (2009) 
+ 	!Config Units = [ubar]   
+ 	CALL getin_p('Oi',Oi) 
+        
+        first_call = .FALSE.
+        
+     ENDIF
+     
+   END SUBROUTINE config_co2_parameters
+!
+!=
+!
+
+!! ================================================================================================================================
+!! SUBROUTINE   : config_stomate_parameters 
+!!
+!>\BRIEF        This subroutine reads in the configuration file all the parameters 
+!! needed when stomate is activated (ie : when OK_STOMATE is set to true).
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    :
+!! \n
+!_ ================================================================================================================================
+
+   SUBROUTINE config_stomate_parameters
+     
+    IMPLICIT NONE
+    
+    !! 0. Variables and parameters declaration
+
+    !! 0.4 Local variables   
+
+    LOGICAL, SAVE ::  first_call = .TRUE.  !! To keep first call trace (true/false)
+!$OMP THREADPRIVATE(first_call)
+
+!_ ================================================================================================================================
+    
+    IF(first_call) THEN
+       
+       !
+       ! debug setting
+       !
+       !Config Key   = TEST_PFT
+       !Config Desc  = pft for which extra output is written to the out_execution file
+       !Config If    = OK_STOMATE
+       !Config Def   = 6
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('TEST_PFT',test_pft)   
+
+       !
+       ! debug setting
+       !
+       !Config Key   = TEST_GRID
+       !Config Desc  = grid cell for which extra output is written to the out_execution file
+       !Config If    = OK_STOMATE
+       !Config Def   = 1
+       !Config Help  = 
+       !Config Units = [-]
+       test_grid=1
+       CALL getin_p('TEST_GRID',test_grid)   
+
+       !-
+       ! constraints_parameters
+       !-
+       !
+       !Config Key   = TOO_LONG 
+       !Config Desc  = longest sustainable time without regeneration (vernalization)
+       !Config If    = OK_STOMATE
+       !Config Def   = 5.
+       !Config Help  = 
+       !Config Units = [days]   
+       CALL getin_p('TOO_LONG',too_long)
+
+       !-
+       ! fire parameters
+       !-
+       !
+       !Config Key   = TAU_FIRE 
+       !Config Desc  = Time scale for memory of the fire index (days). Validated for one year in the DGVM. 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 30.
+       !Config Help  = 
+       !Config Units = [days]    
+       CALL getin_p('TAU_FIRE',tau_fire)
+       !
+       !Config Key   = LITTER_CRIT
+       !Config Desc  = Critical litter quantity for fire
+       !Config If    = OK_STOMATE 
+       !Config Def   = 200.
+       !Config Help  = 
+       !Config Units = [gC/m^2]  
+       CALL getin_p('LITTER_CRIT',litter_crit)
+       !
+       !Config Key   = FIRE_RESIST_LIGNIN
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.5
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('FIRE_RESIST_LIGNIN',fire_resist_lignin)
+       !
+       !
+       !Config Key   = CO2FRAC
+       !Config Desc  = What fraction of a burned plant compartment goes into the atmosphere
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.95, 0.95, 0., 0.3, 0., 0., 0.95, 0.95, 0.95
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('CO2FRAC',co2frac)
+       !
+       !Config Key   = BCFRAC_COEFF
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.3, 1.3, 88.2 
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('BCFRAC_COEFF',bcfrac_coeff)
+       !
+       !Config Key   = FIREFRAC_COEFF 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.45, 0.8, 0.6, 0.13
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('FIREFRAC_COEFF',firefrac_coeff)
+
+       !-
+       ! gap parameters (+ lpj_const_mort)
+       !-
+       !
+       !Config Key   = AVAILABILITY_FACT 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE, resource-limited allocation 
+       !Config Def   = 0.1
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('AVAILABILITY_FACT', availability_fact)  
+       !
+       !Config Key   = REF_GREFF
+       !Config Desc  = Asymptotic maximum mortality rate
+       !Config If    = OK_STOMATE, resource-limited allocation 
+       !Config Def   = 0.035
+       !Config Help  = Set asymptotic maximum mortality rate from Sitch 2003
+       !Config         (they use 0.01) (year^{-1})
+       !Config Units = [1/year]  
+       CALL getin_p('REF_GREFF',ref_greff)
+
+       !-
+       ! growth_res_limitation
+       !-
+       !
+       !Config Key   = OK_MINRES
+       !Config Desc  = Do we try to reach a minimum reservoir even if we are severely stressed?
+       !Config If    = OK_STOMATE 
+       !Config Def   = y
+       !Config Help  = 
+       !Config Units = [FLAG]
+       CALL getin_p('OK_MINRES',ok_minres)
+       !
+       !Config Key   = TAU_LEAFINIT
+       !Config Desc  = time to attain the initial foliage using the carbohydrate reserve 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 10.
+       !Config Help  =  
+       !Config Units = [days]  
+       CALL getin_p('TAU_LEAFINIT', tau_leafinit)
+       !
+       !Config Key   = RESERVE_TIME_TREE 
+       !Config Desc  = maximum time during which reserve is used (trees) 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 30.
+       !Config Help  = 
+       !Config Units = [days]    
+       CALL getin_p('RESERVE_TIME_TREE',reserve_time_tree)
+       !
+       !Config Key   = RESERVE_TIME_GRASS 
+       !Config Desc  = maximum time during which reserve is used (grasses) 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 20. 
+       !Config Help  = 
+       !Config Units = [days]   
+       CALL getin_p('RESERVE_TIME_GRASS',reserve_time_grass)
+       !
+       !Config Key   = R0
+       !Config Desc  = Standard root allocation 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.3 
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('R0',R0)
+       !
+       !Config Key   = F_FRUIT
+       !Config Desc  = Standard fruit allocation
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.1 
+       !Config Help  = 
+       !Config Units = [-]    
+       CALL getin_p('F_FRUIT',f_fruit)
+       !
+       !Config Key   = ALLOC_SAP_ABOVE_GRASS 
+       !Config Desc  = fraction of sapwood allocation above ground 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 1.0 
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('ALLOC_SAP_ABOVE_GRASS',alloc_sap_above_grass)
+       !
+       !Config Key   = MIN_LTOLSR 
+       !Config Desc  = extrema of leaf allocation fraction 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.2
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('MIN_LTOLSR',min_LtoLSR)
+       !
+       !Config Key   = MAX_LTOLSR
+       !Config Desc  = extrema of leaf allocation fraction
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.5
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('MAX_LTOLSR',max_LtoLSR)
+       !
+       !Config Key   = Z_NITROGEN
+       !Config Desc  = scaling depth for nitrogen limitation 
+       !Config If    = OK_STOMATE
+       !Config Def   = 0.2 
+       !Config Help  =
+       !Config Units = [m]  
+       CALL getin_p('Z_NITROGEN',z_nitrogen)
+       !
+       !Config Key   = NLIM_TREF 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 25. 
+       !Config Help  = 
+       !Config Units = [C]  
+       CALL getin_p('NLIM_TREF',Nlim_tref)
+
+       !-
+       ! growth_fun_all
+       !-
+       !Config Key   = NCIRC
+       !Config Desc  = Number of basal area classes in allocation scheme
+       !               circ classes could be considered as cohorts within a stand 
+       !Config If    = OK_STOMATE, functional allocation 
+       !Config Def   = 2 
+       !Config Help  = 
+       !Config Units = [-]
+       ncirc = 2
+       CALL getin_p('NCIRC',ncirc)  
+
+       !Config Key   = NAGEC
+       !Config Desc  = Number of age classes in forestry and lcchange
+       !               age classes could be considered age classes across stands in the same pixel 
+       !Config If    = OK_STOMATE, forestry and/or lcchange 
+       !Config Def   = 1 
+       !Config Help  = 
+       !Config Units = [-]
+       nagec = 1
+       CALL getin_p('NAGEC',nagec)  
+       !
+       !Config Key   = MIN_WATER_STRESS
+       !Config Desc  = Minimal value for wstress_fac
+       !Config If    = OK_STOMATE, functional allocation 
+       !Config Def   = 0.1 
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('MIN_WATER_STRESS',min_water_stress)
+       !
+       !Config Key   = MAX_DELTA_KF
+       !Config Desc  = Maximum change in KF from one time step to another
+       !Config If    = OK_STOMATE, functional allocation 
+       !Config Def   = 0.1 
+       !Config Help  = 
+       !Config Units = [m]  
+       CALL getin_p('MAX_DELTA_KF',max_delta_KF)
+       !
+       !Config Key   = EVERGREEN_RESERVE
+       !Config Desc  = Fraction of sapwood mass stored in the reserve pool of evergreen trees
+       !Config If    = OK_STOMATE, functional allocation 
+       !Config Def   = 0.05
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('EVERGREEN_RESERVE',evergreen_reserve)
+       !
+       !Config Key   = DECIDUOUS_RESERVE
+       !Config Desc  = Fraction of sapwood mass stored in the reserve pool of 
+       !               deciduous trees during the growing season
+       !Config If    = OK_STOMATE, functional allocation 
+       !Config Def   = 0.12
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('DECIDUOUS_RESERVE',deciduous_reserve)
+       !
+       !Config Key   = SENESCENSE_RESERVE
+       !Config Desc  = Fraction of sapwood mass stored in the reserve pool of 
+       !               deciduous trees during the senescense
+       !Config If    = OK_STOMATE, functional allocation 
+       !Config Def   = 0.12
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('SENESCENSE_RESERVE',senescense_reserve)
+       !
+       !Config Key   = LABILE_RESERVE
+       !Config Desc  = Fraction of sapwood mass stored in the reserve pool of 
+       !               deciduous trees during the senescense divide lab_fac by this 
+       !               parameter to estimate the labile_pool
+       !Config If    = OK_STOMATE, functional allocation 
+       !Config Def   = 10.
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('LABILE_RESERVE',labile_reserve)
+       !
+       !Config Key   = MAINT_FROM_LABILE
+       !Config Desc  = Maintenance respiration should be positive. In case it is 
+       !               very low use ::maint_from_labile of the active labile carbon 
+       !               pool (gC m-2 dt-1)
+       !Config If    = OK_STOMATE, functional allocation 
+       !Config Def   = 0.2
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('MAINT_FROM_LABILE',maint_from_labile)
+       !
+       !Config Key   = MAINT_FROM_GPP
+       !Config Desc  = Some carbon needs to remain to support the growth, hence, 
+       !               respiration will be limited. In this case resp_maint 
+       !               (gC m-2 dt-1) should not be more than 80% (::maint_from_gpp) 
+       !               of the GPP (gC m-2 s-1)
+       !Config If    = OK_STOMATE, functional allocation 
+       !Config Def   = 0.8
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('MAINT_FROM_GPP',maint_from_gpp)
+       !
+       !Config Key   = SYNC_THRESHOLD
+       !Config Desc  = The threshold value for a warning when we sync biomass
+       !Config If    = OK_STOMATE, functional allocation 
+       !Config Def   = 0.1 
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('SYNC_THRESHOLD',sync_threshold)
+    
+       !-
+       ! data parameters
+       !-
+       !
+       !Config Key   = PRECIP_CRIT 
+       !Config Desc  = minimum precip
+       !Config If    = OK_STOMATE 
+       !Config Def   = 100.
+       !Config Help  = 
+       !Config Units = [mm/year]  
+       CALL getin_p('PRECIP_CRIT',precip_crit)
+       !
+       !Config Key   = GDD_CRIT_ESTAB
+       !Config Desc  = minimum gdd for establishment of saplings
+       !Config If    = OK_STOMATE 
+       !Config Def   = 150. 
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('GDD_CRIT_ESTAB',gdd_crit_estab)
+        !
+       !Config Key   = FPC_CRIT
+       !Config Desc  = critical fpc, needed for light competition and establishment
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.95
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('FPC_CRIT',fpc_crit)
+       !
+       !Config Key   = ALPHA_GRASS
+       !Config Desc  = sapling characteristics : alpha's
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.5
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('ALPHA_GRASS',alpha_grass)
+       !
+       !Config Key   = ALPHA_TREE
+       !Config Desc  = sapling characteristics : alpha's 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 1.
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('ALPHA_TREE',alpha_tree)
+       !
+!!$       !Config Key   = STRUCT_TO_LEAVES
+!!$       !Config Desc  = Allocate C to structural carbon i.e. leave stems, tubers, ... 
+!!$       !Config If    = OK_STOMATE 
+!!$       !Config Def   = 0.05
+!!$       !Config Help  = 
+!!$       !Config Units = [-]   
+!!$       CALL getin_p('STRUCT_TO_LEAVES',struct_to_leaves)
+       !  
+       !-
+       !
+       !Config Key   = TAU_HUM_MONTH
+       !Config Desc  = time scales for phenology and other processes
+       !Config If    = OK_STOMATE 
+       !Config Def   = 20. 
+       !Config Help  = 
+       !Config Units = [days]  
+       CALL getin_p('TAU_HUM_MONTH',tau_hum_month)
+       !
+       !Config Key   = TAU_HUM_WEEK
+       !Config Desc  = time scales for phenology and other processes
+       !Config If    = OK_STOMATE 
+       !Config Def   = 7.
+       !Config Help  = 
+       !Config Units = [days]   
+       CALL getin_p('TAU_HUM_WEEK',tau_hum_week)
+       !
+       !Config Key   = TAU_T2M_MONTH
+       !Config Desc  = time scales for phenology and other processes
+       !Config If    = OK_STOMATE 
+       !Config Def   = 20.
+       !Config Help  = 
+       !Config Units = [days]     
+       CALL getin_p('TAU_T2M_MONTH',tau_t2m_month)
+       !
+       !Config Key   = TAU_T2M_WEEK
+       !Config Desc  = time scales for phenology and other processes
+       !Config If    = OK_STOMATE 
+       !Config Def   = 7.
+       !Config Help  = 
+       !Config Units = [days]   
+       CALL getin_p('TAU_T2M_WEEK',tau_t2m_week)
+       !
+       !Config Key   = TAU_TSOIL_MONTH 
+       !Config Desc  = time scales for phenology and other processes
+       !Config If    = OK_STOMATE 
+       !Config Def   = 20. 
+       !Config Help  = 
+       !Config Units = [days]     
+       CALL getin_p('TAU_TSOIL_MONTH',tau_tsoil_month)
+       !
+       !Config Key   = TAU_SOILHUM_MONTH
+       !Config Desc  = time scales for phenology and other processes
+       !Config If    = OK_STOMATE 
+       !Config Def   = 20. 
+       !Config Help  = 
+       !Config Units = [days]   
+       CALL getin_p('TAU_SOILHUM_MONTH',tau_soilhum_month)
+       !
+       !Config Key   = TAU_GPP_WEEK 
+       !Config Desc  = time scales for phenology and other processes
+       !Config If    = OK_STOMATE 
+       !Config Def   = 7. 
+       !Config Help  = 
+       !Config Units = [days]   
+       CALL getin_p('TAU_GPP_WEEK',tau_gpp_week)
+       !
+       !Config Key   = TAU_GDD
+       !Config Desc  = time scales for phenology and other processes
+       !Config If    = OK_STOMATE 
+       !Config Def   = 40. 
+       !Config Help  = 
+       !Config Units = [days]   
+       CALL getin_p('TAU_GDD',tau_gdd)
+       !
+       !Config Key   = TAU_NGD
+       !Config Desc  = time scales for phenology and other processes
+       !Config If    = OK_STOMATE 
+       !Config Def   = 50.
+       !Config Help  = 
+       !Config Units = [days]   
+       CALL getin_p('TAU_NGD',tau_ngd)
+       !
+       !Config Key   = COEFF_TAU_LONGTERM
+       !Config Desc  = time scales for phenology and other processes
+       !Config If    = OK_STOMATE 
+       !Config Def   = 3. 
+       !Config Help  = 
+       !Config Units = [days]   
+       CALL getin_p('COEFF_TAU_LONGTERM',coeff_tau_longterm)
+       !-
+       !
+       !Config Key   = BM_SAPL_CARBRES 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 5. 
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('BM_SAPL_CARBRES',bm_sapl_carbres)
+       !
+       !Config Key   = BM_SAPL_SAPABOVE
+       !Config Desc  = 
+       !Config If    = OK_STOMATE
+       !Config Def   = 0.5 
+       !Config Help  = 
+       !Config Units = [-]    
+       CALL getin_p('BM_SAPL_SAPABOVE',bm_sapl_sapabove)
+       !
+       !Config Key   = BM_SAPL_HEARTABOVE 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 2.
+       !Config Help  = 
+       !Config Units = [-]    
+       CALL getin_p('BM_SAPL_HEARTABOVE',bm_sapl_heartabove)
+       !
+       !Config Key   = BM_SAPL_HEARTBELOW 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 2. 
+       !Config Help  = 
+       !Config Units = [-]    
+       CALL getin_p('BM_SAPL_HEARTBELOW',bm_sapl_heartbelow)
+       !
+       !Config Key   = INIT_SAPL_MASS_LEAF_NAT
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.1 
+       !Config Help  = 
+       !Config Units = [-]    
+       CALL getin_p('INIT_SAPL_MASS_LEAF_NAT',init_sapl_mass_leaf_nat)
+       !
+       !Config Key   = INIT_SAPL_MASS_LEAF_AGRI
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 1. 
+       !Config Help  = 
+       !Config Units = [-]    
+       CALL getin_p('INIT_SAPL_MASS_LEAF_AGRI',init_sapl_mass_leaf_agri)
+       !
+       !Config Key   = INIT_SAPL_MASS_CARBRES
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 5. 
+       !Config Help  = 
+       !Config Units = [-]    
+       CALL getin_p('INIT_SAPL_MASS_CARBRES',init_sapl_mass_carbres)
+       !
+       !Config Key   = INIT_SAPL_MASS_ROOT
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.1 
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('INIT_SAPL_MASS_ROOT',init_sapl_mass_root)
+       !
+       !Config Key   = INIT_SAPL_MASS_FRUIT
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.3 
+       !Config Help  = 
+       !Config Units = [-]    
+       CALL getin_p('INIT_SAPL_MASS_FRUIT',init_sapl_mass_fruit)
+       !
+       !Config Key   = CN_SAPL_INIT 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.5 
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('CN_SAPL_INIT',cn_sapl_init)
+       !
+       !Config Key   = MIGRATE_TREE 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 10000.
+       !Config Help  = 
+       !Config Units = [m/year]   
+       CALL getin_p('MIGRATE_TREE',migrate_tree)
+       !
+       !Config Key   = MIGRATE_GRASS
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 10000.
+       !Config Help  = 
+       !Config Units = [m/year]   
+       CALL getin_p('MIGRATE_GRASS',migrate_grass)
+       !
+       !replaced by a calculation of lai_tagret
+       !Config Key   = LAI_INITMIN_TREE
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.3
+       !Config Help  = 
+       !Config Units = [m^2/m^2]  
+       CALL getin_p('LAI_INITMIN_TREE',lai_initmin_tree)
+       !
+       !Config Key   = LAI_INITMIN_GRASS 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.1
+       !Config Help  = 
+       !Config Units = [m^2/m^2]    
+       CALL getin_p('LAI_INITMIN_GRASS',lai_initmin_grass)
+       !
+       !Config Key   = DIA_COEFF
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 4., 0.5
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('DIA_COEFF',dia_coeff)
+       !
+       !Config Key   = MAXDIA_COEFF
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 100., 0.01 
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('MAXDIA_COEFF',maxdia_coeff)
+       !
+       !Config Key   = BM_SAPL_LEAF
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 4., 4., 0.8, 5. 
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('BM_SAPL_LEAF',bm_sapl_leaf)
+
+       !-
+       ! litter parameters
+       !-
+       !
+       !Config Key   = METABOLIC_REF_FRAC
+       !Config Desc  =
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.85  
+       !Config Help  = 
+       !Config Units = [-]
+       CALL getin_p('METABOLIC_REF_FRAC',metabolic_ref_frac)
+       !
+       !Config Key   = Z_DECOMP
+       !Config Desc  = scaling depth for soil activity
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.2
+       !Config Help  = 
+       !Config Units = [m]   
+       CALL getin_p('Z_DECOMP',z_decomp)
+       !
+       !Config Key   = CN
+       !Config Desc  = C/N ratio
+       !Config If    = OK_STOMATE 
+       !Config Def   = 40., 40., 40., 40., 40., 40., 40., 40.
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('CN',CN)
+       !
+       !Config Key   = LC 
+       !Config Desc  = Lignine/C ratio of the different plant parts
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.22, 0.35, 0.35, 0.35, 0.35, 0.22, 0.22, 0.22
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('LC',LC)
+       !
+       !Config Key   = FRAC_SOIL_STRUCT_AA
+       !Config Desc  = frac_soil(istructural,iactive,iabove)
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.55
+       !Config Help  = 
+       !Config Units = [-]
+       CALL getin_p('FRAC_SOIL_STRUCT_AA',frac_soil_struct_aa)
+       !
+       !Config Key   = FRAC_SOIL_STRUCT_A 
+       !Config Desc  = frac_soil(istructural,iactive,ibelow)
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.45
+       !Config Help  = 
+       !Config Units = [-]
+       CALL getin_p('FRAC_SOIL_STRUCT_AB',frac_soil_struct_ab)
+       !
+       !Config Key   = FRAC_SOIL_STRUCT_SA
+       !Config Desc  = frac_soil(istructural,islow,iabove)
+       !Config If    = OK_STOMATE
+       !Config Def   = 0.7  
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('FRAC_SOIL_STRUCT_SA',frac_soil_struct_sa)
+       !
+       !Config Key   = FRAC_SOIL_STRUCT_SB
+       !Config Desc  = frac_soil(istructural,islow,ibelow) 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.7  
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('FRAC_SOIL_STRUCT_SB',frac_soil_struct_sb)
+       !
+       !Config Key   = FRAC_SOIL_METAB_AA 
+       !Config Desc  = frac_soil(imetabolic,iactive,iabove) 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.45 
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('FRAC_SOIL_METAB_AA',frac_soil_metab_aa)
+       !
+       !Config Key   = FRAC_SOIL_METAB_AB 
+       !Config Desc  = frac_soil(imetabolic,iactive,ibelow)
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.45  
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('FRAC_SOIL_METAB_AB',frac_soil_metab_ab)
+       !
+       !
+       !Config Key   = METABOLIC_LN_RATIO
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.018  
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('METABOLIC_LN_RATIO',metabolic_LN_ratio) 
+       !
+       !Config Key   = TAU_METABOLIC
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.066
+       !Config Help  = 
+       !Config Units = [days] 
+       CALL getin_p('TAU_METABOLIC',tau_metabolic)
+       !
+       !Config Key   = TAU_STRUCT 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.245 
+       !Config Help  = 
+       !Config Units = [days]
+       CALL getin_p('TAU_STRUCT',tau_struct)
+       !
+       !Config Key   = TAU_WOODY
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.75
+       !Config Help  = 
+       !Config Units = [days]
+       CALL getin_p('TAU_WOODY',tau_woody)
+       !
+       !Config Key   = SOIL_Q10
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.69 (=ln2)
+       !Config Help  = 
+       !Config Units = [-]
+       CALL getin_p('SOIL_Q10',soil_Q10)
+       !
+       !Config Key   = TSOIL_REF
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 30. 
+       !Config Help  = 
+       !Config Units = [C]   
+       CALL getin_p('TSOIL_REF',tsoil_ref)
+       !
+       !Config Key   = LITTER_STRUCT_COEF 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 3. 
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('LITTER_STRUCT_COEF',litter_struct_coef)
+       !
+       !Config Key   = MOIST_COEFF
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = -1.1, 2.4, -0.29
+       !Config Help  = Coefficients of the quadratic function determining
+       !Config         the moisture control factor controling heterotrophic
+       !Config         respiration.
+       !Config Units = [-]   
+       CALL getin_p('MOIST_COEFF',moist_coeff)
+       !
+       !Config Key   = MOISTCONT_MIN
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.25
+       !Config Help  = Minimum value of the moisture control factor
+       !Config         controling heterotrophic respiration.
+       !Config Units = [-]   
+       CALL getin_p("MOISTCONT_MIN",moistcont_min)
+
+       !-
+       ! lpj parameters
+       !-
+       !
+       !Config Key   = FRAC_TURNOVER_DAILY 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.55
+       !Config Help  = 
+       !Config Units = [-]
+       CALL getin_p('FRAC_TURNOVER_DAILY',frac_turnover_daily)   
+
+       !-
+       ! npp parameters
+       !-
+       !
+       !Config Key   = TAX_MAX
+       !Config Desc  = maximum fraction of allocatable biomass used for maintenance respiration
+       !Config If    = OK_STOMATE, OK_FUNCTIONAL_ALLOCATION = N 
+       !Config Def   = 0.8
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('TAX_MAX',tax_max) 
+
+       !-
+       ! phenology parameters
+       !-
+       !
+       !Config Key   = ALWAYS_INIT
+       !Config Desc  = take carbon from atmosphere if carbohydrate reserve too small? 
+       !Config If    = OK_STOMATE 
+       !Config Def   = n 
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('ALWAYS_INIT',always_init)
+       !
+       !Config Key   = MIN_GROWTHINIT_TIME 
+       !Config Desc  = minimum time since last beginning of a growing season
+       !Config If    = OK_STOMATE 
+       !Config Def   = 300. 
+       !Config Help  = 
+       !Config Units = [days]  
+       CALL getin_p('MIN_GROWTHINIT_TIME',min_growthinit_time)
+       !
+       !Config Key   = MOIAVAIL_ALWAYS_TREE
+       !Config Desc  = moisture availability above which moisture tendency doesn't matter 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 1.0 
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('MOIAVAIL_ALWAYS_TREE',moiavail_always_tree)
+       !
+       !Config Key   = MOIAVAIL_ALWAYS_GRASS 
+       !Config Desc  = moisture availability above which moisture tendency doesn't matter
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.6 
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('MOIAVAIL_ALWAYS_GRASS',moiavail_always_grass)
+       !
+       !Config Key   = T_ALWAYS_ADD
+       !Config Desc  = monthly temp. above which temp. tendency doesn't matter 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 10.
+       !Config Help  = 
+       !Config Units = [C]    
+       CALL getin_p('T_ALWAYS_ADD',t_always_add)
+       !
+       !
+       !Config Key   = GDDNCD_REF 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 603. 
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('GDDNCD_REF',gddncd_ref)
+       !
+       !Config Key   = GDDNCD_CURVE
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.0091 
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('GDDNCD_CURVE',gddncd_curve)
+       !
+       !Config Key   = GDDNCD_OFFSET
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 64. 
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('GDDNCD_OFFSET',gddncd_offset)
+       !-
+       ! prescribe parameters
+       !-
+       !
+       !Config Key   = BM_SAPL_RESCALE 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 40. 
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('BM_SAPL_RESCALE',bm_sapl_rescale)
+
+       !-
+       ! respiration parameters
+       !-
+       !
+       !Config Key   = MAINT_RESP_MIN_VMAX
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.3
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('MAINT_RESP_MIN_VMAX',maint_resp_min_vmax)  
+       !
+       !Config Key   = MAINT_RESP_COEFF 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 1.4 
+       !Config Help  = 
+       !Config Units = [-] 
+       CALL getin_p('MAINT_RESP_COEFF',maint_resp_coeff)
+       !
+       !Config Key   = MAINT_RESP_C
+       !Config Desc  = Offset coefficient
+       !Config If    = OK_STOMATE 
+       !Config Def   = 1.
+       !Config Help  = Offset of the relationship between temperature and
+       !Config         maintenance respiration
+       !Config Units = [-] 
+       CALL getin_p("MAINT_RESP_C",maint_resp_c)
+
+       !-
+       ! soilcarbon parameters 
+       !-
+       !
+       !Config Key   = FRAC_CARB_AP
+       !Config Desc  = frac carb coefficients from active pool: depends on clay content
+       !Config if    = OK_STOMATE 
+       !Config Def   = 0.004
+       !Config Help  = fraction of the active pool going into the passive pool
+       !Config Units = [-]
+       CALL getin_p('FRAC_CARB_AP',frac_carb_ap)  
+       !
+       !Config Key   = FRAC_CARB_SA
+       !Config Desc  = frac_carb_coefficients from slow pool
+       !Config if    = OK_STOMATE 
+       !Config Def   = 0.42
+       !Config Help  = fraction of the slow pool going into the active pool
+       !Config Units = [-]
+       CALL getin_p('FRAC_CARB_SA',frac_carb_sa)
+       !
+       !Config Key   = FRAC_CARB_SP
+       !Config Desc  = frac_carb_coefficients from slow pool
+       !Config if    = OK_STOMATE 
+       !Config Def   = 0.03
+       !Config Help  = fraction of the slow pool going into the passive pool
+       !Config Units = [-] 
+       CALL getin_p('FRAC_CARB_SP',frac_carb_sp)
+       !
+       !Config Key   = FRAC_CARB_PA
+       !Config Desc  = frac_carb_coefficients from passive pool
+       !Config if    = OK_STOMATE 
+       !Config Def   = 0.45
+       !Config Help  = fraction of the passive pool going into the active pool
+       !Config Units = [-]
+       CALL getin_p('FRAC_CARB_PA',frac_carb_pa)
+       !
+       !Config Key   = FRAC_CARB_PS
+       !Config Desc  = frac_carb_coefficients from passive pool
+       !Config if    = OK_STOMATE 
+       !Config Def   = 0.0
+       !Config Help  = fraction of the passive pool going into the slow pool
+       !Config Units = [-]
+       CALL getin_p('FRAC_CARB_PS',frac_carb_ps)
+       !
+       !Config Key   = ACTIVE_TO_PASS_CLAY_FRAC
+       !Config Desc  = 
+       !Config if    = OK_STOMATE 
+       !Config Def   = 0.68  
+       !Config Help  =
+       !Config Units = [-] 
+       CALL getin_p('ACTIVE_TO_PASS_CLAY_FRAC',active_to_pass_clay_frac)
+       !
+       !Config Key   = CARBON_TAU_IACTIVE
+       !Config Desc  = residence times in carbon pools
+       !Config if    = OK_STOMATE 
+       !Config Def   = 0.149
+       !Config Help  =
+       !Config Units =  [days] 
+       CALL getin_p('CARBON_TAU_IACTIVE',carbon_tau_iactive)
+       !
+       !Config Key   = CARBON_TAU_ISLOW
+       !Config Desc  = residence times in carbon pools
+       !Config if    = OK_STOMATE 
+       !Config Def   = 5.48
+       !Config Help  =
+       !Config Units = [days]
+       CALL getin_p('CARBON_TAU_ISLOW',carbon_tau_islow)
+       !
+       !Config Key   = CARBON_TAU_IPASSIVE
+       !Config Desc  = residence times in carbon pools
+       !Config if    = OK_STOMATE 
+       !Config Def   = 241.
+       !Config Help  = residence time in the passive pool
+       !Config Units = [days] 
+       CALL getin_p('CARBON_TAU_IPASSIVE',carbon_tau_ipassive)
+       !
+       !Config Key   = FLUX_TOT_COEFF
+       !Config Desc  =
+       !Config if    = OK_STOMATE 
+       !Config Def   = 1.2, 1.4,.75
+       !Config Help  =
+       !Config Units = [days] 
+       CALL getin_p('FLUX_TOT_COEFF',flux_tot_coeff)
+
+       !-
+       ! turnover parameters
+       !-
+       !
+       !Config Key   = NEW_TURNOVER_TIME_REF
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 20. 
+       !Config Help  = 
+       !Config Units = [days]  
+       CALL getin_p('NEW_TURNOVER_TIME_REF',new_turnover_time_ref)
+       !
+       !Config Key   = DT_TURNOVER_TIME 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 10.
+       !Config Help  = 
+       !Config Units = [days]  
+       CALL getin_p('DT_TURNOVER_TIME',dt_turnover_time)
+       !
+       !Config Key   = LEAF_AGE_CRIT_TREF
+       !Config Desc  = Mean critical leaf life time
+       !Config If    = OK_STOMATE 
+       !Config Def   = 20. 
+       !Config Help  = 
+       !Config Units = [days]  
+       CALL getin_p('LEAF_AGE_CRIT_TREF',leaf_age_crit_tref)
+       !
+       !Config Key   = LEAF_AGE_CRIT_COEFF 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 1.5, 0.75, 10. 
+       !Config Help  = 
+       !Config Units = [-] 
+       CALL getin_p('LEAF_AGE_CRIT_COEFF',leaf_age_crit_coeff)
+
+       !-
+       ! vmax parameters
+       !-
+       !
+       !Config Key   = VMAX_OFFSET 
+       !Config Desc  = offset (minimum relative vcmax)
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.3
+       !Config Help  = offset (minimum vcmax/vmax_opt)
+       !Config Units = [-]  
+       CALL getin_p('VMAX_OFFSET',vmax_offset)
+       !
+       !Config Key   = LEAFAGE_FIRSTMAX
+       !Config Desc  = leaf age at which vmax attains vcmax_opt (in fraction of critical leaf age)
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.03 
+       !Config Help  = relative leaf age at which vmax attains vcmax_opt
+       !Config Units = [-] 
+       CALL getin_p('LEAFAGE_FIRSTMAX',leafage_firstmax)
+       !
+       !Config Key   = LEAFAGE_LASTMAX 
+       !Config Desc  = leaf age at which vmax falls below vcmax_opt (in fraction of critical leaf age) 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.5 
+       !Config Help  = relative leaf age at which vmax falls below vcmax_opt
+       !Config Units = [-]  
+       CALL getin_p('LEAFAGE_LASTMAX',leafage_lastmax)
+       !
+       !Config Key   = LEAFAGE_OLD 
+       !Config Desc  = leaf age at which vmax attains its minimum (in fraction of critical leaf age)
+       !Config If    = OK_STOMATE 
+       !Config Def   = 1.
+       !Config Help  = relative leaf age at which vmax attains its minimum
+       !Config Units = [-]  
+       CALL getin_p('LEAFAGE_OLD',leafage_old)
+
+       !-
+       ! season parameters
+       !-
+       !
+       !Config Key   = GPPFRAC_DORMANCE 
+       !Config Desc  = rapport maximal GPP/GGP_max pour dormance
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.2 
+       !Config Help  = 
+       !Config Units = [-]
+       CALL getin_p('GPPFRAC_DORMANCE',gppfrac_dormance)
+       !
+       !Config Key   = TAU_CLIMATOLOGY
+       !Config Desc  = tau for "climatologic variables 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 20
+       !Config Help  = 
+       !Config Units = [days]
+       CALL getin_p('TAU_CLIMATOLOGY',tau_climatology)
+       !
+       !Config Key   = HVC1 
+       !Config Desc  = parameters for herbivore activity
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.019
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('HVC1',hvc1)
+       !
+       !Config Key   = HVC2 
+       !Config Desc  = parameters for herbivore activity 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 1.38
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('HVC2',hvc2)
+       !
+       !Config Key   = LEAF_FRAC_HVC
+       !Config Desc  = parameters for herbivore activity 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.33
+       !Config Help  = 
+       !Config Units = [-] 
+       CALL getin_p('LEAF_FRAC_HVC',leaf_frac_hvc)
+       !
+       !Config Key   = TLONG_REF_MAX
+       !Config Desc  = maximum reference long term temperature 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 303.1
+       !Config Help  = 
+       !Config Units = [K]  
+       CALL getin_p('TLONG_REF_MAX',tlong_ref_max)
+       !
+       !Config Key   = TLONG_REF_MIN 
+       !Config Desc  = minimum reference long term temperature 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 253.1
+       !Config Help  = 
+       !Config Units = [K]  
+       CALL getin_p('TLONG_REF_MIN',tlong_ref_min)
+       !
+       !Config Key   = TUNE_WATERSTRESS
+       !Config Desc  = Tuning parameter when calculating ::wstress_fac from ::moiavail_daily
+       !Config If    = OK_STOMATE, functional_allocation 
+       !Config Def   = 2
+       !Config Help  = 
+       !Config Units = [-]
+       CALL getin_p('TUNE_WATERSTRESS',tune_waterstress)
+       !
+       !Config Key   = NCD_MAX_YEAR
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 3. 
+       !Config Help  = NCD : Number of Chilling Days
+       !Config Units = [days]
+       CALL getin_p('NCD_MAX_YEAR',ncd_max_year)
+       !
+       !Config Key   = GDD_THRESHOLD 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 5. 
+       !Config Help  = GDD : Growing-Degree-Day
+       !Config Units = [K] 
+       CALL getin_p('GDD_THRESHOLD',gdd_threshold)
+       !
+       !Config Key   = GREEN_AGE_EVER 
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 2. 
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('GREEN_AGE_EVER',green_age_ever)
+       !
+       !Config Key   = GREEN_AGE_DEC
+       !Config Desc  = 
+       !Config If    = OK_STOMATE 
+       !Config Def   = 0.5 
+       !Config Help  = 
+       !Config Units = [-] 
+       CALL getin_p('GREEN_AGE_DEC',green_age_dec)
+       !
+       !Config Key   = NGD_MIN_DORMANCE
+       !Config Desc  = Minimum length (days) of the dormance period
+       !               for species with the ngd phenology type
+       !Config If    = OK_STOMATE 
+       !Config Def   = 90.
+       !Config Help  = 
+       !Config Units = [days] 
+       CALL getin_p('NGD_MIN_DORMANCE',ngd_min_dormance)
+       
+       !-
+       ! growth_fun_all
+       !-
+       !Config Key   = BLYPASS_CC_BUG
+       !Config Desc  = There is a bug somewhere which allows the circumference classes to
+       !               deviate from monotonically increasing order, which can cause a problem.
+       !               Setting this to TRUE disables the check for this condition and impliments
+       !               a small patch for the one problem which has manifested.  This needs to
+       !               be found.
+       !Config If    = OK_STOMATE, functional allocation 
+       !Config Def   = FALSE 
+       !Config Help  = 
+       !Config Units = [-]
+       lbypass_cc = .FALSE.
+       CALL getin_p('BYPASS_CC_BUG',lbypass_cc)  
+
+       first_call = .FALSE.
+       
+    ENDIF
+    
+  END SUBROUTINE config_stomate_parameters
+!
+!=
+!
+!! ================================================================================================================================
+!! SUBROUTINE   : config_forest_manage_parameters 
+!!
+!>\BRIEF        This subroutine reads in the configuration file all the parameters 
+!! needed when forest management is activated (ie : when FOREST_MANAGEMENT is set to true).
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    :
+!! \n
+!_ ================================================================================================================================
+
+   SUBROUTINE config_forest_manage_parameters
+     
+    IMPLICIT NONE
+    
+    !! 0. Variables and parameters declaration
+
+    !! 0.4 Local variables   
+
+    LOGICAL, SAVE ::  first_call = .TRUE.  !! To keep first call trace (true/false)
+!$OMP THREADPRIVATE(first_call)
+
+!_ ================================================================================================================================
+    
+    IF(first_call) THEN
+       
+       !Config Key   = BAV_F
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT  
+       !Config Def   = 0
+       !Config Help  = 
+       !Config Units = 
+       bavard_f=0
+       CALL getin_p ('BAV_F',bavard_f)
+
+       !! 2.1 Load parameters
+
+       !Config Key   = SS_SIGMA
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       CALL getin_p ('SS_SIGMA',ss_sigma) 
+       !
+       !Config Key   = FAKE
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT 
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       CALL getin_p ('FAKE',fake)
+       !
+       !Config Key   = EARLY_CUT 
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       CALL getin_p ('EARLY_CUT',early_cut)
+       !
+       !Config Key   = CLEARFIRST 
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT  
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       CALL getin_p ('CLEARFIRST',clearfirst)
+       !
+       !Config Key   = ITINERARY 
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT  
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       CALL getin_p ('ITINERARY',itinerary)
+       !
+       !Config Key   = AGE_TARGET_DEF
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT  
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       CALL getin_p('AGE_TARGET_DEF',age_target_def)
+       !
+       !Config Key   = NTREES_PROFIT
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT  
+       !Config Def   = 100 
+       !Config Help  = 
+       !Config Units = (number of trees)
+       ntrees_profit=200
+       CALL getin_p('NTREES_PROFIT',ntrees_profit)
+
+       ! Sensitivity analysis
+       !
+       !Config Key   = SS_PIPE_DENSITY
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT  
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       CALL getin_p('SS_PIPE_DENSITY',ss_pipe_density)
+
+       !Config Key   = SS_LAMBDA
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT  
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       CALL getin_p('SS_LAMBDA',ss_lambda)
+
+       !Config Key   = SS_CIRC_BM
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT  
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       CALL getin_p('SS_CIRC_BM',ss_circ_bm)
+
+       !Config Key   = SS_HEIGHT_CIRC
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT  
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       CALL getin_p('SS_HEIGHT_CIRC',ss_height_circ)
+
+       !Config Key   = SS_MIN_CIRC_INIT
+       !Config Desc  = 
+       !Config If    = 
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       CALL getin_p('SS_MIN_CIRC_INIT',ss_min_circ_init)
+
+       !Config Key   = SS_P_MAX 
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT  
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       CALL getin_p('SS_P_MAX',ss_p_max)
+
+       !Config Key   = SS_TH_STRAT  
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT  
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       CALL getin_p('SS_TH_STRAT',ss_th_strat)
+
+       !Config Key   = SS_TAU_SPREAD
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT 
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       CALL getin_p('SS_TAU_SPREAD',ss_tau_spread)
+
+       !Config Key   = SS_SELFTH_CURVE
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT  
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       CALL getin_p('SS_SELFTH_CURVE',ss_selfth_curve)
+       
+       !
+       ! these parameters were initially found in the clearcut routine,
+       ! but I moved them here for externalization
+       !
+       !Config Key   = FRAC_SHOOT_INIT
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT  
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       frac_shoot_init = un/1.4_r_std
+       CALL getin_p('FRAC_SHOOT_INIT',frac_shoot_init)
+
+       !Config Key   = MIN_CIRC_INIT
+       !Config Desc  = 
+       !Config If    = FOREST_MANAGEMENT  
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = cm
+       min_circ_init = un*pi
+       CALL getin_p('MIN_CIRC_INIT',min_circ_init)
+
+       !Config Key   = RDI_LIMIT_UPPER
+       !Config Desc  = Replace yield relationship by this values in case inconsistencies
+       !               exist between the fitted self-tinning and fitted yield relationships          
+       !Config If    = OK_STOMATE, functional allocation 
+       !Config Def   = 0.9 
+       !Config Help  = 
+       !Config Units = [-]
+       rdi_limit_upper = 0.9
+       CALL getin_p('RDI_LIMIT_UPPER',rdi_limit_upper)
+
+       !Config Key   = NDIA_HARVEST
+       !Config Desc  = Number of basal area classes in allocation scheme 
+       !Config If    = OK_STOMATE, functional allocation 
+       !Config Def   = 5 
+       !Config Help  = 
+       !Config Units = [-]
+       ndia_harvest = 5
+       CALL getin_p('NDIA_HARVEST',ndia_harvest)
+
+       !Config Key   = MAX_HARVEST_DIA
+       !Config Desc  = The maximum diamter of tree [m] which can be harvested.  Notice that we
+       !               will create a class that is one size larger than this to make sure
+       !               we keep track of all the wood.
+       !Config If    = OK_STOMATE, functional allocation 
+       !Config Def   = 1.0
+       !Config Help  = 
+       !Config Units = [-]
+       max_harvest_dia = un
+       CALL getin_p('MAX_HARVEST_DIA',max_harvest_dia) 
+
+       !Config Key   = N_PAI
+       !Config Desc  = Number of years used for the calculation of the periodic annual increment
+       !Config If    = OK_STOMATE, functional allocation 
+       !Config Def   = 5 
+       !Config Help  = 
+       !Config Units = [-]
+       n_pai=5
+       CALL getin_p('N_PAI',n_pai)
+
+       ! Check to see if we are interested in using a litter demand map
+       ! to remove litter from forest PFTs and put it into agricultural
+       ! PFTs.  This simulations the practice of litter raking.
+       !Config Key   = USE_LITTER_RAKING
+       !Config Desc  =
+       !Config If    = OK_STOMATE
+       !Config Def   = N
+       !Config Help  =
+       !Config Units =
+       use_litter_raking=.FALSE.
+       CALL getin_p('USE_LITTER_RAKING',use_litter_raking)
+
+       ! We need to have the option to read the forest management
+       ! strategy from a map (NetCDF file).  If this option is
+       ! equal to Y, we will overwrite the forest_managed_forced 
+       ! option above, so you should be careful to only use one
+       ! or the other.  
+       !Config Key   = READ_FM_MAP
+       !Config Desc  =
+       !Config If    = OK_STOMATE
+       !Config Def   = N
+       !Config Help  =
+       !Config Units =
+       lread_fm_map=.FALSE.
+       CALL getin_p('READ_FM_MAP',lread_fm_map)
+
+       ! Sometimes it's a good idea to change species after
+       ! a clearcut on managed forest.  If this flag is true,
+       ! we do this.  If not, the same PFT is always replanted.
+       !Config Key   = LCHANGE_SPECIES
+       !Config Desc  =
+       !Config If    = OK_STOMATE
+       !Config Def   = N
+       !Config Help  =
+       !Config Units =
+       lchange_species=.FALSE.
+       CALL getin_p('LCHANGE_SPECIES',lchange_species)
+
+       ! If we change the species after a clearcut, do we want to
+       ! read the new PFT from a map?
+       !Config Key   = READ_SPECIES_CHANGE_MAP
+       !Config Desc  =
+       !Config If    = OK_STOMATE
+       !Config Def   = N
+       !Config Help  =
+       !Config Units =
+       lread_species_change_map=.FALSE.
+       CALL getin_p('READ_SPECIES_CHANGE_MAP',lread_species_change_map)
+
+       ! If we don't read the new species from a map, we will force it
+       ! with this variable.
+       !Config Key   = SPECIES_CHANGE_FORCE
+       !Config Desc  =
+       !Config If    = OK_STOMATE
+       !Config Def   = 1
+       !Config Help  =
+       !Config Units =
+       species_change_force=1
+       CALL getin_p('SPECIES_CHANGE_FORCE',species_change_force)
+
+       first_call = .FALSE.
+       
+    ENDIF
+    
+  END SUBROUTINE config_forest_manage_parameters
+
+!
+! =
+!
+
+!! ================================================================================================================================
+!! SUBROUTINE   : config_dgvm_parameters 
+!!
+!>\BRIEF        This subroutine reads in the configuration file all the parameters 
+!! needed when the DGVM model is activated (ie : when ok_dgvm is set to true).
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    :
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE config_dgvm_parameters   
+    
+    IMPLICIT NONE
+    
+    !! 0. Variables and parameters declaration
+
+    !! 0.4 Local variables
+
+    LOGICAL, SAVE ::  first_call = .TRUE.         !! To keep first call trace (true/false)
+!$OMP THREADPRIVATE(first_call)
+
+!_ ================================================================================================================================    
+
+    IF(first_call) THEN
+  
+       !-
+       ! establish parameters
+       !-
+       !
+       !Config Key   = ESTAB_MAX_TREE
+       !Config Desc  = Maximum tree establishment rate 
+       !Config If    = OK_DGVM
+       !Config Def   = 0.12 
+       !Config Help  = 
+       !Config Units = [-]   
+       CALL getin_p('ESTAB_MAX_TREE',estab_max_tree)
+       !
+       !Config Key   = ESTAB_MAX_GRASS
+       !Config Desc  = Maximum grass establishment rate
+       !Config If    = OK_DGVM
+       !Config Def   = 0.12 
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('ESTAB_MAX_GRASS',estab_max_grass)
+       !
+       !Config Key   = ESTABLISH_SCAL_FACT
+       !Config Desc  = 
+       !Config If    = OK_DGVM 
+       !Config Def   = 5.
+       !Config Help  = 
+       !Config Units = [-] 
+       CALL getin_p('ESTABLISH_SCAL_FACT',establish_scal_fact)
+       !
+       !Config Key   = MAX_TREE_COVERAGE 
+       !Config Desc  = 
+       !Config If    = OK_DGVM 
+       !Config Def   = 0.98
+       !Config Help  = 
+       !Config Units = [-] 
+       CALL getin_p('MAX_TREE_COVERAGE',max_tree_coverage)
+       !
+       !Config Key   = IND_0_ESTAB
+       !Config Desc  = 
+       !Config If    = OK_DGVM 
+       !Config Def   = 0.2
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('IND_0_ESTAB',ind_0_estab)
+
+       !-
+       ! light parameters
+       !-
+       !
+       !Config Key   = ANNUAL_INCREASE
+       !Config Desc  = for diagnosis of fpc increase, compare today's fpc to last year's maximum (T) or to fpc of last time step (F)?
+       !Config If    = OK_DGVM
+       !Config Def   = y
+       !Config Help  = 
+       !Config Units = [FLAG]
+       CALL getin_p('ANNUAL_INCREASE',annual_increase)
+       !
+       !Config Key   = MIN_COVER 
+       !Config Desc  = For trees, minimum fraction of crown area occupied 
+       !Config If    = OK_DGVM
+       !Config Def   = 0.05 
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('MIN_COVER',min_cover)
+
+       !-
+       ! pftinout parameters
+       !
+       !Config Key   = IND_0 
+       !Config Desc  = initial density of individuals
+       !Config If    = OK_DGVM
+       !Config Def   = 0.02 
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('IND_0',ind_0)
+       !
+       !Config Key   = MIN_AVAIL
+       !Config Desc  = minimum availability
+       !Config If    = OK_DGVM
+       !Config Def   = 0.01
+       !Config Help  = 
+       !Config Units = [-]  
+       CALL getin_p('MIN_AVAIL',min_avail)
+       !
+       !Config Key   = RIP_TIME_MIN
+       !Config Desc  = 
+       !Config If    = OK_DGVM
+       !Config Def   = 1.25 
+       !Config Help  = 
+       !Config Units = [year]  
+       CALL getin_p('RIP_TIME_MIN',RIP_time_min)
+       !
+       !Config Key   = NPP_LONGTERM_INIT
+       !Config Desc  = 
+       !Config If    = OK_DGVM
+       !Config Def   = 10.
+       !Config Help  = 
+       !Config Units = [gC/m^2/year]
+       CALL getin_p('NPP_LONGTERM_INIT',npp_longterm_init)
+       !
+       !Config Key   = EVERYWHERE_INIT
+       !Config Desc  = 
+       !Config If    = OK_DGVM
+       !Config Def   = 0.05 
+       !Config Help  = 
+       !Config Units = [-] 
+       CALL getin_p('EVERYWHERE_INIT',everywhere_init)
+       
+       first_call = .FALSE.
+       
+    ENDIF
+    
+    
+  END SUBROUTINE config_dgvm_parameters
+
+
+END MODULE constantes
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parameters/constantes_mtc.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parameters/constantes_mtc.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parameters/constantes_mtc.f90	(revision 7236)
@@ -0,0 +1,1209 @@
+! =================================================================================================================================
+! MODULE       : constantes_mtc
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2011)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         This module contains the standard values of the parameters for the 13 metaclasses of vegetation used by ORCHIDEE.
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): Didier Solyga : replace default values for humscte at 2 meters soil depth by default values for humcste
+!!                   at 4 meters (used for the CMIP simulations). The standard values for 2 meters soil depth are :
+!!                   REAL(r_std), PARAMETER, DIMENSION(nvmc) :: humcste_mtc  =  &
+!!                   & (/ 5.0,   0.8,   0.8,   1.0,   0.8,   0.8,   1.0,  &
+!!                   &    1.0,   0.8,   4.0,   4.0,   4.0,   4.0  /)
+!!
+!! REFERENCE(S)	:
+!! - Kuppel, S. (2012): Doctoral Thesis, Assimilation de mesures de flux turbulents d'eau et de carbone dans un modÃšle de la biosphÃšre 
+!! continentale 
+!! - McDowell, N., Barnard, H., Bond, B.J., Hinckley, T., Hubbard, R.M., Ishii, H., KÃ¶stner, B., 
+!! Magnani, F. Marshall, J.D., Meinzer, F.C., Phillips, N., Ryan, M.G., Whitehead D. 2002. The 
+!! relationship between tree height and leaf area: sapwood area ratio. Oecologia, 132:12â20 
+!! - Kuppel, S., Peylin, P., Chevallier, F., Bacour, C., Maignan, F., and Richardson, A. D. (2012). Constraining a global ecosystem
+!! model with multi-site eddy-covariance data, Biogeosciences, 9, 3757-3776, DOI 10.5194/bg-9-3757-2012.
+!! - Wohlfahrt, G., M. Bahn, E. Haubner, I. Horak, W. Michaeler, K.Rottmar, U. Tappeiner, and A. Cemusca, 1999: Inter-specific 
+!! variation of the biochemical limitation to photosynthesis and related leaf traits of 30 species from mountain grassland 
+!! ecosystems under different land use. Plant Cell Environ., 22, 12811296.
+!! - Malhi, Y., Doughty, C., and Galbraith, D. (2011). The allocation of ecosystem net primary productivity in tropical forests, 
+!! Philosophical Transactions of the Royal Society B-Biological Sciences, 366, 3225-3245, DOI 10.1098/rstb.2011.0062.
+!! - Earles, J. M., Yeh, S., and Skog, K. E. (2012). Timing of carbon emissions from global forest clearance, Nature Climate Change, 2, 
+!! 682-685, Doi 10.1038/Nclimate1535.
+!! - Piao, S. L., Luyssaert, S., Ciais, P., Janssens, I. A., Chen, A. P., Cao, C., Fang, J. Y., Friedlingstein, P., Luo, Y. Q., and 
+!! Wang, S. P. (2010). Forest annual carbon cost: A global-scale analysis of autotrophic respiration, Ecology, 91, 652-661, 
+!! Doi 10.1890/08-2176.1.
+!! - Verbeeck, H., Peylin, P., Bacour, C., Bonal, D., Steppe, K., and Ciais, P. (2011). Seasonal patterns of co2 fluxes in amazon 
+!! forests: Fusion of eddy covariance data and the orchidee model, Journal of Geophysical Research-Biogeosciences, 116, 
+!! Artn G02018, Doi 10.1029/2010jg001544.
+!!
+!! SVN          :
+!! $HeadURL: $
+!! $Date: 2015-02-22 16:18:16 +0100 (Sun, 22 Feb 2015) $
+!! $Revision: 2555 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE constantes_mtc
+
+  USE defprec
+  USE constantes
+
+  IMPLICIT NONE
+
+  !
+  ! METACLASSES CHARACTERISTICS
+  !
+
+  INTEGER(i_std), PARAMETER :: nvmc = 13                               !! Number of MTCS fixed in the code (unitless)
+
+  CHARACTER(len=34), PARAMETER, DIMENSION(nvmc) :: MTC_name = &        !! description of the MTC (unitless)
+  & (/ 'bare 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
+
+
+  !
+  ! VEGETATION STRUCTURE
+  !
+  INTEGER(i_std),PARAMETER, DIMENSION(nvmc) :: leaf_tab_mtc  =  &       !! leaf type (1-4, unitless)
+  & (/  4,   1,   1,   2,   1,   1,   2,   &                            !! 1=broad leaved tree, 2=needle leaved tree
+  &     1,   2,   3,   3,   3,   3   /)                                 !! 3=grass 4=bare ground
+
+  CHARACTER(len=6), PARAMETER, DIMENSION(nvmc) :: pheno_model_mtc  =  & !! which phenology model is used? (tabulated) 
+  & (/  'none  ',   'none  ',   'moi   ',   'none  ',   'none  ',  &
+  &     'ncdgdd',   'none  ',   'ncdgdd',   'ngd   ',   'moigdd',  &
+  &     'moigdd',   'moigdd',   'moigdd'  /) 
+
+  LOGICAL, PARAMETER, DIMENSION(nvmc) :: is_tropical_mtc  =  &          !! Is PFT tropical ? (true/false)
+  & (/ .FALSE.,   .TRUE.,    .TRUE.,    .FALSE.,   .FALSE.,   .FALSE.,   .FALSE.,  &
+  &    .FALSE.,   .FALSE.,   .FALSE.,   .FALSE.,   .FALSE.,   .FALSE. /)    
+
+  LOGICAL, PARAMETER, DIMENSION(nvmc) :: is_temperate_mtc  =  &         !! Is PFT temperate ? (true/false)
+  & (/ .FALSE.,   .FALSE.,   .FALSE.,   .TRUE.,    .TRUE.,    .TRUE.,   .FALSE.,  &
+  &    .FALSE.,   .FALSE.,   .FALSE.,   .FALSE.,   .FALSE.,   .FALSE. /)
+
+  LOGICAL, PARAMETER, DIMENSION(nvmc) :: is_boreal_mtc = &              !! Is PFT boreal ? (true/false)
+  & (/ .FALSE.,   .FALSE.,   .FALSE.,   .FALSE.,   .FALSE.,   .FALSE.,   .TRUE.,  &
+  &    .TRUE.,   .TRUE.,   .FALSE.,   .FALSE.,   .FALSE.,   .FALSE. /)
+    
+
+  CHARACTER(LEN=5), PARAMETER, DIMENSION(nvmc) :: type_of_lai_mtc  =  & !! Type of behaviour of the LAI evolution algorithm
+  & (/ 'inter', 'inter', 'inter', 'inter', 'inter',  &                  !! for each vegetation type. (unitless)
+  &    'inter', 'inter', 'inter', 'inter', 'inter',  &                  !! Value of type_of_lai : mean or interp
+  &    'inter', 'inter', 'inter' /)
+
+  LOGICAL, PARAMETER, DIMENSION(nvmc) :: natural_mtc =  &               !! natural?  (true/false)
+  & (/ .TRUE.,   .TRUE.,   .TRUE.,   .TRUE.,   .TRUE.,    .TRUE.,   .TRUE.,  &
+  &    .TRUE.,   .TRUE.,   .TRUE.,   .TRUE.,   .FALSE.,   .FALSE.  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: veget_ori_fixed_mtc  =  &  !! Value for veget_ori for tests in
+  & (/ 0.2,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,  &                !! 0-dim simulations (0-1, unitless)
+  &    0.0,   0.0,   0.8,   0.0,   0.0,   0.0  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: llaimax_mtc  =  &          !! laimax for maximum
+  & (/ undef,   8.0,   8.0,   4.0,   4.5,   4.5,   4.0,  &              !! See also type of lai interpolation
+  &      4.5,   4.0,   2.0,   2.0,   2.0,   2.0  /)                     !! @tex $(m^2.m^{-2})$ @endtex
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: llaimin_mtc  = &           !! laimin for minimum lai
+  & (/ undef,   8.0,   0.0,   4.0,   4.5,   0.0,   4.0,  &              !! See also type of lai interpolation (m^2.m^{-2})
+  &      0.0,   0.0,   0.0,   0.0,   0.0,   0.0  /)                     !! @tex $(m^2.m^{-2})$ @endtex
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: height_presc_mtc  =  &     !! prescribed height of vegetation (m) ONLY used without
+  & (/  0.0,   30.0,   30.0,   20.0,   20.0,   20.0,   15.0,  &         !! stomate. Value for height_presc : one for each vegetation 
+  &    15.0,   15.0,    0.5,    0.6,    1.0,    1.0  /)                 !! type
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: rveg_mtc  =  &             !! Potentiometer to set vegetation resistance (unitless)
+  & (/ 1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,  &                !! Nathalie on March 28th, 2006 - from Fred Hourdin,
+  &    1.0,   1.0,   1.0,   1.0,   1.0,   1.0   /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: sla_mtc  =  &              !! specif leaf area @tex $(m^2.gC^{-1})$ @endtex
+  & (/ 1.5E-2,   1.53E-2,   2.6E-2,   9.26E-3,     2E-2,   2.6E-2,   9.26E-3,  &
+  &    2.6E-2,    1.9E-2,   2.6E-2,    2.6E-2,   2.6E-2,   2.6E-2  /) 
+
+
+  !
+  ! EVAPOTRANSPIRATION (sechiba)
+  !
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: rstruct_const_mtc  =  &    !! Structural resistance.
+  & (/ 0.0,   25.0,   25.0,   25.0,   25.0,   25.0,   25.0,  &          !! @tex $(s.m^{-1})$ @endtex
+  &   25.0,   25.0,    2.5,    2.0,    2.0,    2.0   /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: kzero_mtc  =  &                  !! A vegetation dependent constant used in the 
+  & (/    0.0,   12.E-5,   12.E-5,   12.E-5,   12.E-5,   25.E-5,   12.E-5,  & !! calculation  of the surface resistance. 
+  &    25.E-5,   25.E-5,   30.E-5,   30.E-5,   30.E-5,   30.E-5  /)           !! @tex $(kg.m^2.s^{-1})$ @endtex
+
+
+  !
+  ! WATER (sechiba)
+  !
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: wmax_veg_mtc  =  &        !! Volumetric available soil water capacity in each PFT
+  & (/ 150.0,   150.0,   150.0,   150.0,   150.0,   150.0,   150.0,  & !! @tex $(kg.m^{-3} of soil)$ @endtex
+  &    150.0,   150.0,   150.0,   150.0,   150.0,   150.0  /)         
+                                                                      
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: humcste_mtc  =  &         !! Root profile description for the different 
+  & (/ 5.0,   0.4,   0.4,   1.0,   0.8,   0.8,   1.0,  &               !! vegetations types. @tex $(m^{-1})$ @endtex
+  &    1.0,   0.8,   4.0,   1.0,   4.0,   1.0  /)                      !! These are the factor in the exponential which gets       
+                                                                       !! the root density as a function of depth
+                                                                       !! Values for zmaxh = 4.0  
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: humcste_cwrr  =  &        !! Root profile description for the different
+  & (/ 5.0,   0.8,   0.8,   1.0,   0.8,   0.8,   1.0,  &               !! vegetations types.  @tex $(m^{-1})$ @endtex
+  &    1.0,   0.8,   4.0,   4.0,   4.0,   4.0  /)                      !! These are the factor in the exponential which gets       
+                                                                        !! the root density as a function of depth
+                                                                        !! Values for zmaxh = 2.0
+                                                                        !! (used by using 11 layers hydrology) 
+
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: throughfall_by_mtc  =  &  !! Fraction of rain intercepted by the canopy
+  & (/ 30.0,   30.0,   30.0,   30.0,   30.0,   30.0,   30.0,  &        !! (0-100, unitless)
+  &    30.0,   30.0,   30.0,   30.0,   30.0,   30.0  /)
+
+
+  !
+  ! ALBEDO (sechiba)
+  !
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: snowa_aged_mtc  =  &    !! Minimum snow albedo value for each vegetation type
+  & (/ 0.35,    0.0,    0.0,   0.14,   0.14,   0.14,   0.14,  &      !! after aging (dirty old snow) (unitless)
+  &    0.14,   0.14,   0.18,   0.18,   0.18,   0.18  /)              !! Source : Values are from the Thesis of S. Chalita (1992)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: snowa_dec_mtc  =  &     !! Decay rate of snow albedo value for each vegetation type
+  & (/ 0.45,    0.0,    0.0,   0.06,   0.06,   0.11,   0.06,  &      !! as it will be used in condveg_snow (unitless)
+  &    0.11,   0.11,   0.52,   0.52,   0.52,   0.52  /)              !! Source : Values are from the Thesis of S. Chalita (1992)
+  !
+  ! albedo values for albedo type 'standard'
+  !
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: alb_leaf_vis_mtc  =  &  !! leaf albedo of vegetation type, visible albedo 
+  & (/ 0.00,   0.04,   0.06,   0.06,   0.06,   0.06,   0.06,  &      !! (unitless)
+  &    0.06,   0.06,   0.10,   0.10,   0.10,   0.10  /) 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: alb_leaf_nir_mtc  =  &  !! leaf albedo of vegetation type, near infrared albedo
+  & (/ 0.00,   0.10,   0.22,   0.22,   0.22,   0.22,   0.22,  &      !! (unitless)
+  &    0.22,   0.22,   0.30,   0.30,   0.30,   0.30  /)
+
+  !
+  ! albedo values for albedo type 'pinty'
+  ! these next values were determined by fitting to global MODIS data and using the inversion scheme of
+  ! Pinty et al (see Pinty B,Andredakis I, Clerici M, et al. (2011) ! 'Exploiting the MODIS albedos 
+  ! with the Two-stream Inversion Package (JRC-TIP): 1. Effective leaf area index,
+  ! vegetation, and soil properties'. Journal of Geophysical Research.
+  !
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: leaf_ssa_vis_mtc  =  &           !! leaf single scattering albedo, visible light (unitless)
+  (/ 0.17192, 0.12560, 0.16230, 0.13838, 0.13202, 0.14720,  &
+     0.14680, 0.14415, 0.15485, 0.17544, 0.17384, 0.17302, 0.17116 /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: leaf_ssa_nir_mtc  =  &           !! leaf single scattering albedo, near infrared (unitless)
+  (/ 0.70253, 0.68189, 0.69684, 0.68778, 0.68356, 0.69533, &
+     0.69520, 0.69195, 0.69180, 0.71236, 0.71904, 0.71220, 0.71190 /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: leaf_psd_vis_mtc  =  &           !! leaf preferred scattering direction, visible light (unitless)
+  (/ 1.00170, 0.96776, 0.99250, 0.97170, 0.97119, 0.98077, &
+     0.97672, 0.97810, 0.98605, 1.00490, 1.00360, 1.00320, 1.00130 /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: leaf_psd_nir_mtc  =  &           !! leaf preferred scattering direction, NIR light (unitless)
+  (/ 2.00520, 1.95120, 1.98990, 1.97020, 1.95900, 1.98190, &
+     1.98890, 1.97400, 1.97780, 2.02430, 2.03350, 2.02070, 2.02150 /)
+    
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: bgd_reflectance_vis_mtc  =  &    !! background reflectance, visible light (unitless)
+  (/ 0.13796, 0.08311, 0.08784, 0.04339, 0.07228, 0.06460, &
+     0.03170, 0.06029, 0.06403, 0.12459, 0.14366, 0.11012, 0.12245 /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: bgd_reflectance_nir_mtc  =  &    !! background reflectance, NIR light (unitless)
+  (/ 0.26520, 0.14605, 0.14937, 0.06608, 0.12334, 0.10534, &
+     0.04443, 0.09455, 0.09770, 0.23034, 0.29221, 0.20508, 0.23339 /)
+     
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: tune_coupled_mtc  =  &           !! tune factors for LAI coupled LAI,  (unitless)
+  (/ un,   un,   un,   un,   un,   un,   un,  &  
+     un,   un,   un,   un,   un,   un /)    
+     
+     
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: leaf_to_shoot_clumping_mtc  =  & !! The clumping factor for leaves to shoots in the 
+  (/ un,   un,   un,   un,   un,   un,   un,  &                               !! effective LAI calculation...notice this should be
+     un,   un,   un,   un,   un,   un /)                                      !! equal to unity for grasslands/croplands
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: lai_correction_factor_mtc  =  &  !! see the note about this variable in pft_parameters
+  (/ un,   un,   un,   un,   un,   un,   un,  &  
+     un,   un,   un,   un,   un,   un /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: min_level_sep_mtc  =  &          !! The minimum level thickness for photosynthesis [m]
+  (/ un,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,  &                         !! This number is arbitrary at the moment.  The idea
+     0.1,   0.1,   0.1,   0.1,   0.1,   0.1 /)                                !! is to have a small number to make as many levels
+                                                                              !! as possible in the canopies, but not too small which
+                                                                              !! results in too little LAI in all the levels.  If all your
+                                                                              !! levels have less than 0.1 LAI in them, that's probably 
+                                                                              !! too small.
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: lai_top_mtc = &                  !! Diffuco.f90 calculates the stomatal conductance of the
+  (/ un,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,  &                         !! top layer of the canopy. Because the top layer can contain
+     0.1,   0.1,   0.1,   0.1,   0.1,   0.1 /)                                !! diiferent amounts of LAI depending on the crown diameter
+                                                                              !! we had to define top layer in terms of the LAI it contains.
+                                                                              !! stomatal conductance in the top layer contributes to the 
+                                                                              !! transpiration (m2 m-2). Arbitrary values.
+  !
+  ! SOIL - VEGETATION
+  !
+  INTEGER(i_std), PARAMETER, DIMENSION(nvmc) :: pref_soil_veg_mtc  =  &       !! The soil tile number for each vegetation
+  & (/ 1,   2,   2,   2,   2,   2,   2,  &                                    
+  &    2,   2,   3,   3,   3,   3  /)                                         
+
+  !
+  ! VEGETATION - AGE CLASSES
+  !
+  INTEGER(i_std), PARAMETER, DIMENSION(nvmc) :: agec_group_mtc  =  &       !! The age class group that each PFT belongs to.
+       (/ 1,   2,   3,   4,   5,   6,   7,  &                                    
+       8,   9,   10,   11,   12,   13  /)                                         
+
+
+  !
+  ! PHOTOSYNTHESIS
+  !
+  !-
+  ! 1 .CO2
+  !-
+ LOGICAL, PARAMETER, DIMENSION(nvmc) :: is_c4_mtc  =  &                            !! flag for C4 vegetation types (true/false)
+  & (/ .FALSE.,  .FALSE.,   .FALSE.,   .FALSE.,   .FALSE.,   .FALSE.,   .FALSE.,  &
+  &    .FALSE.,  .FALSE.,   .FALSE.,   .TRUE.,    .FALSE.,   .TRUE.  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: vcmax_fix_mtc  =  &     !! values used for vcmax when STOMATE is not
+  & (/  0.0,   40.0,   50.0,   30.0,   35.0,   40.0,   30.0,  &      !! activated @tex $(\mu mol.m^{-2}.s^{-1})$ @endtex
+  &    40.0,   35.0,   60.0,   60.0,   70.0,   70.0  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: E_KmC_mtc  = &            !! Energy of activation for KmC (J mol-1)
+  & (/undef,  79430.,  79430.,  79430.,  79430.,  79430.,  79430.,  &  !! See Medlyn et al. (2002) 
+  &  79430.,  79430.,  79430.,  79430.,  79430.,  79430.  /)           !! from Bernacchi al. (2001)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: E_KmO_mtc  = &            !! Energy of activation for KmO (J mol-1)
+  & (/undef,  36380.,  36380.,  36380.,  36380.,  36380.,  36380.,  &  !! See Medlyn et al. (2002) 
+  &  36380.,  36380.,  36380.,  36380.,  36380.,  36380.  /)           !! from Bernacchi al. (2001)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: E_gamma_star_mtc  = &     !! Energy of activation for gamma_star (J mol-1)
+  & (/undef,  37830.,  37830.,  37830.,  37830.,  37830.,  37830.,  &  !! See Medlyn et al. (2002) from Bernacchi al. (2001) 
+  &  37830.,  37830.,  37830.,  37830.,  37830.,  37830.  /)           !! for C3 plants - We use the same values for C4 plants
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: E_Vcmax_mtc  = &          !! Energy of activation for Vcmax (J mol-1)
+  & (/undef,  71513.,  71513.,  71513.,  71513.,  71513.,  71513.,  &  !! See Table 2 of Yin et al. (2009) for C4 plants
+  &  71513.,  71513.,  71513.,  67300.,  71513.,  67300.  /)           !! and Kattge & Knorr (2007) for C3 plants (table 3)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: E_Jmax_mtc  = &            !! Energy of activation for Jmax (J mol-1)
+  & (/undef,  49884.,  49884.,  49884.,  49884.,  49884.,  49884.,  &   !! See Table 2 of Yin et al. (2009) for C4 plants
+  &  49884.,  49884.,  49884.,  77900.,  49884.,  77900.  /)            !! and Kattge & Knorr (2007) for C3 plants (table 3)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: aSV_mtc     = &            !! a coefficient of the linear regression (a+bT) defining   
+  & (/undef,  668.39,  668.39,  668.39,  668.39,  668.39,  668.39,  &   !! the Entropy term for Vcmax (J K-1 mol-1) See Table 3 of 
+  &  668.39,  668.39,  668.39,  641.64,  668.39,  641.64  /)            !! Kattge & Knorr (2007). For C4 plants, we assume that 
+                                                                        !! there is no acclimation and that at for a temperature 
+                                                                        !! of 25Â°C, aSV is the same for both C4 and C3 plants 
+                                                                        !! (no strong jusitification - need further parametrization)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: bSV_mtc     = &            !! b coefficient of the linear regression (a+bT) defining 
+  & (/undef,   -1.07,   -1.07,   -1.07,   -1.07,   -1.07,   -1.07,  &   !! the Entropy term for Vcmax (J K-1 mol-1 Â°C-1) See Table 3 
+  &   -1.07,   -1.07,   -1.07,      0.,   -1.07,      0.  /)            !! of Kattge & Knorr (2007). We assume No acclimation term for C4 plants
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: tphoto_min_mtc  =  &       !! minimum photosynthesis temperature (deg C) 
+  & (/  undef,   -4.0,    -4.0,   -4.0,   -4.0,   -4.0,   -4.0,  & 
+  &      -4.0,   -4.0,    -4.0,   -4.0,   -4.0,   -4.0  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: tphoto_max_mtc  =  &       !! maximum photosynthesis temperature (deg C) 
+  & (/  undef,   55.0,    55.0,   55.0,   55.0,   55.0,   55.0,  & 
+  &      55.0,   55.0,    55.0,   55.0,   55.0,   55.0  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: aSJ_mtc     = &            !! a coefficient of the linear regression (a+bT) defining the 
+  & (/undef,  659.70,  659.70,  659.70,  659.70,  659.70,  659.70,  &   !! Entropy term for Jmax (J K-1 mol-1) See Table 3 of 
+  &  659.70,  659.70,  659.70,    630.,  659.70,    630.  /)            !! Kattge & Knorr (2007) and Table 2 of Yin et al. (2009) for C4 plants
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: bSJ_mtc     = &            !! b coefficient of the linear regression (a+bT) defining the 
+  & (/undef,   -0.75,   -0.75,   -0.75,   -0.75,   -0.75,   -0.75,  &   !! Entropy term for Jmax (J K-1 mol-1 Â°C-1). See Table 3 of 
+  &   -0.75,   -0.75,   -0.75,      0.,   -0.75,      0.  /)            !! Kattge & Knorr (2007) We assume no acclimation term for C4 plants
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: D_Vcmax_mtc  = &           !! Energy of deactivation for Vcmax (J mol-1)
+  & (/undef, 200000., 200000., 200000., 200000., 200000., 200000.,  &   !! Medlyn et al. (2002) also uses 200000. for C3 plants (same value than D_Jmax)
+  & 200000., 200000., 200000., 192000., 200000., 192000.  /)            !! 'Consequently', we use the value of D_Jmax for C4 plants
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: D_Jmax_mtc  = &            !! Energy of deactivation for Jmax (J mol-1)
+  & (/undef, 200000., 200000., 200000., 200000., 200000., 200000.,  &   !! See Table 2 of Yin et al. (2009)
+  & 200000., 200000., 200000., 192000., 200000., 192000.  /)            !! Medlyn et al. (2002) also uses 200000. for C3 plants
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: E_Rd_mtc  = &              !! Energy of activation for Rd (J mol-1)
+  & (/undef,  46390.,  46390.,  46390.,  46390.,  46390.,  46390.,  &   !! See Table 2 of Yin et al. (2009)
+  &  46390.,  46390.,  46390.,  46390.,  46390.,  46390.  /)           
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: Vcmax25_mtc  =  &          !! Maximum rate of Rubisco activity-limited carboxylation at 25Â°C
+  & (/ undef,   65.0,    65.0,    35.0,   45.0,   55.0,   35.0,  &      !! @tex $(\mu mol.m^{-2}.s^{-1})$ @endtex
+  &     45.0,   35.0,    70.0,    70.0,   70.0,   70.0  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: arJV_mtc    = &            !! a coefficient of the linear regression (a+bT) defining the 
+  & (/undef,    2.59,    2.59,    2.59,    2.59,    2.59,    2.59,  &   !! Jmax25/Vcmax25 ratio (mu mol e- (mu mol CO2)-1) See Table 3 of 
+  &    2.59,    2.59,    2.59,   1.715,    2.59,   1.715  /)            !! Kattge & Knorr (2007). For C4 plants, we assume that there is no
+                                                                        !! acclimation and that for a temperature of 25Â°C, aSV is the same 
+                                                                        !! for both C4 and C3 plants (no strong jusitification - need further 
+                                                                        !! parametrization)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: brJV_mtc    = &            !! b coefficient of the linear regression (a+bT) defining the 
+  & (/undef,  -0.035,  -0.035,  -0.035,  -0.035,  -0.035,  -0.035,  &   !! Jmax25/Vcmax25 ratio ((mu mol e- (mu mol CO2)-1) (Â°C)-1) See 
+  &  -0.035,  -0.035,  -0.035,      0.,  -0.035,      0.  /)            !! Table 3 of Kattge & Knorr (2007). We assume No acclimation term for C4 plants
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: KmC25_mtc  = &             !! MichaelisâMenten constant of Rubisco for CO2 at 25Â°C (ubar)
+  & (/undef,   404.9,   404.9,   404.9,   404.9,  404.9,   404.9,  &    !! See Table 2 of Yin et al. (2009) for C4
+  &   404.9,   404.9,   404.9,    650.,   404.9,   650.  /)             !! and Medlyn et al (2002) for C3
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: KmO25_mtc  = &             !! MichaelisâMenten constant of Rubisco for O2 at 25Â°C (ubar)
+  & (/undef, 278400., 278400., 278400., 278400., 278400., 278400.,  &   !! See Table 2 of Yin et al. (2009) for C4 plants and Medlyn et al. (2002) for C3
+  & 278400., 278400., 278400., 450000., 278400., 450000.  /)           
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: gamma_star25_mtc  = &      !! Ci-based CO2 compensation point in the absence of Rd at 25Â°C (ubar)
+  & (/undef,   42.75,   42.75,   42.75,   42.75,   42.75,   42.75,  &   !! See Medlyn et al. (2002) for C3 plants - For C4 plants, we use the 
+  &   42.75,   42.75,   42.75,   42.75,   42.75,   42.75  /)            !! same value (probably uncorrect)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: a1_mtc  = &                !! Empirical factor involved in the calculation of fvpd (-)
+  & (/undef,    0.85,    0.85,    0.85,    0.85,    0.85,  0.85,  &     !! See Table 2 of Yin et al. (2009)
+  &    0.85,    0.85,    0.85,    0.85,    0.85,    0.85  /)           
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: b1_mtc  = &                !! Empirical factor involved in the calculation of fvpd (-)
+  & (/undef,    0.14,    0.14,    0.14,    0.14,    0.14,  0.14,  &     !! See Table 2 of Yin et al. (2009)
+  &    0.14,    0.14,    0.14,    0.20,    0.14,    0.20  /)           
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: g0_mtc  = &                !! Residual stomatal conductance when irradiance approaches 
+  & (/undef, 0.00625, 0.00625, 0.00625, 0.00625, 0.00625, 0.00625,  &   !! zero (mol CO2 mâ2 sâ1 barâ1). Value from ORCHIDEE - No other reference.
+  & 0.00625, 0.00625, 0.00625, 0.01875, 0.00625, 0.01875  /)            !! modofy to account for the conversion for conductance to H2O to CO2 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: h_protons_mtc  = &         !! Number of protons required to produce one ATP (mol mol-1)
+  & (/undef,      4.,      4.,      4.,      4.,      4.,    4.,  &     !! See Table 2 of Yin et al. (2009) - h parameter
+  &      4.,      4.,      4.,      4.,      4.,      4.  /)           
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: fpsir_mtc = &              !! Fraction of PSII eâ transport rate 
+  & (/undef,   undef,   undef,   undef,   undef,  undef,  undef,  &     !! partitioned to the C4 cycle (-)
+  &   undef,   undef,   undef,     0.4,   undef,    0.4  /)             !! See Table 2 of Yin et al. (2009) - x parameter        
+ 
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: fQ_mtc = &                 !! Fraction of electrons at reduced plastoquinone 
+  & (/undef,   undef,   undef,   undef,   undef,  undef,  undef,  &     !! that follow the Q-cycle (-) - Values for C3 platns are not used
+  &   undef,   undef,   undef,      1.,   undef,     1.  /)             !! See Table 2 of Yin et al. (2009)          
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: fpseudo_mtc = &            !! Fraction of electrons at PSI that follow 
+  & (/undef,   undef,   undef,   undef,   undef,  undef,  undef,  &     !! pseudocyclic transport (-) - Values for C3 platns are not used
+  &   undef,   undef,   undef,     0.1,   undef,    0.1  /)             !! See Table 2 of Yin et al. (2009)    
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: kp_mtc = &                 !! Initial carboxylation efficiency of the PEP carboxylase (mol mâ2 sâ1 barâ1) 
+  & (/undef,   undef,   undef,   undef,   undef,  undef,  undef,  &     !! See Table 2 of Yin et al. (2009)
+  &   undef,   undef,   undef,     0.7,   undef,    0.7  /)                 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: alpha_mtc = &              !! Fraction of PSII activity in the bundle sheath (-)
+  & (/undef,   undef,   undef,   undef,   undef,  undef,  undef,  &     !! See legend of Figure 6 of Yin et al. (2009)
+  &   undef,   undef,   undef,     0.1,   undef,    0.1  /)                 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: gbs_mtc = &                !! Bundle-sheath conductance (mol mâ2 sâ1 barâ1)
+  & (/undef,   undef,   undef,   undef,   undef,  undef,  undef,  &     !! See legend of Figure 6 of Yin et al. (2009)
+  &   undef,   undef,   undef,   0.003,   undef,  0.003  /)    
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: theta_mtc = &              !! Convexity factor for response of J to irradiance (-)
+  & (/undef,     0.7,     0.7,     0.7,     0.7,    0.7,    0.7,  &     !! See Table 2 of Yin et al. (2009) 
+  &     0.7,     0.7,     0.7,     0.7,     0.7,    0.7  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: alpha_LL_mtc = &           !! Conversion efficiency of absorbed light into J at strictly 
+  & (/undef,     0.3,     0.3,     0.3,     0.3,    0.3,    0.3,  &     !! limiting light (mol eâ (mol photon)â1). See comment from 
+  &     0.3,     0.3,     0.3,     0.3,     0.3,    0.3  /)             !! Yin et al. (2009) after eq. 4. alpha value from Medlyn et al. (2002)
+                                                                        !! This is rather low, Yin et al. proposes 0.43 (text above eq.11)
+
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: downregulation_co2_coeff_mtc  =  &  !! coefficient for CO2 downregulation 
+  & (/  0.0,   0.38,   0.38,   0.28,   0.28,   0.28,   0.22,  &
+  &     0.22,  0.22,   0.26,   0.26,   0.26,   0.26 /)
+  !-
+  ! 2 .Stomate
+  !-
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: ext_coeff_mtc  =  &     !! extinction coefficient of the Monsi&Saeki
+  & (/ 0.5,   0.5,   0.5,   0.5,   0.5,   0.5,   0.5,  &             !! relationship (1953) (unitless)
+  &    0.5,   0.5,   0.5,   0.5,   0.5,   0.5  /)
+    
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: vcmax_opt_fun_all_mtc = & !! Maximum rate of carboxylation
+  & (/ undef,   65.,    65.,    35.,    40.,    55.,    35., &         !! @tex $(\mu mol.m^{-2}.s^{-1})$ @endtex
+  &      45.,   35.,    70.,    70.,    70.,    70.     /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: vjmax_opt_fun_all_mtc = & !! Maximum rate of RUbp regeneration
+  & vcmax_opt_fun_all_mtc(:)*2.                                        !! @tex $(\mu mol.m^{-2}.s^{-1})$ @endtex
+      
+  !
+  ! ALLOCATION (stomate)
+  ! 
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: S0_mtc = &              !! Default sapwood allocation (0-1, unitless)
+  & (/ undef,   0.25,   0.25,   0.30,   0.30,  0.30,    0.30, &
+  &     0.30,   0.30,   0.30,   0.30,   0.30,  0.30 /)                   
+
+  !
+  ! RESPIRATION (stomate)
+  !
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: maint_resp_slope_c_mtc  =  &  !! slope of maintenance respiration coefficient (1/K),
+  & (/  undef,   0.20,   0.20,   0.16,   0.16,   0.16,   0.16,  &          !! constant c of aT^2+bT+c, tabulated
+  &      0.16,   0.16,   0.16,   0.12,   0.16,   0.12  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: maint_resp_slope_b_mtc  =  &  !! slope of maintenance respiration coefficient (1/K),
+  & (/  undef,   0.0,        0.0,   0.0,        0.0,   0.0,   0.0,  &      !! constant b of aT^2+bT+c, tabulated
+  &       0.0,   0.0,   -0.00133,   0.0,   -0.00133,   0.0  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: maint_resp_slope_a_mtc  =  &  !! slope of maintenance respiration coefficient (1/K),
+  & (/  undef,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,  &                !! constant a of aT^2+bT+c, tabulated
+  &       0.0,   0.0,   0.0,   0.0,   0.0,   0.0  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cm_zero_leaf_mtc  =   &                  !! maintenance respiration coefficient
+  & (/   undef,   2.35E-3,   2.62E-3,   1.01E-3,   2.35E-3,   2.62E-3,   1.01E-3,  &  !! at 0 deg C,for leaves, tabulated, 
+  &    2.62E-3,   2.05E-3,   2.62E-3,   2.62E-3,   2.62E-3,   2.62E-3  /)             !! @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cm_zero_sapabove_mtc =  &                !! maintenance respiration coefficient 
+  & (/   undef,   1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4,  &  !! at 0 deg C, for sapwood above,
+  &    1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4  /)             !! tabulated, @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cm_zero_sapbelow_mtc  =  &               !! maintenance respiration coefficient
+  & (/   undef,   1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4,  &  !! at 0 deg C, for sapwood below, 
+  &    1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4  /)             !! tabulated, @tex $(gC.gC^{-1}.day^{-1})$ @endtex 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cm_zero_heartabove_mtc  =  &             !! maintenance respiration coefficient
+  & (/  undef,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,  &                           !! at 0 deg C, for heartwood above,
+  &       0.0,   0.0,   0.0,   0.0,   0.0,   0.0  /)                                  !! tabulated, @tex $(gC.gC^{-1}.day^{-1})$ @endtex 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cm_zero_heartbelow_mtc  =  &             !! maintenance respiration coefficient
+  & (/  undef,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,  &                           !! at 0 deg C, for heartwood below, 
+  &       0.0,   0.0,   0.0,   0.0,   0.0,   0.0  /)                                  !! tabulated, @tex $(gC.gC^{-1}.day^{-1})$ @endtex 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cm_zero_root_mtc  =  &                   !! maintenance respiration coefficient
+  & (/   undef,   1.67E-3,   1.67E-3,   1.67E-3,   1.67E-3,   1.67E-3,   1.67E-3,  &  !! at 0 deg C, for roots, tabulated,
+  &    1.67E-3,   1.67E-3,   1.67E-3,   1.67E-3,   1.67E-3,   1.67E-3  /)             !! @tex $(gC.gC^{-1}.day^{-1})$ @endtex 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cm_zero_fruit_mtc  =  &                  !! maintenance respiration coefficient
+  & (/   undef,   1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4,  &  !! at 0 deg C, for fruits, tabulated,
+  &    1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4,   1.19E-4  /)             !!  @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+   
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cm_zero_carbres_fun_all_mtc  =  &        !! maintenance respiration coefficient
+  & (/   undef,   0.,   0.,   0.,   0.,   0.,   0.,  &                                !! at 0 deg C, for carbohydrate reserve,
+  &         0.,   0.,   0.,   0.,   0.,   0.   /)                                     !! tabulated, @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cm_zero_labile_fun_all_mtc =    &        !! maintenance respiration coefficient
+  & (/  undef,  2.78E-3, 2.78E-3, 2.78E-3, 2.78E-3, 2.78E-3, 2.78E-3,    &            !! at 0 deg C, for labile carbon pool,
+  &   2.78E-3,  2.78E-3, 2.78E-3, 2.78E-3, 2.78E-3, 2.78E-3  /)*12.                   !! tabulated, @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cm_zero_carbres_res_lim_mtc  =  &        !! maintenance respiration coefficient
+  & (/   undef, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4,  &              !! at 0 deg C, for carbohydrate reserve,
+  &    1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4  /)                       !! tabulated, @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cm_zero_labile_res_lim_mtc  =  &         !! (not used) maintenance respiration coefficient
+  & (/   undef,   0.,   0.,   0.,   0.,   0.,   0.,  &                                !! at 0 deg C, for labile carbon pool,
+  &    0.,        0.,   0.,   0.,   0.,   0.   /)                                     !! tabulated, @tex $(gC.gC^{-1}.day^{-1})$ @endtex  
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: coeff_maint_init_mtc = &                 !! Initial values for maintenance respiration 
+  & (/  undef,   0.022,   0.022,  0.021,  0.033,  0.033,  0.033,       &              !! at 0 deg C, used in the functional allocation
+  &     0.033,   0.033,   0.033,  0.033,  0.033,  0.033      /)                       !! scheme. The range of the values  is given by
+                                                                                      !! Sitch et al 2003  but the values were tuned to
+                                                                                      !! obtain a NPP/GPP ratio of 0.5 in forests
+                                                                                      !! given a sufficient nutrient supply (see Vicca 
+                                                                                      !! et al 2012 Ecology Letters)
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: frac_growthresp_res_lim_mtc = &          !! Fraction of growth respiration expressed as 
+  &(/  0.28,   0.28,   0.28,   0.28,   0.28,   0.28,   0.28, &                        !! share of the total C that is to be allocated
+  &    0.28,   0.28,   0.28,   0.28,   0.28,   0.28 /)                                !! (0-1). Value for the resource limitation based
+                                                                                      !! allocation scheme
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: frac_growthresp_fun_all_mtc = &          !! Fraction of growth respiration expressed as
+  &(/  0.28,   0.28,   0.28,   0.28,   0.28,   0.28,   0.28, &                        !! share of the total C that is to be allocated
+  &    0.28,   0.28,   0.28,   0.28,   0.28,   0.28 /)                                !! (0-1). Value for the functional allocation 
+                                                                                      !! approach
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: gpp_to_labile_mtc = &                    !! The size of the labile pool as a fraction of the
+  &(/  1.,  3.,  1.,  1.,  3.,  1.,  3., &                                            !! weekly gpp (-). For example, 3 indicates that the 
+  &    3.,  3.,  3.,  3.,  3.,  3.  /)                                                !! labile pool is 3 times the weekly gpp.    
+
+  !
+  ! STAND STRUCTURE
+  !
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: pipe_density_mtc = &                     !! Wood density @tex $(gC.m^{-3})$ @endtex
+  &(/   0.0,   3.e5,   3.e5,   2.e5,   3.e5,   3.e5,   2.e5,  &                       !! Current values are taken from the trunk. 
+  &    3.e5,  2.e5,    2.e5,   2.e5,   2.e5,   2.e5  /)                               !! forestry-branch has more realistic values 
+                                                                                      !! in it. Source: AFOCEL 2006
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: pipe_tune1_mtc = &                       !! cn_area = pipe_tune1*...
+  &(/ undef,  100.,  100.,  100.,  100.,  100.,  100., &                              !!    stem diameter**pipe_tune_exp_coeff
+  &    100.,  100., undef, undef, undef, undef /) 
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: tree_ff_mtc = &                          !! Tree form factor to reduce
+  &(/ undef,  0.6,    0.6,   0.6,   0.6,   0.6,   0.8, &                              !! the volume of a cylinder 
+  &     0.8,  0.8,  undef, undef, undef, undef /)                                     !! to the volume of the real tree shape
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: pipe_tune2_mtc = &                       !! height=pipe_tune2 * diameter**pipe_tune3
+  &(/ undef,   55.,   55.,   55.,   55.,   55.,   55., &
+  &     55.,   55., undef, undef, undef, undef /) 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: pipe_tune3_mtc = &                       !! height=pipe_tune2 * diameter**pipe_tune3
+  &(/ undef,   0.65,   0.65,   0.65,   0.65,   0.65,  0.65, &
+  &     0.65,   0.65, undef, undef, undef, undef /)   
+      
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: pipe_tune4_mtc = &                       !! CHECK - needed for stem diameter no longer used
+  &(/ undef,   0.3,   0.3,   0.3,   0.3,   0.3,   0.3, &
+        0.3,   0.3, undef, undef, undef, undef /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: pipe_k1_mtc = &                          !! CHECK - no longer used
+  &(/ undef,  8.e3,  8.e3,  8.e3,  8.e3,  8.e3,  8.e3, &
+  &    8.e3,  8.e3, undef, undef, undef, undef /) 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: pipe_tune_exp_coeff_mtc = &              !! cn_area = pipe_tune1*...  
+  &(/ undef,   1.6,   1.6,   1.6,   1.6,   1.6,   1.6, &                              !!    stem diameter**pipe_tune_exp_coeff
+  &     1.6,   1.6, undef, undef, undef, undef /)  
+      
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: mass_ratio_heart_sap_mtc = &             !! mass ratio (heartwood+sapwood)/heartwood 
+  &(/ undef,    3.,    3.,    3.,    3.,    3.,    3., &
+  &      3.,    3., undef, undef, undef, undef /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: lai_to_height_mtc = &                    !! Convertion from lai to height for grasses
+  &(/ undef, undef, undef, undef, undef, undef, undef, &                              !! and cropland. Convert lai because that way a dynamic
+  &   undef, undef,   0.1,   0.2,   0.1,   0.2 /)                                     !! sla is accounted for
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: canopy_cover_mtc = &                     !! Prescribed canopy cover (1-gap fraction) 
+  & (/ undef,    0.9,   0.9,   0.7,   0.7,   0.7,   0.6, &                            !! of a canopy (unitless)
+  &      0.5,    0.5,   0.9,   0.9,   0.9,   0.9 /)  
+
+  INTEGER(i_std), PARAMETER, DIMENSION(nvmc) :: nmaxtrees_mtc = &                     !! Initial number of trees per ha. This parameter is 
+  & (/  10000,  10000,  10000,  10000,  10000,  10000,  2000,  &                      !! used at .firstcall. and after clearcuts
+  &      2000,   2000,  10000,  10000,  10000,  10000 /)                              !! the value is used by the allometric allocation
+                                                                                      !! and forestry subroutines.
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: height_init_min_mtc = &                  !! The minimum height (m) of a tree sapling when a forest 
+  &(/ undef,    2.,    2.,    2.,    2.,    2.,    3., &                              !! stand is established. Owing to the allometric 
+  &      3.,    3.,   0.1,   0.1,   0.1,   0.1 /)                                     !! relationship this setting determines all
+                                                                                      !! biomass components of a newly establised stand
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: height_init_max_mtc = &                  !! The maximum height (m) of a tree sapling when a forest 
+  &(/ undef,    3.,    3.,    3.,    3.,    3.,    4., &                              !! stand is established. 
+  &      4.,    4.,   0.2,   0.2,   0.2,   0.2 /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: alpha_self_thinning_mtc = &              !! Coefficient of the self-thinning relationship D=alpha*N^beta 
+  &(/ undef,  3000.,  3000.,  1462.,  2262.,  1900.,  960., &                         !! estimated from German, French, Spanish and Swedish 
+  &     939.,  1046.,  undef,  undef,  undef,  undef/)                                !! forest inventories
+ 
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: beta_self_thinning_mtc = &               !! Exponent of the self-thinning relationship D=alpha*N^beta 
+  &(/ undef,  -0.57,  -0.57,  -0.55,  -0.61,  -0.58,  -0.55, &                        !! estimated from German, French, Spanish and Swedish 
+  &    -0.56, -0.56,  undef,  undef,  undef,  undef/)                                 !! forest inventories
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: fuelwood_diameter_mtc = &                !! Diameter below which the wood harvest is used as fuelwood (m)
+  &(/ undef,   0.3,   0.3,   0.2,   0.3,   0.3,   0.2, &                              !! Affects the way the wood is used in the dim_product_use   
+  &     0.2,   0.2, undef, undef, undef, undef/)                                      !! subroutine 
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: coppice_kill_be_wood_mtc = &             !! The fraction of the belowground wood killed during coppicing.
+  &(/ undef,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0, &                              !! (unitless)
+  &     0.0,   0.0, undef, undef, undef, undef/)                                      
+                                                                                      
+  !
+  ! GROWTH
+  !
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cn_leaf_prescribed_mtc = &  !! C/N of leaves according to stich et al 2003
+  & (/ undef,  29.,  29.,  29.,  29.,  29.,  29.,  &
+  &      29.,  29.,  29.,  29.,  29.,  29.   /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: fcn_wood_mtc = &      !! C/N of "wood" for allocation relative to leaf C/N  according 
+  & (/ undef,    .087,   .087,   .087,   .087,   .087,  .087,  &   !! to stich et al 2003
+  &     .087,    .087,     1.,     1.,     1.,     1.   /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: fcn_root_mtc = &      !! C/N of "root" for allocation relative to leaf C/N  according 
+  & (/ undef,   .86,    .86,    .86,    .86,    .86,   .86,   &    !! to stich et al 2003
+  &      .86,   .86,    .86,    .86,    .86,    .86   /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: k_latosa_max_mtc = &  !! Maximum leaf-to-sapwood area ratio as defined in McDowell et al
+  & (/ undef,  5000.,  5000.,  5000.,  3000.,  5000.,  5000.,  &   !! 2002, Oecologia and compiled in Hickler et al 2006, Appendix S2 
+  &    5000.,  5000.,  0.833,  0.833,  0.833,  0.833 /)                      !! The values for grasses and crops are tuned. More work is needed
+                                                                   !! to fully justify this approach for the herbacuous PFTs (unitless)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: k_latosa_min_mtc = &  !! Minimum leaf-to-sapwood area ratio as defined in McDowell et al
+  & (/ undef,  5000.,  5000.,  5000.,  3000.,  5000.,  5000.,  &   !! 2002, Oecologia and compiled in Hickler et al 2006, Appendix S2 
+  &    5000.,  5000.,  0.833,  0.833,  0.833,  0.833  /)           !! The values for grasses and crops are tuned. More work is needed
+                                                                   !! to fully justify this approach for the herbacuous PFTs (unitless)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: fruit_alloc_mtc = &   !! Fraction of biomass allocated to fruit production (0-1)
+  & (/ undef,   0.1,    0.1,    0.1,     0.1,     0.1,    0.1, &   !! currently only parameterized for forest PFTs 
+  &      0.1,   0.1,     0.,     0.,      0.,      0. /)  
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: lai_max_to_happy_mtc = & !! Multiplicative factor of lai_max that determines
+  & (/ undef,   0.5,    0.5,    0.5,     0.5,     0.4,    0.5, &   !! the threshold value of LAI below which the carbohydrate
+  &      0.36,   0.35,     0.35,     0.5,      0.5,      0.5 /)    !! reserve is used 
+ 
+  !
+  ! HYDRAULIC ARCHITECTURE
+  ! 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: k_root_mtc = &        !! Fine root specific conductivity. Values compiled in T. Hickler     
+  & (/ undef,    4.,    4.,   4.,   4.,   4.,   4.,       &        !! et al. 2006. @tex $(m^{3} kg^{-1} s^{-1} MPa^{-1})$ @endtex    
+  &       4.,    4.,   50.,  50.,  50.,  50.   /)*1.e-7         
+                                                                       
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: k_sap_mtc = &         !! Maximal sapwood specific conductivity. Values compiled in T. Hickler 
+  & (/ undef,   50.,   10.,    8.,    5.,   30.,    8.,    &       !! et al. 2006. @tex $(m^{2} s^{-1} MPa^{-1})$ @endtex 
+  &      20.,    8., undef, undef, undef, undef    /)*1.e-4 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: k_leaf_mtc = &        !! Leaf conductivity. Values compiled in T. Hickler et al 2006
+  & (/ undef,  1.5,  1.5,  1.5,  1.5,  1.5,  1.5,         &        !! @tex $(m s^{-1} MPa^{-1})$ @endtex
+         1.5,  1.5,  1.5,  1.5,  1.5,  1.5         /)*1.e-7
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: phi_leaf_mtc = &      !! Minimal leaf water potential. Values in T. Hickler et al 2006
+  & (/ undef, -2.2, -2.2, -2.2, -3.5, -2.2, -2.2,   &              !! @tex $(MPa)$ @endtex
+        -2.2, -2.2, -2.2, -2.2, -2.2, -2.2        /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: phi_50_mtc = &        !! Sapwood leaf water potential that causes 50% loss of xylem
+  & (/ undef, -0.3, -1.3, -2.0, -1.7, -1.0, -2.0, &                !! conductivity through cavitation. @tex $(MPa)$ @endtex
+        -1.0, -2.0, undef, undef, undef, undef /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: c_cavitation_mtc = &  !! Shape parameter for loss of conductance Machado & Tyree, 1994
+  & (/ undef,  5.,  3.,  3.,  3.,  3.,  3.,  &                     !! (unitless)
+          3.,  3., undef, undef, undef, undef /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: phi_soil_tune_mtc = & !! Additive tuning parameter to account for soil-root interactions
+  & (/ undef,  0.,  0.,  0.,  0.,  0.,  0.,  &                     !! @tex $(MPa)$ @endtex
+          0.,  0.,  0.,  0.,  0.,  0. /)                                  
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: lai_happy_mtc = &     !! Lai threshold below which carbohydrate
+  & (/ undef,  1.,  1.,  1.,  1.,  1.,  1.,  &                     !! reserve may be used in functional allocation.
+          1.,  1.,  1.,  1.,  1.,  1. /)                           !! Also used in phenology to see if mixed classes
+                                                                   !! should die.  These seem completely arbitrary.
+                                                                   !! @tex $(m^2.m^{-2})$ @endtex
+
+  ! -------------------------------------------------------------------------------------------------------
+  ! tzjh parameter for the new hydraulic architecture -- all set up for PFT2 now
+  ! -------------------------------------------------------------------------------------------------------
+ 
+  ! Stomatal conductance parameters
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: gpsi_mtc = &        !! ! gs vs psi_leaf curve parameter     
+  & (/ undef,   -2.0,    -2.0,   -2.0,  -2.0,   -2.0,   -2.0,       & !!     
+  &       -2.0,    -2.0,   -2.0,  -2.0,  -2.0,  -2.0   /)
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: gpsi_50_mtc = &        !! ! psi_leaf at 50% stomatal closure, -MPa     
+  & (/ undef,   1.5,    1.5,   1.5,  1.5,   1.5,   1.5,       & !!     
+  &       1.5,    1.5,   1.5,  1.5,  1.5,  1.5   /)
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: gmax_mtc = &        !! maximum stomatal conductance     
+  & (/ undef,   500.,    500.,   500.,   500.,   500.,   500.,       & !! @tex $mmol m^{-2}s^{-1}$ @endtex    
+  &       500.,    500.,   500.,  500.,  500.,  500.   /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: gmin_mtc = &        !! minimum (cuticular) conductance     
+  & (/ undef,   10.,    10.,   10.,   10.,   10.,   10.,       & !! @tex $mmol m^{-2}s^{-1}$ @endtex    
+  &       10.,    10.,   10.,  10.,  10.,  10.   /)
+ 
+  ! Hydraulic conductivity parameters
+ 
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: kmax_leaf_mtc = &    !! maximum hydraulic conductivity of leaf     
+  & (/ undef,   20.,    20.,   20.,   20.,   20.,   20.,       &   !! @tex $mmol m^{-2}s^{-1} MPa^{-1}$ @endtex    
+  &       10.,    10.,   10.,  10.,  10.,  10.   /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: kmax_stem_mtc = &    !! maximum hydraulic conductivity of stem     
+  & (/ undef,   10.,    10.,   10.,   10.,   10.,   10.,       &   !! @tex $mmol m^{-2}s^{-1} MPa^{-1}$ @endtex    
+  &       10.,    10.,   10.,  10.,  10.,  10.   /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: kmax_root_mtc = &    !! maximum hydraulic conductivity of root     
+  & (/ undef,   10.,    10.,   10.,   10.,   10.,   10.,       &   !! @tex $mmol m^{-2}s^{-1} MPa^{-1}$ @endtex    
+  &       10.,    10.,   10.,  10.,  10.,  10.   /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: a_leaf_mtc = &        !! kleaf vs. psi_leaf curve parameter    
+  & (/ undef,   -1.2,    -1.2,   -1.2,  -1.2,   -1.2,   -1.2,       & !!     
+  &       -1.2,    -1.2,   -1.2,  -1.2,  -1.2,  -1.2   /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: a_stem_mtc = &        !! kstem vs. psi_stem curve parameter    
+  & (/ undef,   -1.2,    -1.2,   -1.2,  -1.2,   -1.2,   -1.2,       & !!     
+  &       -1.2,    -1.2,   -1.2,  -1.2,  -1.2,  -1.2   /)
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: a_root_mtc = &        !! kroot vs. psi_root curve parameter    
+  & (/ undef,   -1.2,    -1.2,   -1.2,  -1.2,   -1.2,   -1.2,       & !!     
+  &       -1.2,    -1.2,   -1.2,  -1.2,  -1.2,  -1.2   /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: P50_leaf_mtc = &      !! psi_leaf at 50% loss of leaf hydraulic conductivity, MPa
+  & (/ undef,   2.0,    2.0,   2.0,  2.0,   2.0,   2.0,       & !!     
+  &       2.0,    2.0,   2.0,  2.0,  2.0,  2.0   /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: P50_stem_mtc = &      !! psi_stem at 50% loss of leaf hydraulic conductivity, MPa
+  & (/ undef,   2.5,    2.5,   2.5,  2.5,   2.5,   2.5,       & !!     
+  &       2.5,    2.5,   2.5,  2.5,  2.5,  2.5   /)
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: P50_root_mtc = &      !! psi_root at 50% loss of leaf hydraulic conductivity, MPa
+  & (/ undef,   2.0,    2.0,   2.0,  2.0,   2.0,   2.0,       & !!     
+  &       2.0,    2.0,   2.0,  2.0,  2.0,  2.0   /)
+
+  ! Water storage parameters 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: wood_density_mtc = &      !! g of stem dry mass per m3 of stem volume Averaged across all Neotropical species
+  & (/ undef,   645000.0,    645000.0,   645000.0,  645000.0,   645000.0,   645000.0,      &     !! from Chave et al. 2006 Ecological Applications
+  &       645000.0,    645000.0,   645000.0,  645000.0,  645000.0,  645000.0   /)                !! in the code pipe_density, not the same values
+                                                                   !!  (create a new variable for now to don't change the allocation)   
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: w_density_stem_mtc = &    !! mmol H2O per m3 of stem volume values averaged from a Bornean tropical forest, 
+  & (/ undef,  25000000.0,   25000000.0,   25000000.0,  25000000.0,   25000000.0,  25000000.0, & !! from Suzuki et al. 1999 Ecological Research
+  & 25000000.0, 25000000.0,  25000000.0, 25000000.0,  25000000.0,  25000000.0 /)             !!       
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: root_shoot_ratio_mtc = &   !! ratio of root mass to shoot mass, g g-1 values are averaged for wet and
+  & (/ undef,   0.25,   0.25 ,  0.25 , 0.25 ,  0.25 ,  0.25 ,       & !!      dry tropical forests from Mokany et al. 2005 Global Change Biology
+  &      0.25 ,   0.25 ,  0.25 ,  0.25,  0.25, 0.25     /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: rwc_root_mtc = &   !! mmol H2O per g of dry root mass
+  & (/ undef,   35.0,  35.0  ,   35.0,  35.0,   35.0,   35.0,       & !!      dry tropical forests from Mokany et al. 2005 Global Change Biology
+  &      35.0 ,    35.0,   35.0,  35.0,  35.0, 35.0    /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: root_density_mtc = &   !! wood density of the roots, g dry mass cm-3 volume
+  & (/ undef,   0.502,  0.502  ,   0.502,  0.502,   0.502,   0.502,       & !!    
+  &      0.502 ,    0.502,   0.502,  0.502,  0.502, 0.502    /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: LDMC_mtc = &   !! leaf dry matter content (g dry mass g-1 fresh mass), currently the global mean in the TRY
+  & (/ undef,   0.2,    0.2,   0.2,  0.2,   0.2,   0.2,       & !!      database but should be replaced with the mean across tropical species (Kattge et al. 2011 Global Change Biology)
+  &       0.2,    0.2,   0.2,  0.2,  0.2,  0.2   /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: sla_hydro_mtc = &    !! sla (m2 kg-1), currenly the global mean in the TRY     
+  & (/ undef,   16.6,    16.6,   16.6,   16.6,   16.6,   16.6,     &   !! database but should be replaced with the mean across tropical species (Kattge et    
+  &       16.6,    16.6,   16.6,  16.6,  16.6,  16.6   /)               !! al. 2011 Global Change Biology)   idem, sla dalready in the code, to change ?  
+
+  ! Capacitance parameters
+ 
+!  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cxyl_mtc = &    !! stem capacitance, kg m^-3 MPa-1     
+! & (/ undef,   0,    0,   0,   0,   0,   0,     &   !!    
+!  &       0,    0,   0,  0,  0,  0   /)               !!  
+
+! REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cr_mtc = &    !! root capacitance, kg m^-3 MPa-1     
+!  & (/ undef,   0,    0,   0,   0,   0,   0,     &   !!    
+!  &       0,    0,   0,  0,  0,  0   /)               !!  
+
+! REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cl_mtc = &    !! leaf capacitance, mmol m^2 MPa-1     
+!  & (/ undef,   0,    0,   0,   0,   0,   0,     &   !!    
+!  &       0,    0,   0,  0,  0,  0   /)               !!  
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cxyl_mtc = &    !! stem capacitance, kg m^-3 MPa-1     
+  & (/ undef,   124.0,    124.0,   124.0,   124.0,   124.0,   124.0,     &   !!    
+  &       124.0,    124.0,   124.0,  124.0,  124.0,  124.0   /)               !!  
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cr_mtc = &    !! root capacitance, kg m^-3 MPa-1     
+  & (/ undef,   150.0,    150.0,   150.0,   150.0,   150.0,   150.0,     &   !!    
+  &       150.0,    150.0,   150.0,  150.0,  150.0,  150.0   /)               !!  
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: cl_mtc = &    !! leaf capacitance, mmol m^2 MPa-1     
+  & (/ undef,   750.0,    670.0,   670.0,   670.0,   670.0,   670.0,     &   !!    
+  &       670.0,    670.0,   670.0,  670.0,  670.0,  670.0   /)               !!  
+  !
+  ! MORTALITY (stomate)
+  !
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: death_distribution_factor_mtc = &    !!  The scale factor between the smallest and largest
+       (/ undef,  100.,  100.,  100.,  100.,  100.,  100.,  &                     !! circ class for tree mortality in stomate_mark_kill.
+            100.,  100., undef, undef, undef, undef /)                            !! (unitless)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: npp_reset_value_mtc = &  !! The value of the NPP that the long-term value is
+       (/ undef,  undef,  undef,  undef,  undef,  undef,  undef,  &   !! reset to after a PFT dies in stomate_kill.  This
+          undef,  undef,   500.,   500.,   500.,   500. /)            !! only seems to be used for non-trees.
+                                                                      !! @tex $(gC m^{-2})$ @endtex
+
+  
+  !
+  ! FIRE (stomate)
+  !
+  REAL(r_std),PARAMETER, DIMENSION(nvmc) :: flam_mtc  =  &         !! flamability: critical fraction of water 
+  & (/  undef,   0.15,   0.25,   0.25,   0.25,   0.25,   0.25,  &  !! holding capacity (0-1, unitless)
+  &      0.25,   0.25,   0.25,   0.25,   0.35,   0.35  /)
+
+  REAL(r_std),PARAMETER, DIMENSION(nvmc) :: resist_mtc  =  &       !! fire resistance (0-1, unitless)
+  & (/ undef,   0.95,   0.90,   0.12,   0.50,   0.12,   0.12,  &
+  &    0.12,    0.12,    0.0,    0.0,    0.0,    0.0 /) 
+
+
+  !
+  ! FLUX - LUC
+  !
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: coeff_lcchange_s_mtc  =  &   !! Coeff of biomass export for the year
+  & (/  undef,   0.897,   0.897,   0.597,   0.597,   0.597,   0.597,  &   !! (0-1, unitless)
+  &     0.597,   0.597,   0.597,   0.597,   0.597,   0.597  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: coeff_lcchange_m_mtc  =  &  !! Coeff of biomass export for the decade 
+  & (/  undef,   0.103,   0.103,   0.299,   0.299,   0.299,   0.299,  &   !! (0-1, unitless)
+  &     0.299,   0.299,   0.299,   0.403,   0.299,   0.403  /) 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: coeff_lcchange_l_mtc  =  & !! Coeff of biomass export for the century
+  & (/  undef,     0.0,     0.0,   0.104,   0.104,   0.104,   0.104,  &   !! (0-1, unitless)
+  &     0.104,   0.104,   0.104,     0.0,   0.104,     0.0  /)
+
+
+  !
+  ! PHENOLOGY
+  !
+  !-
+  ! 1. Stomate
+  !-
+  REAL(r_std), PARAMETER, DIMENSION (nvmc) :: lai_max_mtc  =  &          !! maximum LAI, PFT-specific 
+  & (/ undef,   7.0,   7.0,   5.0,   5.0,   5.0,   4.5,  &               !! @tex $(m^2.m^{-2})$ @endtex
+  &      4.5,   3.0,   2.5,   2.5,   5.0,   5.0  /)
+
+  INTEGER(i_std), PARAMETER, DIMENSION(nvmc) :: pheno_type_mtc  =  &     !! type of phenology (0-4, unitless)
+  & (/  0,   1,   3,   1,   1,   2,   1,  &                              !! 0=bare ground 1=evergreen,  2=summergreen, 
+  &     2,   2,   4,   4,   2,   3  /)                                   !! 3=raingreen,  4=perennial
+  !-
+  ! 2. Leaf Onset
+  !-
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: pheno_gdd_crit_c_mtc  =  &    !! critical gdd, tabulated (C),
+  & (/  undef,   undef,   undef,   undef,   undef,   undef,   undef,  &    !! constant c of aT^2+bT+c
+  &     undef,   undef,   320.0,   400.0,   450.0,   550.0  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: pheno_gdd_crit_b_mtc  =  &    !! critical gdd, tabulated (C),
+  & (/  undef,   undef,   undef,   undef,   undef,   undef,   undef,  &    !! constant b of aT^2+bT+c
+  &     undef,   undef,    6.25,     0.0,    6.25,     0.0  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: pheno_gdd_crit_a_mtc  =  &    !! critical gdd, tabulated (C),
+  & (/  undef,   undef,     undef,   undef,   undef,   undef,   undef,  &  !! constant a of aT^2+bT+c
+  &     undef,   undef,   0.03125,     0.0,  0.0315,   0.0  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: ngd_crit_mtc  =  &            !! critical cumulated ngd, tabulated. 
+  & (/  undef,   undef,   undef,   undef,   undef,   undef,   undef,  &    !! Threshold -5 degrees (C)
+  &     undef,    17.0,   undef,   undef,   undef,   undef  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: opti_kpheno_crit_mtc  =  &   !! multiplicative factor to use optimized 
+  & (/  undef,   1.,   1.,   1.,   1.,   1.13,   1.,  &                   !! gdd_crit (N. MacBean)
+  &     0.87,    1.08,   0.81,   1.,   1.,   1.  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: ncdgdd_temp_mtc  =  &         !! critical temperature for the ncd vs. gdd 
+  & (/  undef,   undef,   undef,   undef,   undef,     5.0,   undef,  &    !! function in phenology (C)
+  &       0.0,     0.0,   undef,   undef,   undef,   undef  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: hum_frac_mtc  =  &            !! critical humidity (relative to min/max) 
+  & (/  undef,   undef,   0.5,   undef,   undef,   undef,   undef, &       !! for phenology (unitless)
+  &     undef,   undef,   0.5,     0.5,     0.5,     0.5  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: hum_min_time_mtc  =  &        !! minimum time elapsed since
+  & (/  undef,   undef,   50.0,   undef,   undef,   undef,   undef,  &     !! moisture minimum (days)
+  &     undef,   undef,   58.71,    35.0,    75.0,    75.0  /) 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: tau_sap_mtc  =  &             !! Sapwood longivety (days)  
+  & (/  undef,   730.,   730.,   730.,   730.,   730.,   730.,  &
+  &      730.,   730.,  undef,  undef,  undef,  undef  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: tau_fruit_mtc  =  &           !! fruit longivety (days)
+  & (/  undef,   90.,   90.,    90.,     90.,   90.,   90.,  &
+  &       90.,   90., undef,  undef,   undef,   undef  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: tau_root_mtc  =  &            !! roots longevity (days)
+  & (/  undef,  365.,   365.,    365.,    365.,   365.,   365.,  &
+  &      365.,  365.,   365.,    365.,    365.,   365.  /)/7
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: tau_leaf_mtc  =  &            !! leaf longevity (days)
+  & (/  undef,   730.,   180.,    910.,   730.,   160.62,   910.,  &
+  &      240.,   89.57,   89.57,    120.,    90.,    90.  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: ecureuil_mtc  =  &            !! fraction of primary leaf and root allocation
+  & (/  undef,   0.0,   1.0,   0.0,   0.0,   1.0,   0.0,  &                !! put into reserve (0-1, unitless)
+  &       1.0,   1.0,   1.0,   1.0,   1.0,   1.0  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: alloc_min_mtc  =  &           !! NEW - allocation above/below = f(age) 
+  & (/  undef,   0.2,     0.2,     0.2,     0.2,    0.2,   0.2,  &         !! - 30/01/04 NV/JO/PF
+  &       0.2,   0.2,   undef,   undef,   undef,   undef  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: alloc_max_mtc  =  &           !! NEW - allocation above/below = f(age) 
+  & (/  undef,   0.8,     0.8,     0.8,     0.8,    0.8,   0.8,  &         !! - 30/01/04 NV/JO/PF
+  &       0.8,   0.8,   undef,   undef,   undef,   undef  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: demi_alloc_mtc  =  &          !! NEW - allocation above/below = f(age) 
+  & (/  undef,   5.0,     5.0,     5.0,     5.0,    5.0,   5.0,  &         !! - 30/01/04 NV/JO/PF
+  &       5.0,   5.0,   undef,   undef,   undef,   undef  /)
+
+  !-
+  ! 3. Senescence
+  !-
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: leaffall_mtc  =  &             !! length of death of leaves, tabulated (days)
+  & (/  undef,   undef,   10.0,   undef,   undef,   29.48,   undef,  &
+  &      4.71,    9.41,   10.0,    10.0,    10.0,   10.0  /)
+
+  CHARACTER(LEN=6), PARAMETER, DIMENSION(nvmc) :: senescence_type_mtc  =  & !! type of senescence, tabulated (unitless)
+  & (/  'none  ',  'none  ',   'dry   ',  'none  ',  'none  ',  &
+  &     'cold  ',  'none  ',   'cold  ',  'cold  ',  'mixed ',  &
+  &     'mixed ',  'crop  ',   'crop  '            /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: senescence_hum_mtc  =  &       !! critical relative moisture availability
+  & (/  undef,   undef,   0.3,   undef,   undef,   undef,   undef,  &       !! for senescence (0-1, unitless)
+  &     undef,   undef,   0.2,     0.2,     0.3,     0.2  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: nosenescence_hum_mtc  =  &     !! relative moisture availability above which 
+  & (/  undef,   undef,   0.8,   undef,   undef,   undef,   undef,  &       !! there is no humidity-related senescence
+  &     undef,   undef,   0.63,     0.3,     0.3,     0.3  /)                !! (0-1, unitless)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: max_turnover_time_mtc  =  &    !! maximum turnover time for grasses (days)
+  & (/  undef,   undef,   undef,   undef,   undef,   undef,   undef,  &
+  &     undef,   undef,    80.0,    80.0,    80.0,    80.0  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: min_turnover_time_mtc  =  &    !! minimum turnover time for grasses (days)
+  & (/  undef,   undef,   undef,   undef,   undef,   undef,   undef,  &
+  &     undef,   undef,    10.0,    10.0,    10.0,    10.0  /)
+ 
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: min_leaf_age_for_senescence_mtc  =  &  !! minimum leaf age to allow 
+  & (/  undef,   undef,   90.0,   undef,   undef,   90.0,   undef,  &               !! senescence g (days)
+  &      60.0,    60.0,   30.0,    30.0,    30.0,   30.0  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: senescence_temp_c_mtc  =  &    !! critical temperature for senescence (C)
+  & (/  undef,   undef,    undef,   undef,   undef,   16.57,   undef,  &     !! constant c of aT^2+bT+c, tabulated
+  &       14.61,    12.0,   9.38,     5.0,    13.0,    10.0  /)              !! (unitless)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: senescence_temp_b_mtc  =  &    !! critical temperature for senescence (C), 
+  & (/  undef,   undef,   undef,   undef,   undef,   0.0,   undef,  &       !! constant b of aT^2+bT+c, tabulated
+  &       0.0,     0.0,     0.1,     0.0,     0.0,   0.0  /)                !! (unitless)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: senescence_temp_a_mtc  =  &    !! critical temperature for senescence (C), 
+  & (/  undef,   undef,     undef,   undef,   undef,   0.0,   undef,  &     !! constant a of aT^2+bT+c, tabulated
+  &       0.0,     0.0,   0.00375,     0.0,     0.0,   0.0  /)              !! (unitless)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: gdd_senescence_mtc  =  &       !! minimum gdd to allow senescence of crops (days)
+  & (/  undef,   undef,    undef,   undef,     undef,    undef,    undef,  &
+  &     undef,   undef,    undef,   undef,     1500.,    1500.  /)
+
+
+  !
+  ! DGVM
+  !
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: residence_time_mtc  =  &    !! residence time of trees (years). NOTE: the meaning of  
+  & (/  undef,   30.0,   30.0,   40.0,   40.0,   40.0,   80.0,  &        !! ::residence_time is very different between the DOFOCO
+  &      80.0,   80.0,    0.0,    0.0,    0.0,    0.0  /)                !! branch and the trunk. In the trunk biomass has no age
+                                                                         !! thus the residence time accounts for all forest dynamics 
+                                                                         !! including self-thinning, pests, diseases and wind fall. 
+                                                                         !! In the DOFOCO branch biomass has an age and 
+                                                                         !! self-thinning is explicitly accounted for. Hence, the 
+                                                                         !! residence time should be much higher as it only accounts 
+                                                                         !! for mortality due to pest, diseases and windfall. Even the 
+                                                                         !! latter is not exact because as long as those disturbances 
+                                                                         !! are small scale they are probably accounted for in the       ! added by yitong yao 07 Jan 2020 08:43                                !! parametrization of self-thinning.
+  REAL(r_std), PARAMETER, DIMENSION(nvmc)  :: plc_kill_frac_mtc  =  &
+  & (/  undef,   0.01,   0.01,   0.01,   0.01,   0.01,   0.01,  & 
+  &     0.01,    0.01,   0.0,    0.0,   0.0,   0.0   /)
+  ! added by yitong yao 07 Jan 2020 08:44 above line   
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc)  :: mor_kill_frac_mtc  =  &
+  & (/  undef,   0.001,   0.01,   0.01,   0.01,   0.01,   0.01,  &
+  &     0.01,    0.01,   0.0,    0.0,   0.0,   0.0   /)
+
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: tmin_crit_mtc  =  &
+  & (/  undef,     0.0,     0.0,   -30.0,   -14.0,   -30.0,   -45.0,  &  !! critical tmin, tabulated (C)
+  &     -45.0,   undef,   undef,   undef,   undef,   undef  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: tcm_crit_mtc  =  &
+  & (/  undef,   undef,   undef,     5.0,    15.5,    15.5,   -8.0,  &   !! critical tcm, tabulated (C)
+  &      -8.0,    -8.0,   undef,   undef,   undef,   undef  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: mortality_min_mtc = &       !! Asymptotic mortality if plant growth exceeds long term
+  & (/  undef,  0.01,  0.01,  0.01,  0.01,  0.01,  0.01,  &               !! NPP (thus a strongly growing PFT)
+  &      0.01,  0.01,  0.01,  0.01,  0.01,  0.01  /)                      !! @tex $(year^{-1})$ @endtex
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: mortality_max_mtc = &       !! Maximum mortality if plants hardly grows thus 
+  & (/  undef,  0.1,  0.1,  0.1,  0.1,  0.1,  0.1,  &                      !! NPP << NPPlongterm @tex $(year^{-1})$ @endtex
+  &       0.1,  0.1,  0.1,  0.1,  0.1,  0.1  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: ref_mortality_mtc = &       !! Reference mortality rate used to calculate mortality
+  & (/  undef,  0.035,  0.035,  0.035,  0.035,  0.035,  0.035,  &        !! as a function of the plant vigor 
+  &     0.035,  0.035,  0.035,  0.035,  0.035,  0.035  /)                !! @tex $(year^{-1})$ @endtex
+
+
+
+  !
+  ! Biogenic Volatile Organic Compounds
+  !
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: em_factor_isoprene_mtc = &     !! Isoprene emission factor 
+  & (/  0.,    24.,   24.,    8.,   16.,   45.,   8.,  &                    !!
+  &     8.,     8.,   16.,   24.,    5.,    5.  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: em_factor_monoterpene_mtc = &  !! Monoterpene emission factor
+  & (/   0.,   0.8,    0.8,   2.4,    1.2,    0.8,    2.4,  &               !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+  &    2.4,    2.4,    0.8,   1.2,    0.2,     0.2  /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: em_factor_ORVOC_mtc = &        !! ORVOC emissions factor 
+  &  (/  0.,    1.5,    1.5,    1.5,    1.5,   1.5,    1.5,  &              !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+  &     1.5,    1.5,    1.5,    1.5,    1.5,   1.5  /) 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: em_factor_OVOC_mtc = &         !! OVOC emissions factor 
+  &  (/  0.,    1.5,    1.5,    1.5,    1.5,   1.5,    1.5,  &              !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+  &     1.5,    1.5,    1.5,    1.5,    1.5,   1.5  /)
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: em_factor_MBO_mtc = &          !! MBO emissions factor
+  & (/  0.,    0.,    0.,    20.0,    0.,    0.,    0.,  &                  !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+  &     0.,    0.,    0.,       0.,   0.,    0.  /)  
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: em_factor_methanol_mtc = &     !! Methanol emissions factor 
+  & (/  0.,    0.6,   0.6,   1.8,   0.9,   0.6,   1.8,  &                   !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+  &    1.8,    1.8,   0.6,   0.9,    2.,     2.  /)  
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: em_factor_acetone_mtc = &      !! Acetone emissions factor
+  & (/  0.,   0.29,   0.29,   0.87,   0.43,   0.29,   0.87,  &              !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+  &   0.87,   0.87,   0.29,   0.43,   0.07,   0.07  /)
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: em_factor_acetal_mtc = &       !! Acetaldehyde emissions factor 
+  & (/  0.,   0.1,    0.1,     0.3,    0.15,   0.1,   0.3,   0.3,   &       !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+  &    0.3,   0.1,   0.15,   0.025,   0.025  /)  
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: em_factor_formal_mtc = &       !! Formaldehyde emissions factor
+  & (/  0.,   0.07,   0.07,   0.2,     0.1,    0.07,   0.2,  &              !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+  &    0.2,    0.2,   0.07,   0.1,   0.017,   0.017  /)  
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: em_factor_acetic_mtc = &       !! Acetic Acid emissions factor
+  & (/   0.,   0.002,   0.002,   0.006,   0.003,     0.002,   0.006,   &    !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+  &   0.006,   0.006,   0.002,   0.003,   0.0005,   0.0005  /)  
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: em_factor_formic_mtc = &       !! Formic Acid emissions factor
+  & (/  0.,   0.01,   0.01,   0.03,     0.015,     0.01,   0.03,  &         !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+  &   0.03,   0.03,   0.01,   0.015,   0.0025,   0.0025  /)  
+
+  REAL(r_std),PARAMETER, DIMENSION(nvmc) :: em_factor_no_wet_mtc = &        !! NOx emissions factor soil emissions and exponential
+  & (/  0.,   2.6,   0.06,   0.03,   0.03,   0.03,   0.03,  &               !! dependancy factor for wet soils
+  &  0.03,   0.03,   0.36,   0.36,   0.36,   0.36  /)                       !! @tex $(ngN.m^{-2}.s^{-1})$ @endtex
+
+  REAL(r_std),PARAMETER, DIMENSION(nvmc) :: em_factor_no_dry_mtc = &        !! NOx emissions factor soil emissions and exponential
+  & (/  0.,   8.60,   0.40,   0.22,   0.22,   0.22,   0.22,  &              !! dependancy factor for dry soils
+  &   0.22,   0.22,   2.65,   2.65,   2.65,   2.65  /)                      !! @tex $(ngN.m^{-2}.s^{-1})$ @endtex 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: Larch_mtc = &                  !! Larcher 1991 SAI/LAI ratio (unitless)
+  & (/   0.,   0.015,   0.015,   0.003,   0.005,   0.005,   0.003,  &
+  &   0.005,   0.003,   0.005,   0.005,   0.008,   0.008  /)  
+
+  !
+  ! Forest Management
+  !
+
+!!$  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: fm_allo_a_mtc = &
+!!$  & (/ undef,   19.42,   19.42,     9.3,   19.42,   19.42,   9.3,  &        
+!!$  &    19.42,     9.3,   undef,   undef,   undef,   undef   /)   
+!!$    
+!!$  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: fm_allo_c_mtc = &
+!!$  & (/ undef,    0.11,   0.11,     0.35,   0.11,    0.11,   0.35,  &        
+!!$  &    0.11,     0.35,   undef,   undef,   undef,   undef   /)     
+!!$  
+!!$  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: fm_allo_d_mtc = &
+!!$  & (/ undef,    0.13,   0.13,     0.3,   0.13,    0.13,   0.3,  &        
+!!$  &    0.13,     0.3,   undef,   undef,   undef,   undef   /)     
+!!$  
+!!$  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: fm_allo_p_mtc = &
+!!$  & (/ undef,    0.75,   0.75,     0.69,   0.75,    0.75,   0.69,  &        
+!!$  &    0.75,     0.69,   undef,   undef,   undef,   undef   /) 
+!!$      
+!!$  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: fm_allo_q_mtc = &
+!!$  & (/ undef,    -0.12,   -0.12,     -0.32,   -0.12,    -0.12,   -0.32,  &        
+!!$  &    -0.12,    -0.32,    undef,    undef,   undef,    undef   /)
+!!$       
+!!$  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: allo_crown_a0_mtc = &
+!!$  & (/   undef,   -0.7602,   -0.7602,     -1.019,   -0.7602,   -0.7602,   -1.019,  &        
+!!$  &    -0.7602,    -1.019,     undef,      undef,     undef,      undef   /) 
+!!$  
+!!$  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: allo_crown_a1_mtc = &
+!!$  & (/   undef,   0.6672,   0.6672,     0.887,   0.6672,   0.6672,   0.887,  &        
+!!$  &    0.6672,     0.887,     undef,      undef,     undef,      undef   /)   
+!!$
+!!$  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: allo_crown_a2_mtc = &
+!!$  & (/   undef,   0.12646,   0.12646,     0.188,   0.12646,   0.12646,   0.188,  &        
+!!$  &    0.12646,     0.188,     undef,      undef,     undef,      undef   /)   
+!!$
+!!$  LOGICAL, PARAMETER, DIMENSION(nvmc) :: plantation_mtc = & 
+!!$  & (/  .FALSE.,  .FALSE.,  .FALSE.,  .FALSE.,  .FALSE.,  .FALSE.,  .FALSE.,  &
+!!$  &     .FALSE.,  .FALSE.,  .FALSE.,  .FALSE.,  .FALSE.,  .FALSE.  /)
+!!$
+!!$  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: decl_factor_mtc = &
+!!$  & (/     0.0,   0.0005,   0.0005,   0.0007,   0.0005,   0.0005,   0.0009, & 
+!!$  &    0.00075,   0.0005,      1.0,      1.0,      1.0,      1.0 /)    
+!!$
+!!$  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: opt_factor_mtc = & 
+!!$  & (/  1.0,  1.0,  1.0,  1.0,  1.0,  1.0,  1.0,  &
+!!$  &     1.0,  1.0,  1.0,  1.0,  1.0,  1.0  /)
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: h_first_mtc = &                            !! Height at which thinning will start (m)            
+  & (/   0.0,   10.0,   10.0,   10.0,   10.0,   10.0,  10.0,   &
+  &     10.0,   10.0,    0.0,    0.0,    0.0,    0.0   /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: dens_target_mtc =  &                       !! Minimal density. Below this density the forest
+  & (/   0.0,   100.0,   100.0,   200.0,   100.0,   100.0,   200.0,  &                  !! will be clearcut (trees.ha-1)
+  &    100.0,   200.0,     0.0,     0.0,     0.0,     0.0   /) 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: thinstrat_mtc =  &                         !! Thinning strategy. The FM code distinguished
+  & (/   0.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,  &                              !! thinning from above (<0) or from below (>0).  
+  &    1.0,   1.0,     0.0,     0.0,     0.0,     0.0   /)                              
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: taumin_mtc =  &                            !! Minimum probability that a tree get thinned (unitless)
+  & (/   0.0,   0.01,   0.01,   0.01,   0.01,   0.01,   0.01,  &
+  &    0.01,   0.01,     0.0,     0.0,     0.0,     0.0   /) 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: taumax_mtc =  &                            !! Maximum probability that a tree get thinned (unitless)
+  & (/   0.0,   0.05,   0.05,   0.05,   0.05,   0.05,   0.05,  &
+  &    0.05,   0.05,     0.0,     0.0,     0.0,     0.0   /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: alpha_rdi_upper_mtc = &                    !! Coefficient of the yield-table derived thinning relationship 
+  &(/ undef,  3000.,  3000.,  592.,  862.,  504.,  1287., &                             !! D=alpha*N^beta estimated from JRC yield table database 
+  &    984.,   589.,  undef,  undef,  undef,  undef/)                                  
+ 
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: beta_rdi_upper_mtc = &                     !! Coefficient of the yield-table derived thinning relationship 
+  &(/ undef,  -0.57,  -0.57,  -0.46,  -0.51,  -0.44,  -0.59, &                          !! D=alpha*N^beta estimated from JRC yield table database 
+  &   -0.57,  -0.48,  undef,  undef,  undef,  undef/)                                   
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: alpha_rdi_lower_mtc = &                    !! Coefficient of the yield-table derived thinning relationship 
+  &(/ undef,  2999.,  2999.,  433.,  445.,  369.,  1022., &                             !! D=alpha*N^beta estimated from JRC yield table database 
+  &    828.,   385.,  undef,  undef,  undef,  undef/)                                  
+ 
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: beta_rdi_lower_mtc = &                     !! Coefficient of the yield-table derived thinning relationship 
+  &(/ undef,  -0.57,  -0.57,  -0.46,  -0.51,  -0.44,  -0.59, &                          !! D=alpha*N^beta estimated from JRC yield table database 
+  &   -0.57,  -0.48,  undef,  undef,  undef,  undef/) 
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: largest_tree_dia_mtc =  &                  !! Maximal tree diameter (m). If this diameter is exceeded a
+  & (/   0.0,   .45,   .45,   .45,   .45,   .45,   .45,  &                              !! a clearcut will happen.
+  &   .45,    .45,     0.0,     0.0,     0.0,     0.0   /) 
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: branch_ratio_mtc =  &                      !! Ratio of branches to total woody biomass (unitless)
+  & (/  0.0,   0.38,   0.38,   0.25,   0.38,   0.38,   0.25,  &
+  &    0.38,   0.25,    0.0,    0.0,    0.0,    0.0 /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: branch_harvest_mtc =  &                    !! Ratio of branches harvested in FM2 management.
+  & (/  0.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,  &
+  &    1.0,   1.0,    0.0,    0.0,    0.0,    0.0 /)
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: m_dv_mtc = &                               !! Parameter in the Deleuze & Dhote allocation 
+  & (/ undef,  1.05,  1.05,  1.05,  1.05,  1.05,  1.05, &                               !! rule that relaxes the cut-off imposed by
+  &     1.05,  1.05,    0.,    0.,    0.,    0. /)                                      !! ::sigma. Owing to m_relax trees still grow
+                                                                                        !! a little when their ::circ is below ::sigma
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: coppice_diameter_mtc = &                   !! The trunk diameter above which one coppices
+  & (/ undef,  0.20,  0.20,  0.20,  0.20,  0.20,  0.20, &                               !! trees. (m)
+  &     0.20,  0.20,    0.,    0.,    0.,    0. /)                                      
+  INTEGER(i_std), PARAMETER, DIMENSION(nvmc) :: shoots_per_stool_mtc = &                !! The number of shoots which regrow on a stool after
+  (/ 9999,  6,     6,     6,      6,     6,     6, &                                    !! coppicing. 
+  6,  6, 9999, 9999,  9999, 9999 /)   
+  INTEGER(i_std), PARAMETER, DIMENSION(nvmc) :: src_rot_length_mtc = &                  !! The number of years between SRC cuttings.
+  (/ 9999,   3,     3,     3,     3,     3,     3, &                                    !! (-)
+  3,   3, 9999, 9999, 9999, 9999 /)                            
+  INTEGER(i_std), PARAMETER, DIMENSION(nvmc) :: src_nrots_mtc = &                       !! The number of SRC rotations before the whole stand
+  (/ 9999,   10,    10,    10,    10,    10,    10, &                                   !! is harvested (-)
+  10,  10, 9999, 9999, 9999, 9999 /)
+ 
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: deleuze_a_mtc = &                          !! intercept of the intra-tree competition within a stand
+  & (/ undef,  0.23,  0.23,  0.23,  0.23,  0.23,  0.23, &                               !! based on the competion rule of Deleuze and Dhote 2004
+  &     0.23,  0.23, undef, undef, undef, undef /)                                      !! Used when n_circ > 6
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: deleuze_b_mtc = &                          !! slope of the intra-tree competition within a stand
+  & (/ undef,  0.58,  0.58,  0.58,  0.58,  0.58,  0.58, &                               !! based on the competion rule of Deleuze and Dhote 2004
+  &     0.58,  0.58, undef, undef, undef, undef /)                                      !! Used when n_circ > 6
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: deleuze_p_all_mtc = &                      !! Percentile of the circumferences that receives photosynthates
+  & (/ undef,  0.50,  0.50,  0.99,  0.99,  0.99,  0.99, &                               !! based on the competion rule of Deleuze and Dhote 2004
+  &     0.99,  0.99, undef, undef, undef, undef /)                                      !! Used when n_circ > 6 for FM1, FM2 and FM4
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: deleuze_p_coppice_mtc = &                  !! Percentile of the circumferences that receives photosynthates
+  & (/ undef,  0.50,  0.50,  0.50,  0.50,  0.50,  0.50, &                               !! based on the competion rule of Deleuze and Dhote 2004
+  &     0.50,  0.50, undef, undef, undef, undef /)                                      !! Used when n_circ > 6 for FM3
+
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: recruitment_light_threshold_mtc = &          !! Light threshold (0 - 1) under which no recruitment is possible
+  &(/ undef, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, undef, undef, undef, undef/)
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: dia_recr_mtc = &                         !! Diameter (m) of the recruited stems
+  &(/ undef, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, undef, undef, undef, undef/)
+  
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: hei_recr_mtc = &                         !! Height (m) of the recruited stems (derived from allometric equation
+  &(/ undef, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, undef, undef, undef, undef/)     !! for Nouragues, French Guiana). 
+  
+ 
+  !
+  ! CROP MAANAGEMENT
+  !
+  REAL(r_std), PARAMETER, DIMENSION(nvmc) :: harvest_ratio_mtc = &                      !! Share of biomass that is removed from the site during harvest
+  & (/ undef,  undef,  undef,  undef,  undef,  undef,  undef, &                         !! A high value indicates a high harvest efficiency and thus a 
+  &    undef,  undef,  undef,  undef,    0.5,    0.5 /)                                 !! input of residuals. (unitless, 0-1).
+  
+                                                                                      
+END MODULE constantes_mtc
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parameters/constantes_soil.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parameters/constantes_soil.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parameters/constantes_soil.f90	(revision 7236)
@@ -0,0 +1,328 @@
+! =================================================================================================================================
+! MODULE 	: constantes_soil
+!
+! CONTACT       : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE       : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         "constantes_soil" module contains subroutine to initialize the parameters related to soil and hydrology.
+!!
+!!\n DESCRIPTION : "constantes_soil" module contains subroutine to initialize the parameters related to soil and hydrology.
+!!                 This module alos USE constates_soil and can therfor be used to acces the subroutines and the constantes.
+!!                 The constantes declarations can also be used seperatly with "USE constantes_soil_var".
+!!
+!! RECENT CHANGE(S): 
+!!
+!! REFERENCE(S)	:
+!!
+!! SVN          :
+!! $HeadURL: $
+!! $Date: $
+!! $Revision: $
+!! \n
+!_ ================================================================================================================================
+
+MODULE constantes_soil
+
+  USE constantes_soil_var
+  USE constantes
+  USE ioipsl_para 
+
+  IMPLICIT NONE
+
+CONTAINS
+
+  
+!! ================================================================================================================================
+!! SUBROUTINE   : config_soil_parameters
+!!
+!>\BRIEF        This subroutine reads in the configuration file all the parameters related to soil and hydrology. 
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    :
+!! \n
+!_ ================================================================================================================================
+
+   SUBROUTINE config_soil_parameters(active_flags, impose_param)
+     
+     USE ioipsl
+
+     IMPLICIT NONE
+
+     !! 0. Variables and parameters declaration
+
+     !! 0.1 Input variables
+
+     TYPE(control_type), INTENT(in) :: active_flags            !! What parts of the code are activated ? (true/false)  
+     LOGICAL                        :: impose_param            !! Flag for imposing parameters in run.def
+    !! 0.4 Local variables 
+
+     INTEGER(i_std), PARAMETER      :: error_level = 3         !! Switch to 2 to turn fatal errors into warnings.(1-3, unitless)
+     LOGICAL, SAVE                  :: first_call = .TRUE.     !! To keep first call trace (true/false)
+!$OMP THREADPRIVATE(first_call)
+
+!_ ================================================================================================================================
+     
+     IF ( first_call ) THEN
+
+        !Config Key   = THERMOSOIL_NBLEV
+        !Config Desc  = Number of soil level
+        !Config If    = 
+        !Config Def   = 7
+        !Config Help  = 
+        !Config Units = (-)
+        ngrnd=7
+        CALL getin_p("THERMOSOIL_NBLEV",ngrnd)
+
+
+        ! Following initializations are only done for option impose_param
+        IF ( active_flags%ok_sechiba .AND. impose_param ) THEN
+
+        !Config Key   = DRY_SOIL_HEAT_CAPACITY
+        !Config Desc  = Dry soil Heat capacity of soils
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 1.80e+6
+        !Config Help  = Values taken from : PIELKE,'MESOSCALE METEOROLOGICAL MODELING',P.384.
+        !Config Units = [J.m^{-3}.K^{-1}] 
+        CALL getin_p("DRY_SOIL_HEAT_CAPACITY",so_capa_dry)
+        
+        !! Check parameter value (correct range)
+        IF ( so_capa_dry <= zero ) THEN
+           CALL ipslerr_p(error_level, "config_soil_parameters.", &
+                &     "Wrong parameter value for DRY_SOIL_HEAT_CAPACITY.", &
+                &     "This parameter should be positive. ", &
+                &     "Please, check parameter value in run.def. ")
+        END IF
+        
+
+        !Config Key   = DRY_SOIL_HEAT_COND
+        !Config Desc  = Dry soil Thermal Conductivity of soils
+        !Config If    = OK_SECHIBA
+        !Config Def   = 0.40 
+        !Config Help  = Values taken from : PIELKE,'MESOSCALE METEOROLOGICAL MODELING',P.384.
+        !Config Units = [W.m^{-2}.K^{-1}] 
+        CALL getin_p("DRY_SOIL_HEAT_COND",so_cond_dry)
+
+        !! Check parameter value (correct range)
+        IF ( so_cond_dry <= zero ) THEN
+           CALL ipslerr_p(error_level, "config_soil_parameters.", &
+                &     "Wrong parameter value for DRY_SOIL_HEAT_COND.", &
+                &     "This parameter should be positive. ", &
+                &     "Please, check parameter value in run.def. ")
+        END IF
+
+
+        !Config Key   = WET_SOIL_HEAT_CAPACITY
+        !Config Desc  = Wet soil Heat capacity of soils 
+        !Config If    = OK_SECHIBA
+        !Config Def   = 3.03e+6
+        !Config Help  = 
+        !Config Units = [J.m^{-3}.K^{-1}]
+        CALL getin_p("WET_SOIL_HEAT_CAPACITY",so_capa_wet)
+
+        !! Check parameter value (correct range)
+        IF ( so_capa_wet <= zero ) THEN
+           CALL ipslerr_p(error_level, "config_soil_parameters.", &
+               &     "Wrong parameter value for WET_SOIL_HEAT_CAPACITY.", &
+               &     "This parameter should be positive. ", &
+               &     "Please, check parameter value in run.def. ")
+        END IF
+
+
+        !Config Key   = WET_SOIL_HEAT_COND
+        !Config Desc  = Wet soil Thermal Conductivity of soils
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 1.89 
+        !Config Help  = 
+        !Config Units = [W.m^{-2}.K^{-1}]
+        CALL getin_p("WET_SOIL_HEAT_COND",so_cond_wet)
+
+        !! Check parameter value (correct range)
+        IF ( so_cond_wet <= zero ) THEN
+           CALL ipslerr_p(error_level, "config_soil_parameters.", &
+               &     "Wrong parameter value for WET_SOIL_HEAT_COND.", &
+               &     "This parameter should be positive. ", &
+               &     "Please, check parameter value in run.def. ")
+        END IF
+
+
+        !Config Key   = SNOW_HEAT_COND
+        !Config Desc  = Thermal Conductivity of snow
+        !Config If    = OK_SECHIBA  
+        !Config Def   = 0.3
+        !Config Help  = 
+        !Config Units = [W.m^{-2}.K^{-1}]
+        CALL getin_p("SNOW_HEAT_COND",sn_cond)
+
+        !! Check
+        IF ( sn_cond <= zero ) THEN
+           CALL ipslerr_p(error_level, "config_soil_parameters.", &
+               &     "Wrong parameter value for SNOW_HEAT_COND.", &
+               &     "This parameter should be positive. ", &
+               &     "Please, check parameter value in run.def. ")
+        END IF
+
+
+        !Config Key   = SNOW_DENSITY
+        !Config Desc  = Snow density for the soil thermodynamics 
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 330.0
+        !Config Help  = 
+        !Config Units = [-] 
+        CALL getin_p("SNOW_DENSITY",sn_dens)
+        
+        !! Check parameter value (correct range)
+        IF ( sn_dens <= zero ) THEN
+          CALL ipslerr_p(error_level, "config_soil_parameters.", &
+               &     "Wrong parameter value for SNOW_DENSITY.", &
+               &     "This parameter should be positive. ", &
+               &     "Please, check parameter value in run.def. ")
+        END IF
+
+
+        !! Calculation of snow capacity
+        !! If sn_dens is redefined by the user, sn_capa needs to be reset
+        sn_capa = 2100.0_r_std*sn_dens
+
+
+        !Config Key   = NOBIO_WATER_CAPAC_VOLUMETRI
+        !Config Desc  = 
+        !Config If    = OK_SECHIBA and .NOT.(HYDROL_CWRR)
+        !Config Def   = 150.
+        !Config Help  = 
+        !Config Units = [s/m^2]
+        CALL getin_p('NOBIO_WATER_CAPAC_VOLUMETRI',mx_eau_nobio)
+
+       !! Check parameter value (correct range)
+        IF ( mx_eau_nobio <= zero ) THEN
+           CALL ipslerr_p(error_level, "config_soil_parameters.", &
+               &     "Wrong parameter value for NOBIO_WATER_CAPAC_VOLUMETRI.", &
+               &     "This parameter should be positive. ", &
+               &     "Please, check parameter value in run.def. ")
+        END IF
+
+
+        !Config Key   = SECHIBA_QSINT 
+        !Config Desc  = Interception reservoir coefficient
+        !Config If    = OK_SECHIBA 
+        !Config Def   = 0.1
+        !Config Help  = Transforms leaf area index into size of interception reservoir
+        !Config         for slowproc_derivvar or stomate
+        !Config Units = [m]
+        CALL getin_p('SECHIBA_QSINT',qsintcst)
+
+        !! Check parameter value (correct range)
+        IF ( qsintcst <= zero ) THEN
+           CALL ipslerr_p(error_level, "config_soil_parameters.", &
+                &     "Wrong parameter value for SECHIBA_QSINT.", &
+                &     "This parameter should be positive. ", &
+                &     "Please, check parameter value in run.def. ")
+        END IF
+
+
+        IF ( .NOT.(active_flags%hydrol_cwrr) ) THEN
+           
+           !Config Key   = CHOISNEL_DIFF_MIN
+           !Config Desc  = Diffusion constant for the slow regime
+           !Config If    = OK_SECHIBA and .NOT.(HYDROL_CWRR)
+           !Config Def   = 0.001
+           !Config Help  = 
+           !Config Units = [kg/m^2/dt]
+           CALL getin_p('CHOISNEL_DIFF_MIN',min_drain)
+
+           !! Check parameter value (correct range)
+           IF ( min_drain <= zero ) THEN
+              CALL ipslerr_p(error_level, "config_soil_parameters.", &
+                   &     "Wrong parameter value for CHOISNEL_DIFF_MIN.", &
+                   &     "This parameter should be positive. ", &
+                   &     "Please, check parameter value in run.def. ")
+            END IF
+
+
+           !Config Key   = CHOISNEL_DIFF_MAX
+           !Config Desc  = Diffusion constant for the fast regime
+           !Config If    = OK_SECHIBA and .NOT.(HYDROL_CWRR)
+           !Config Def   = 0.1
+           !Config Help  = 
+           !Config Units = [kg/m^2/dt]
+           CALL getin_p('CHOISNEL_DIFF_MAX',max_drain)
+
+           !! Check parameter value (correct range)
+           IF (  ( max_drain <= zero ) .OR. ( max_drain <= min_drain ) ) THEN
+              CALL ipslerr_p(error_level, "config_soil_parameters.", &
+                   &     "Wrong parameter value for CHOISNEL_DIFF_MAX.", &
+                   &     "This parameter should be positive or greater than CHOISNEL_DIFF_MIN.", &
+                   &     "Please, check parameter value in run.def. ")
+           END IF
+
+
+           !Config Key   = CHOISNEL_DIFF_EXP
+           !Config Desc  = The exponential in the diffusion law
+           !Config If    = OK_SECHIBA and .NOT.(HYDROL_CWRR)
+           !Config Def   = 1.5
+           !Config Help  = 
+           !Config Units = [-]
+           CALL getin_p('CHOISNEL_DIFF_EXP',exp_drain)
+           
+           !! Check parameter value (correct range)
+           IF ( exp_drain <= zero ) THEN
+              CALL ipslerr_p(error_level, "config_soil_parameters.", &
+                   &     "Wrong parameter value for CHOISNEL_DIFF_EXP.", &
+                   &     "This parameter should be positive. ", &
+                   &     "Please, check parameter value in run.def. ")
+           END IF
+
+
+           !Config Key   = CHOISNEL_RSOL_CSTE
+           !Config Desc  = Constant in the computation of resistance for bare  soil evaporation 
+           !Config If    = OK_SECHIBA and .NOT.(HYDROL_CWRR)
+           !Config Def   = 33.E3
+           !Config Help  = 
+           !Config Units = [s/m^2]
+           CALL getin_p('CHOISNEL_RSOL_CSTE',rsol_cste)
+
+           !! Check parameter value (correct range)
+           IF ( rsol_cste <= zero ) THEN
+              CALL ipslerr_p(error_level, "config_soil_parameters.", &
+                   &     "Wrong parameter value for CHOISNEL_RSOL_CSTE.", &
+                   &     "This parameter should be positive. ", &
+                   &     "Please, check parameter value in run.def. ")
+           END IF
+
+
+           !Config Key   = HCRIT_LITTER
+           !Config Desc  = Scaling depth for litter humidity
+           !Config If    = OK_SECHIBA and .NOT.(HYDROL_CWRR) 
+           !Config Def   = 0.08 
+           !Config Help  = 
+           !Config Units = [m]
+           CALL getin_p('HCRIT_LITTER',hcrit_litter)
+
+           !! Check parameter value (correct range)
+           IF ( hcrit_litter <= zero ) THEN
+              CALL ipslerr_p(error_level, "config_soil_parameters.", &
+                   &     "Wrong parameter value for HCRIT_LITTER.", &
+                   &     "This parameter should be positive. ", &
+                   &     "Please, check parameter value in run.def. ")
+           END IF
+
+        END IF
+     
+        END IF ! IF ( active_flags%ok_sechiba .AND. impose_param ) THEN
+     
+        first_call =.FALSE.
+        
+     ENDIF
+     
+   END SUBROUTINE config_soil_parameters
+   
+
+END MODULE constantes_soil
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parameters/constantes_soil_var.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parameters/constantes_soil_var.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parameters/constantes_soil_var.f90	(revision 7236)
@@ -0,0 +1,255 @@
+! =================================================================================================================================
+! MODULE 	: constantes_soil_var
+!
+! CONTACT       : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE       : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         "constantes_soil_var" module contains the parameters related to soil and hydrology.
+!!
+!!\n DESCRIPTION : The non saturated hydraulic properties are defined from the  
+!!                 formulations of van Genuchten (1980) and Mualem (1976), combined as  
+!!                 explained in d'Orgeval (2006). \n
+!!                 The related parameters for three main  
+!!                 soil textures (coarse, medium and fine) come from Carsel and Parrish  
+!!                 (1988).
+!!
+!! RECENT CHANGE(S): Sonke Zaehle changed hcrit_litter value according to Shilong Piao from 0.03 to 0.08, 080806
+!!
+!! REFERENCE(S)	:
+!!- Roger A.Pielke, (2002), Mesoscale meteorological modeling, Academic Press Inc. 
+!!- Polcher, J., Laval, K., DÃŒmenil, L., Lean, J., et Rowntree, P. R. (1996).
+!! Comparing three land surface schemes used in general circulation models. Journal of Hydrology, 180(1-4), 373--394.
+!!- Ducharne, A., Laval, K., et Polcher, J. (1998). Sensitivity of the hydrological cycle
+!! to the parametrization of soil hydrology in a GCM. Climate Dynamics, 14, 307--327. 
+!!- Rosnay, P. de et Polcher, J. (1999). Modelling root water uptake in a complex land surface
+!! scheme coupled to a GCM. Hydrol. Earth Syst. Sci., 2(2/3), 239--255.
+!!- d'Orgeval, T. et Polcher, J. (2008). Impacts of precipitation events and land-use changes
+!! on West African river discharges during the years 1951--2000. Climate Dynamics, 31(2), 249--262. 
+!!- Carsel, R. and Parrish, R.: Developing joint probability distributions of soil water
+!! retention characteristics, Water Resour. Res.,24, 755â769, 1988.
+!!- Mualem Y (1976) A new model for predicting the hydraulic conductivity  
+!! of unsaturated porous media. Water Resources Research 12(3):513-522
+!!- Van Genuchten M (1980) A closed-form equation for predicting the  
+!! hydraulic conductivity of unsaturated soils. Soil Sci Soc Am J, 44(5):892-898
+!!
+!! SVN          :
+!! $HeadURL: $
+!! $Date: $
+!! $Revision: $
+!! \n
+!_ ================================================================================================================================
+
+MODULE constantes_soil_var
+
+  USE defprec
+
+  IMPLICIT NONE
+
+
+  LOGICAL, SAVE             :: check_waterbal=.TRUE.    !! The check the water balance (true/false)
+!$OMP THREADPRIVATE(check_waterbal)
+
+  !! Dimensioning parameters
+
+  INTEGER(i_std), SAVE :: ngrnd                         !! Number of soil level for thermo (unitless)
+  !$OMP THREADPRIVATE(ngrnd)
+  INTEGER(i_std), PARAMETER :: nbdl=11                  !! Number of diagnostic levels in the soil
+                                                        !! To compare hydrologic variables with tag 1.6 and lower,
+                                                        !! set nbdl to 6 : INTEGER(i_std), PARAMETER :: nbdl = 6
+                                                        !! (unitless)
+  INTEGER(i_std), PARAMETER :: nslm=11                  !! Number of levels in CWRR (unitless)
+
+  REAL(r_std), SAVE         :: dpu_max                  !! Maximum depth of soil reservoir (m). Default value is set 
+                                                        !! in intsurf_config depending on Choisnel(4m) or CWRR(2m)
+!$OMP THREADPRIVATE(dpu_max)
+
+  !! Number of soil classes
+
+  INTEGER(i_std), PARAMETER :: ntext=3                  !! Number of soil textures (Silt, Sand, Clay)
+  INTEGER(i_std), PARAMETER :: nstm=3                   !! Number of soil tiles (unitless)
+  CHARACTER(LEN=30)         :: soil_classif             !! Type of classification used for the map of soil types.
+                                                        !! It must be consistent with soil file given by 
+                                                        !! SOILCLASS_FILE parameter.
+  INTEGER(i_std), PARAMETER :: nscm_fao=3               !! For FAO Classification (unitless)
+  INTEGER(i_std), PARAMETER :: nscm_usda=12             !! For USDA Classification (unitless)
+  INTEGER(i_std), SAVE      :: nscm=nscm_fao            !! Default value for nscm
+!$OMP THREADPRIVATE(nscm)
+
+  !! Parameters for soil thermodynamics
+
+  REAL(r_std), SAVE :: so_capa_dry = 1.80e+6            !! Dry soil Heat capacity of soils 
+                                                        !! @tex $(J.m^{-3}.K^{-1})$ @endtex 
+!$OMP THREADPRIVATE(so_capa_dry)
+  REAL(r_std), SAVE :: so_cond_dry = 0.40               !! Dry soil Thermal Conductivity of soils
+                                                        !! @tex $(W.m^{-2}.K^{-1})$ @endtex
+!$OMP THREADPRIVATE(so_cond_dry)
+  REAL(r_std), SAVE :: so_capa_wet = 3.03e+6            !! Wet soil Heat capacity of soils 
+                                                        !! @tex $(J.m^{-3}.K^{-1})$ @endtex
+!$OMP THREADPRIVATE(so_capa_wet)
+  REAL(r_std), SAVE :: so_cond_wet = 1.89               !! Wet soil Thermal Conductivity of soils 
+                                                        !! @tex $(W.m^{-2}.K^{-1})$ @endtex 
+!$OMP THREADPRIVATE(so_cond_wet)
+  REAL(r_std), SAVE :: sn_cond = 0.3                    !! Thermal Conductivity of snow 
+                                                        !! @tex $(W.m^{-2}.K^{-1})$ @endtex  
+!$OMP THREADPRIVATE(sn_cond)
+  REAL(r_std), SAVE :: sn_dens = 330.0                  !! Snow density for the soil thermodynamics
+                                                        !! @tex $(kg.m^{-3})$ @endtex
+!$OMP THREADPRIVATE(sn_dens)
+  REAL(r_std), SAVE :: sn_capa                          !! Heat capacity for snow 
+                                                        !! @tex $(J.m^{-3}.K^{-1})$ @endtex
+!$OMP THREADPRIVATE(sn_capa)
+
+
+  !! Specific parameters for the Choisnel hydrology
+
+  REAL(r_std), SAVE :: min_drain = 0.001                !! Diffusion constant for the slow regime
+                                                        !! (This is for the diffusion between reservoirs)
+                                                        !! @tex $(kg.m^{-2}.dt^{-1})$ @endtex
+!$OMP THREADPRIVATE(min_drain)
+  REAL(r_std), SAVE :: max_drain = 0.1                  !! Diffusion constant for the fast regime 
+                                                        !! @tex $(kg.m^{-2}.dt^{-1})$ @endtex
+!$OMP THREADPRIVATE(max_drain)
+  REAL(r_std), SAVE :: exp_drain = 1.5                  !! The exponential in the diffusion law (unitless)
+!$OMP THREADPRIVATE(exp_drain)
+  REAL(r_std), SAVE :: qsintcst = 0.1                   !! Transforms leaf area index into size of interception reservoir
+                                                        !! (unitless)
+!$OMP THREADPRIVATE(qsintcst)
+  REAL(r_std), SAVE :: mx_eau_nobio = 150.              !! Volumetric available soil water capacity in nobio fractions
+                                                        !! @tex $(kg.m^{-3} of soil)$ @endtex
+!$OMP THREADPRIVATE(mx_eau_nobio)
+  REAL(r_std), SAVE :: rsol_cste = 33.E3                !! Constant in the computation of resistance for bare soil evaporation
+                                                        !! @tex $(s.m^{-2})$ @endtex
+!$OMP THREADPRIVATE(rsol_cste)
+  REAL(r_std), SAVE :: hcrit_litter=0.08_r_std          !! Scaling depth for litter humidity (m)
+!$OMP THREADPRIVATE(hcrit_litter)
+
+
+  !! Parameters specific for the CWRR hydrology.
+
+  !!  1. Parameters for FAO Classification
+
+  !! Parameters for soil type distribution
+
+  REAL(r_std),DIMENSION(nscm_fao),SAVE :: soilclass_default_fao = &   !! Default soil texture distribution for fao :
+ & (/ 0.28, 0.52, 0.20 /)                                             !! in the following order : COARSE, MEDIUM, FINE (unitless)
+!$OMP THREADPRIVATE(soilclass_default_fao)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: nvan_fao = &            !! Van genuchten coefficient n
+ & (/ 1.89_r_std, 1.56_r_std, 1.31_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: avan_fao = &            !! Van genuchten coefficient a (mm^{-1}) 
+  & (/ 0.0075_r_std, 0.0036_r_std, 0.0019_r_std /) 
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: mcr_fao = &             !! Residual soil water content
+ & (/ 0.065_r_std, 0.078_r_std, 0.095_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: mcs_fao = &             !! Saturated soil water content
+ & (/ 0.41_r_std, 0.43_r_std, 0.41_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: ks_fao = &              !! Hydraulic conductivity Saturation (mm/d)
+ & (/ 1060.8_r_std, 249.6_r_std, 62.4_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: pcent_fao = &           !! Fraction of saturated volumetric soil moisture 
+ & (/ 0.5_r_std, 0.5_r_std, 0.5_r_std /)                               !! above which transpir is max (0-1, unitless)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: free_drain_max_fao = &  !! Max value of the permeability coeff at 
+ & (/ 1.0_r_std, 1.0_r_std, 1.0_r_std /)                               !! the bottom of the soil
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: mcf_fao = &             !! Volumetric water content field capacity
+ & (/ 0.32_r_std, 0.32_r_std, 0.32_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: mcw_fao = &             !! Volumetric water content Wilting pt
+ & (/ 0.10_r_std, 0.10_r_std, 0.10_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: mc_awet_fao = &         !! Vol. wat. cont. above which albedo is cst
+ & (/ 0.25_r_std, 0.25_r_std, 0.25_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: mc_adry_fao = &         !! Vol. wat. cont. below which albedo is cst
+ & (/ 0.1_r_std, 0.1_r_std, 0.1_r_std /)
+
+
+  !!  2. Parameters for USDA Classification
+
+  !! Parameters for soil type distribution :
+  !! Sand, Loamy Sand, Sandy Loam, Silt Loam, Silt, Loam, Sandy Clay Loam, Silty Clay Loam, Clay Loam, Sandy Clay, Silty Clay, Clay
+
+  REAL(r_std),DIMENSION(nscm_usda),SAVE :: soilclass_default_usda = &    !! Default soil texture distribution in the following order :
+ & (/ 0.28, 0.52, 0.20, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 /)   !!    sand, loam and clay ??? OR COARSE, MEDIUM, FINE???
+!$OMP THREADPRIVATE(soilclass_default_usda)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: nvan_usda = &            !! Van genuchten coefficient n
+ & (/ 2.68_r_std, 2.28_r_std, 1.89_r_std, 1.41_r_std, &
+ &    1.37_r_std, 1.56_r_std, 1.48_r_std, 1.23_r_std, &
+ &    1.31_r_std, 1.23_r_std, 1.09_r_std, 1.09_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: avan_usda = &            !! Van genuchten coefficient a (mm^{-1})
+ & (/ 0.0145_r_std, 0.0124_r_std, 0.0075_r_std, 0.0020_r_std, &
+ &    0.0016_r_std, 0.0036_r_std, 0.0059_r_std, 0.0010_r_std, &
+ &    0.0019_r_std, 0.0027_r_std, 0.0005_r_std, 0.0008_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: mcr_usda = &             !! Residual soil water content
+ & (/ 0.045_r_std, 0.057_r_std, 0.065_r_std, 0.067_r_std, &
+ &    0.034_r_std, 0.078_r_std, 0.100_r_std, 0.089_r_std, &
+ &    0.095_r_std, 0.100_r_std, 0.070_r_std, 0.068_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: mcs_usda = &             !! Saturated soil water content
+ & (/ 0.43_r_std, 0.41_r_std, 0.41_r_std, 0.45_r_std, &
+ &    0.46_r_std, 0.43_r_std, 0.39_r_std, 0.43_r_std, &
+ &    0.41_r_std, 0.38_r_std, 0.36_r_std, 0.38_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: ks_usda = &              !! Hydraulic conductivity Saturation (mm/d)
+ & (/ 7128.0_r_std, 3501.6_r_std, 1060.8_r_std, 108.0_r_std, &
+ &    60.0_r_std, 249.6_r_std, 314.4_r_std, 16.8_r_std, &
+ &    62.4_r_std, 28.8_r_std, 4.8_r_std, 48.0_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: pcent_usda = &           !! Soil moisture above which transpir is max
+ & (/ 0.5_r_std, 0.5_r_std, 0.5_r_std, 0.5_r_std, &
+ &    0.5_r_std, 0.5_r_std, 0.5_r_std, 0.5_r_std, &
+ &    0.5_r_std, 0.5_r_std, 0.5_r_std, 0.5_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: free_drain_max_usda = &  !! Max value of the permeability coeff at 
+ & (/ 1.0_r_std, 1.0_r_std, 1.0_r_std, 1.0_r_std, &                      !! the bottom of the soil
+ &    1.0_r_std, 1.0_r_std, 1.0_r_std, 1.0_r_std, &
+ &    1.0_r_std, 1.0_r_std, 1.0_r_std, 1.0_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: mcf_usda = &             !! Volumetric water content field capacity
+ & (/ 0.32_r_std, 0.32_r_std, 0.32_r_std, 0.32_r_std, &
+ &    0.32_r_std, 0.32_r_std, 0.32_r_std, 0.32_r_std, &
+ &    0.32_r_std, 0.32_r_std, 0.32_r_std, 0.32_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: mcw_usda = &             !! Volumetric water content Wilting pt
+ & (/ 0.10_r_std, 0.10_r_std, 0.10_r_std, 0.10_r_std, &
+ &    0.10_r_std, 0.10_r_std, 0.10_r_std, 0.10_r_std, &
+ &    0.10_r_std, 0.10_r_std, 0.10_r_std, 0.10_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: mc_awet_usda = &         !! Vol. wat. cont. above which albedo is cst
+ & (/ 0.25_r_std, 0.25_r_std, 0.25_r_std, 0.25_r_std, &
+ &    0.25_r_std, 0.25_r_std, 0.25_r_std, 0.25_r_std, &
+ &    0.25_r_std, 0.25_r_std, 0.25_r_std, 0.25_r_std /)
+
+  REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: mc_adry_usda = &         !! Vol. wat. cont. below which albedo is cst
+ & (/ 0.1_r_std, 0.1_r_std, 0.1_r_std, 0.1_r_std, &
+ &    0.1_r_std, 0.1_r_std, 0.1_r_std, 0.1_r_std, &
+ &    0.1_r_std, 0.1_r_std, 0.1_r_std, 0.1_r_std /)
+
+
+  !! Parameters for the numerical scheme used by CWRR
+
+  INTEGER(i_std), PARAMETER :: imin = 1                                 !! CWRR linearisation (unitless)
+  INTEGER(i_std), PARAMETER :: nbint = 50                               !! Number of interval for CWRR (unitless)
+  INTEGER(i_std), PARAMETER :: imax = nbint+1                           !! Number of points for CWRR (unitless)
+  REAL(r_std), PARAMETER    :: w_time = 1.0_r_std                       !! Time weighting for discretisation (unitless)
+
+
+  !! Diagnostic variables
+
+  REAL(r_std),DIMENSION(nbdl),SAVE :: diaglev                           !! 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. 
+                                                                        !! (unitless)
+!$OMP THREADPRIVATE(diaglev)
+
+END MODULE Constantes_soil_var
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parameters/constantes_var.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parameters/constantes_var.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parameters/constantes_var.f90	(revision 7236)
@@ -0,0 +1,1600 @@
+! =================================================================================================================================
+! MODULE       : constantes_var
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        constantes_var module contains most constantes like pi, Earth radius, etc...
+!!              and all externalized parameters except pft-dependent constants.
+!!
+!!\n DESCRIPTION: This module contains most constantes and the externalized parameters of ORCHIDEE which 
+!!                are not pft-dependent.\n
+!!                In this module, you can set the flag diag_qsat in order to detect the pixel where the
+!!                temperature is out of range (look qsatcalc and dev_qsatcalc in qsat_moisture.f90).\n
+!!                The Earth radius is approximated by the 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.\n
+!!                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.\n
+!!                This module is already USE in module constantes. Therefor no need to USE it seperatly except
+!!                if the subroutines in module constantes are not needed.\n
+!!                
+!! RECENT CHANGE(S):
+!!
+!! REFERENCE(S)	: 
+!! - Louis, Jean-Francois (1979), A parametric model of vertical eddy fluxes in the atmosphere. 
+!! Boundary Layer Meteorology, 187-202.\n
+!!
+!! SVN          :
+!! $HeadURL: $
+!! $Date: 2015-02-22 16:18:16 +0100 (Sun, 22 Feb 2015) $
+!! $Revision: 2555 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE constantes_var
+
+  USE defprec
+
+  IMPLICIT NONE
+  !
+  ! FLAGS 
+  !
+  TYPE control_type
+    LOGICAL :: river_routing            !! activate river routing (true/false)
+    LOGICAL :: hydrol_cwrr              !! activate 11 layers hydrolgy model (true/false)
+    LOGICAL :: do_floodplains
+    LOGICAL :: do_irrigation
+    LOGICAL :: ok_sechiba               !! activate physic of the model (true/false)
+    LOGICAL :: ok_co2                   !! activate photosynthesis (true/false)
+    LOGICAL :: ok_stomate               !! activate carbon cycle (true/false)
+    LOGICAL :: ok_dgvm                  !! activate dynamic vegetation (true/false)
+    LOGICAL :: stomate_watchout         !! activate the creation of restart files for STOMATE even if STOMATE is not activated 
+                                        !! (true/false)
+    LOGICAL :: ok_pheno                 !! activate the calculation of lai using stomate rather than a prescription (true/false)
+    LOGICAL :: do_land_use              !! ??? NOt clear why this is needed in the control structure
+                                        !! Seems to duplicate ok_land_cover_change (previously lcchange)
+    LOGICAL :: ok_inca                  !! activate biogenic volatile organic coumpounds ? (true/false)
+    LOGICAL :: ok_leafage               !! activate leafage? (true/false)
+    LOGICAL :: ok_radcanopy             !! use canopy radiative transfer model (true/false)
+    LOGICAL :: ok_multilayer            !! use canopy radiative transfer model with multi-layers (true/false)
+    LOGICAL :: ok_pulse_NOx             !! calculate NOx emissions with pulse (true/false)
+    LOGICAL :: ok_bbgfertil_NOx         !! calculate NOx emissions with bbg fertilizing effect (true/false)
+    LOGICAL :: ok_cropsfertil_NOx       !! calculate NOx emissions with fertilizers use (true/false)
+    LOGICAL :: forest_management        !!
+    LOGICAL :: do_new_snow_albedo       !! Use a new type of snow albedo compatible with new albedo schemes (true/false)
+    LOGICAL :: ok_functional_allocation !! Use functional allocation rather than resource limited allocation (true/false)
+    LOGICAL :: ok_cexchange             !! Use photosynthesis according to Friend et al 2010 (true/false)
+    LOGICAL :: ok_hydrol_arch           !! Use hydraulic architecture to calculate supply of water for transpiration from the 
+                                        !! leaves (true/false)
+    LOGICAL :: ok_agricultural_harvest  !! Harvest the agricultural PFT's (true/false)
+    LOGICAL :: ok_constant_mortality    !! Uses a prescribed constant mortality. If not activated, mortality is a function of 
+                                        !! last year's NPP (true/false)
+    LOGICAL :: ok_herbivory             !! allow herbivory (true/false)
+    LOGICAL :: ok_land_cover_change     !! activate land cover change (true/false)
+    LOGICAL :: ok_dofoco                !! Run a DOFOCO simulation (true/false)
+                                        !! This flag overrides a number of other flags if set to TRUE.
+    LOGICAL :: ok_daily_recruitment     !! Activate the daily recruitment
+    LOGICAL :: ok_recruitment           !! Activate the recruitment
+    LOGICAL :: ok_nenerbil              !! Activate the new energy budget scheme
+    LOGICAL :: ok_gs_feedback           !! Activate water stress feedback on the stomatal conductance
+
+    LOGICAL :: ok_joetzjer_hydro        !! Activate the detailled hydraulic architecture !tzjh 
+
+ END TYPE control_type
+
+  !-
+  TYPE(control_type), SAVE :: control  !! Flags that (de)activate parts of the model
+!$OMP THREADPRIVATE(control)
+  LOGICAL, SAVE :: OFF_LINE_MODE = .FALSE.  !! ORCHIDEE detects if it is coupled with a GCM or 
+                                            !! just use with one driver in OFF-LINE. (true/false)
+!$OMP THREADPRIVATE(OFF_LINE_MODE)
+  CHARACTER(LEN=80), SAVE     :: restname_in       = 'NONE'                 !! Input Restart files name for Sechiba component  
+!$OMP THREADPRIVATE(restname_in)
+  CHARACTER(LEN=80), SAVE     :: restname_out      = 'sechiba_rest_out.nc'  !! Output Restart files name for Sechiba component
+!$OMP THREADPRIVATE(restname_out)
+  CHARACTER(LEN=80), SAVE     :: stom_restname_in  = 'NONE'                 !! Input Restart files name for Stomate component
+!$OMP THREADPRIVATE(stom_restname_in)
+  CHARACTER(LEN=80), SAVE     :: stom_restname_out = 'stomate_rest_out.nc'  !! Output Restart files name for Stomate component
+!$OMP THREADPRIVATE(stom_restname_out)
+
+  !
+  ! DEBUG
+  !
+  INTEGER(i_std), SAVE        :: test_pft = 2                               !! tzj Number of PFT for which detailed output 
+                                                                            !! is written to the output file. If set > 26 no extra
+                                                                            !! output is written
+
+
+
+!$OMP THREADPRIVATE(test_pft)
+  INTEGER(i_std), SAVE        :: test_grid                                  !! Number of the grid square for which detailed output 
+                                                                            !! is written to the output file. 
+!$OMP THREADPRIVATE(test_grid)
+  INTEGER, SAVE :: printlev=1       !! Standard level for text output [0, 1, 2, 3]
+!$OMP THREADPRIVATE(printlev)
+
+  !
+  ! TIME
+  !
+  REAL(r_std), SAVE :: one_day  !! One day in seconds (s)
+!$OMP THREADPRIVATE(one_day)
+  REAL(r_std), SAVE :: one_year !! One year in seconds (s)
+!$OMP THREADPRIVATE(one_year)
+  REAL(r_std), PARAMETER :: one_hour = 3600.0  !! One hour in seconds (s)
+
+  ! TIME STEP
+  REAL(r_std)            :: dt_sechiba         !! Time step for in sechiba
+!$OMP THREADPRIVATE(dt_sechiba)
+
+  !
+  ! SPECIAL VALUES 
+  !
+  INTEGER(i_std), PARAMETER :: undef_int = 999999999     !! undef integer for integer arrays (unitless)
+  !-
+  REAL(r_std), SAVE :: val_exp = 999999.                 !! Specific value if no restart value  (unitless)
+!$OMP THREADPRIVATE(val_exp)
+  REAL(r_std), PARAMETER :: undef = -9999.               !! Special value for stomate (unitless)
+  !-
+  REAL(r_std), PARAMETER :: min_sechiba = 1.E-8_r_std    !! Epsilon to detect a near zero floating point (unitless)
+  REAL(r_std), PARAMETER :: undef_sechiba = 1.E+20_r_std !! The undef value used in SECHIBA (unitless)
+  !-
+  REAL(r_std), PARAMETER :: min_stomate = 1.E-8_r_std    !! Epsilon to detect a near zero floating point (unitless)
+  REAL(r_std), PARAMETER :: large_value = 1.E33_r_std    !! some large value (for stomate) (unitless)
+
+
+  !
+  !  DIMENSIONING AND INDICES PARAMETERS  
+  !
+  INTEGER(i_std), PARAMETER :: ibare_sechiba = 1 !! Index for bare soil in Sechiba (unitless)
+  INTEGER(i_std), PARAMETER :: ivis = 1          !! index for albedo in visible range (unitless)
+  INTEGER(i_std), PARAMETER :: inir = 2          !! index for albeod i near-infrared range (unitless) 
+  INTEGER(i_std), PARAMETER :: n_spectralbands=2  !! number of spectral bands
+  INTEGER(i_std), PARAMETER :: nnobio = 1        !! Number of other surface types: land ice (lakes,cities, ...) (unitless)
+  INTEGER(i_std), PARAMETER :: iice = 1          !! Index for land ice (see nnobio) (unitless)
+  !-
+  !! Soil
+  INTEGER(i_std), PARAMETER :: classnb = 9       !! Levels of soil colour classification (unitless)
+  !-
+  INTEGER(i_std), PARAMETER :: nleafages = 4     !! leaf age discretisation ( 1 = no discretisation )(unitless)
+  !-
+  !! litter fractions: indices (unitless)
+  INTEGER(i_std), PARAMETER :: ileaf = 1         !! Index for leaf compartment (unitless)
+  INTEGER(i_std), PARAMETER :: isapabove = 2     !! Index for sapwood above compartment (unitless)
+  INTEGER(i_std), PARAMETER :: isapbelow = 3     !! Index for sapwood below compartment (unitless)
+  INTEGER(i_std), PARAMETER :: iheartabove = 4   !! Index for heartwood above compartment (unitless)
+  INTEGER(i_std), PARAMETER :: iheartbelow = 5   !! Index for heartwood below compartment (unitless)
+  INTEGER(i_std), PARAMETER :: iroot = 6         !! Index for roots compartment (unitless)
+  INTEGER(i_std), PARAMETER :: ifruit = 7        !! Index for fruits compartment (unitless)
+  INTEGER(i_std), PARAMETER :: icarbres = 8      !! Index for reserve compartment (unitless)
+  INTEGER(i_std), PARAMETER :: ilabile = 9       !! Index for reserve compartment (unitless) 
+  INTEGER(i_std), PARAMETER :: nparts = 9        !! Number of biomass compartments (unitless)
+  !-
+  !! indices for assimilation parameters 
+  INTEGER(i_std), PARAMETER :: ivcmax = 1        !! Index for vcmax (assimilation parameters) (unitless)
+  INTEGER(i_std), PARAMETER :: npco2 = 1         !! Number of assimilation parameters (unitless)
+  !-
+  !! trees and litter: indices for the parts of heart-
+  !! and sapwood above and below the ground 
+  INTEGER(i_std), PARAMETER :: iabove = 1       !! Index for above part (unitless)
+  INTEGER(i_std), PARAMETER :: ibelow = 2       !! Index for below part (unitless)
+  INTEGER(i_std), PARAMETER :: nlevs = 2        !! Number of levels for trees and litter (unitless)
+  !-
+  !! litter: indices for metabolic and structural part
+  INTEGER(i_std), PARAMETER :: imetabolic = 1   !! Index for metabolic litter (unitless)
+  INTEGER(i_std), PARAMETER :: istructural = 2  !! Index for structural litter (unitless)
+  INTEGER(i_std), PARAMETER :: iwoody = 3       !! Index for woody litter (unitless)
+  INTEGER(i_std), PARAMETER :: nlitt = 3        !! Number of levels for litter compartments (unitless)
+  !-
+  !! carbon pools: indices
+  INTEGER(i_std), PARAMETER :: iactive = 1      !! Index for active carbon pool (unitless)
+  INTEGER(i_std), PARAMETER :: islow = 2        !! Index for slow carbon pool (unitless)
+  INTEGER(i_std), PARAMETER :: ipassive = 3     !! Index for passive carbon pool (unitless)
+  INTEGER(i_std), PARAMETER :: ncarb = 3        !! Number of soil carbon pools (unitless)
+  !-
+  !! For isotopes and nitrogen
+  INTEGER(i_std), PARAMETER :: nelements = 1    !! Number of isotopes considered
+  INTEGER(i_std), PARAMETER :: icarbon = 1      !! Index for carbon 
+  !
+  !! Indices used for analytical spin-up
+  INTEGER(i_std), PARAMETER :: nbpools = 9              !! Total number of carbon pools (unitless)
+  INTEGER(i_std), PARAMETER :: istructural_above = 1    !! Index for structural litter above (unitless)
+  INTEGER(i_std), PARAMETER :: istructural_below = 2    !! Index for structural litter below (unitless)
+  INTEGER(i_std), PARAMETER :: imetabolic_above = 3     !! Index for metabolic litter above (unitless)
+  INTEGER(i_std), PARAMETER :: imetabolic_below = 4     !! Index for metabolic litter below (unitless)
+  INTEGER(i_std), PARAMETER :: iwoody_above = 5         !! Index for woody litter above (unitless)
+  INTEGER(i_std), PARAMETER :: iwoody_below = 6         !! Index for woody litter below (unitless)
+  INTEGER(i_std), PARAMETER :: iactive_pool = 7         !! Index for active carbon pool (unitless)
+  INTEGER(i_std), PARAMETER :: islow_pool   = 8         !! Index for slow carbon pool (unitless)
+  INTEGER(i_std), PARAMETER :: ipassive_pool = 9        !! Index for passive carbon pool (unitless)
+  !
+  !! Indices for orphan fluxes
+  INTEGER(i_std), PARAMETER :: norphans = 8             !! Total number of orphan fluxes (unitless)
+  INTEGER(i_std), PARAMETER :: ivegold = 1              !! Index for veget_max before LCC
+  INTEGER(i_std), PARAMETER :: ivegnew = 2              !! Index for veget_max before LCC (includes veget_max of orphan fluxes)
+  INTEGER(i_std), PARAMETER :: igpp = 3                 !! Index for gpp_daily
+  INTEGER(i_std), PARAMETER :: ico2bm = 4               !! Index for co2_to_bm
+  INTEGER(i_std), PARAMETER :: irmain = 5               !! Index for maintenance respiration
+  INTEGER(i_std), PARAMETER :: irgrow = 6               !! Index for growth respiration
+  INTEGER(i_std), PARAMETER :: inpp = 7                 !! Index for npp_daily
+  INTEGER(i_std), PARAMETER :: irhet = 8                !! Index for total heterotrophic respiration
+  !
+  !! Indices for circumference classes (output)
+  INTEGER(i_std), PARAMETER :: ic02 = 1                 !! circumeference < 0.2 m
+  INTEGER(i_std), PARAMETER :: ic04 = 2                 !! 0.2 < circ < 0.4
+  INTEGER(i_std), PARAMETER :: ic06 = 3                 !! 0.4 < circ < 0.6
+  INTEGER(i_std), PARAMETER :: ic08 = 4                 !! 0.6 < circ < 0.8
+  INTEGER(i_std), PARAMETER :: ic10 = 5                 !! 0.8 < circ < 1.0
+  INTEGER(i_std), PARAMETER :: ic12 = 6                 !! 1.0 < circ < 1.2
+  INTEGER(i_std), PARAMETER :: ic14 = 7                 !! 1.2 < circ < 1.4
+  INTEGER(i_std), PARAMETER :: ic16 = 8                 !! 1.4 < circ < 1.6
+  INTEGER(i_std), PARAMETER :: ic18 = 9                 !! 1.6 < circ < 1.8
+  INTEGER(i_std), PARAMETER :: ic20 = 10                !! 1.8 < circ < 2.0
+  INTEGER(i_std), PARAMETER :: ic222 = 11               !! circ > 2 m
+  INTEGER(i_std), PARAMETER :: icpo = 12                !! poles, circumference <0.235 m
+  INTEGER(i_std), PARAMETER :: icsw = 13                !! small wood, 0.235 < circ < 0.705
+  INTEGER(i_std), PARAMETER :: icmw = 14                !! medium wood, 0.705 < circ < 1.175
+  INTEGER(i_std), PARAMETER :: iclw = 15                !! large wood, 1.175 < circ 
+
+  !
+  ! These next sets of parameters are now used for both circ_class_kill and
+  ! for the harvest_pool.  One source of confusion is what to do with trees that
+  ! die from self-thinning or forest dieoffs.  These happen in all forests, regardless
+  ! of management strategy.  I decided to put death of this kind into ifm_none, since
+  ! it is the only type of mortality found in an unmanaged forest.  If the mortality
+  ! does not kill the whole forest (e.g. self thinning), it goes into icut_thin.  If it
+  ! does (forest dieoff), it goes into icut_clear.  The biomass is killed in lpj_gap.
+
+  !! Indices used for forest management strategies
+  INTEGER(i_std), PARAMETER :: nfm_types = 6             !! The total number of forest management strategies we can use
+  INTEGER(i_std), PARAMETER :: ifm_none = 1              !! No human intervention in the forests.
+  INTEGER(i_std), PARAMETER :: ifm_thin = 2              !! Regular thinning and harvesting of wood based on RDI.
+  INTEGER(i_std), PARAMETER :: ifm_cop = 3               !! Coppicing for fuelwood.
+  INTEGER(i_std), PARAMETER :: ifm_src = 4               !! Short rotation coppices for biomass production.
+  INTEGER(i_std), PARAMETER :: ifm_crop = 5              !! Crop harvest
+  INTEGER(i_std), PARAMETER :: ifm_grass = 6             !! Grazing or cutting 
+  !! Indices used for harvest pools
+  INTEGER(i_std), PARAMETER :: ncut_times = 9            !! The total number of times when trees are cut and wood harvested.
+  INTEGER(i_std), PARAMETER :: icut_clear = 1            !! A clearcut where all biomass is removed.
+  INTEGER(i_std), PARAMETER :: icut_thin = 2             !! Thinning of biomass to reduce the number of trees.
+  INTEGER(i_std), PARAMETER :: icut_lcc_wood = 3         !! Wood harvest following land cover change (LCC)
+  INTEGER(i_std), PARAMETER :: icut_lcc_res = 4          !! Site clearing, removal of the stumps and branches following LCC
+  INTEGER(i_std), PARAMETER :: icut_crop = 5             !! Crop harvest
+  INTEGER(i_std), PARAMETER :: icut_grass = 6            !! Grazing or cutting
+  INTEGER(i_std), PARAMETER :: icut_cop1 = 7             !! The first coppice cut
+  INTEGER(i_std), PARAMETER :: icut_cop2 = 8             !! The second (and subsequent) coppice cut
+  INTEGER(i_std), PARAMETER :: icut_cop3 = 9             !! The last coppice cut (only for SRC)
+
+  !! Indices used to define the product pools
+  INTEGER(i_std), PARAMETER :: nshort = 1                !! Length in years of the short-lived product pool (GE 1)
+  INTEGER(i_std), PARAMETER :: nmedium = 10              !! Length in years of the medium-lived product pool (GT 4)
+  INTEGER(i_std), PARAMETER :: nlong = 100               !! Length in years of the long-lived product pool (GT 4)
+
+  !! Indices used to check the mass balance closure
+  INTEGER(i_std), PARAMETER :: nmbcomp = 5               !! The total nomber of components in our mass balance check
+  INTEGER(i_std), PARAMETER :: iatm2land = 1             !! atmosphere to land fluxes such as GPP and co2_2_bm
+  INTEGER(i_std), PARAMETER :: iland2atm = 2             !! land to atmosphere fluxes such as Rh, Ra and product decomposition
+  INTEGER(i_std), PARAMETER :: ilat2out = 3              !! outgoing lateral flux i.e. DOC leaching for the litter routine
+  INTEGER(i_std), PARAMETER :: ilat2in = 4               !! incoming lateral flux i.e. N deposition for the land
+  INTEGER(i_std), PARAMETER :: ipoolchange = 5           !! change in pool size i.e. change in biomass
+
+  !! Indices used for warning tracking
+  INTEGER(i_std), PARAMETER :: nwarns = 1                !! The total number of warnings we track
+  INTEGER(i_std), PARAMETER :: iwphoto = 1               !! A warning about division by zero in photosynthesis 
+  !
+  ! NUMERICAL AND PHYSICS CONSTANTS
+  !
+
+  !-
+  ! 1. Mathematical and numerical constants
+  !-
+  REAL(r_std), PARAMETER :: pi = 3.141592653589793238   !! pi souce : http://mathworld.wolfram.com/Pi.html (unitless)
+  REAL(r_std), PARAMETER :: euler = 2.71828182845904523 !! e source : http://mathworld.wolfram.com/e.html (unitless)
+  REAL(r_std), PARAMETER :: zero = 0._r_std             !! Numerical constant set to 0 (unitless)
+  REAL(r_std), PARAMETER :: undemi = 0.5_r_std          !! Numerical constant set to 1/2 (unitless)
+  REAL(r_std), PARAMETER :: un = 1._r_std               !! Numerical constant set to 1 (unitless)
+  REAL(r_std), PARAMETER :: moins_un = -1._r_std        !! Numerical constant set to -1 (unitless)
+  REAL(r_std), PARAMETER :: deux = 2._r_std             !! Numerical constant set to 2 (unitless)
+  REAL(r_std), PARAMETER :: trois = 3._r_std            !! Numerical constant set to 3 (unitless)
+  REAL(r_std), PARAMETER :: quatre = 4._r_std           !! Numerical constant set to 4 (unitless)
+  REAL(r_std), PARAMETER :: cinq = 5._r_std             !![DISPENSABLE] Numerical constant set to 5 (unitless)
+  REAL(r_std), PARAMETER :: six = 6._r_std              !![DISPENSABLE] Numerical constant set to 6 (unitless)
+  REAL(r_std), PARAMETER :: huit = 8._r_std             !! Numerical constant set to 8 (unitless)
+  REAL(r_std), PARAMETER :: mille = 1000._r_std         !! Numerical constant set to 1000 (unitless)
+
+  !-
+  ! 2 . Physics
+  !-
+  REAL(r_std), PARAMETER :: R_Earth = 6378000.              !! radius of the Earth : Earth radius ~= Equatorial radius (m)
+  REAL(r_std), PARAMETER :: mincos  = 0.0001                !! Minimum cosine value used for interpolation (unitless) 
+  REAL(r_std), PARAMETER :: pb_std = 1013.                  !! standard pressure (hPa)
+  REAL(r_std), PARAMETER :: ZeroCelsius = 273.15            !! Freezing point (K)
+  REAL(r_std), PARAMETER :: tp_00 = 273.15                  !! 0 degre Celsius in degre Kelvin (K)
+  REAL(r_std), PARAMETER :: chalsu0 = 2.8345E06             !! Latent heat of sublimation (J.kg^{-1})
+  REAL(r_std), PARAMETER :: chalev0 = 2.5008E06             !! Latent heat of evaporation (J.kg^{-1}) 
+  REAL(r_std), PARAMETER :: chalfu0 = chalsu0-chalev0       !! Latent heat of fusion (J.kg^{-1}) 
+  REAL(r_std), PARAMETER :: c_stefan = 5.6697E-8            !! Stefan-Boltzman constant (W.m^{-2}.K^{-4})
+  REAL(r_std), PARAMETER :: cp_air = 1004.675               !! Specific heat of dry air (J.kg^{-1}.K^{-1}) 
+  REAL(r_std), PARAMETER :: cte_molr = 287.05               !! Specific constant of dry air (kg.mol^{-1}) 
+  REAL(r_std), PARAMETER :: kappa = cte_molr/cp_air         !! Kappa : ratio between specific constant and specific heat 
+                                                            !! of dry air (unitless)
+  REAL(r_std), PARAMETER :: msmlr_air = 28.964E-03          !! Molecular weight of dry air (kg.mol^{-1})
+  REAL(r_std), PARAMETER :: msmlr_h2o = 18.02E-03           !! Molecular weight of water vapor (kg.mol^{-1}) 
+  REAL(r_std), PARAMETER :: cp_h2o = &                      !! Specific heat of water vapor (J.kg^{-1}.K^{-1}) 
+       & cp_air*(quatre*msmlr_air)/( 3.5_r_std*msmlr_h2o) 
+  REAL(r_std), PARAMETER :: cte_molr_h2o = cte_molr/quatre  !! Specific constant of water vapor (J.kg^{-1}.K^{-1}) 
+  REAL(r_std), PARAMETER :: retv = msmlr_air/msmlr_h2o-un   !! Ratio between molecular weight of dry air and water 
+                                                            !! vapor minus 1(unitless)  
+  REAL(r_std), PARAMETER :: rvtmp2 = cp_h2o/cp_air-un       !! Ratio between specific heat of water vapor and dry air
+                                                            !! minus 1 (unitless)
+  REAL(r_std), PARAMETER :: rho_h2o= 0.9991_r_std           !! Density of water at 15Â°C (g cm-3)                       
+  REAL(r_std), PARAMETER :: cepdu2 = (0.1_r_std)**2         !! Squared wind shear (m^2.s^{-2}) 
+  REAL(r_std), PARAMETER :: ct_karman = 0.35_r_std          !! Van Karmann Constant (unitless)
+  REAL(r_std), PARAMETER :: cte_grav = 9.80665_r_std        !! Acceleration of the gravity (m.s^{-2})
+  REAL(r_std), PARAMETER :: pa_par_hpa = 100._r_std         !! Transform pascal into hectopascal (unitless)
+  REAL(r_std), PARAMETER :: RR = 8.314                      !! Ideal gasconstant (J.mol^{-1}.K^{-1})
+  REAL(r_std), PARAMETER :: Sct = 1370.                     !! Solar constant (W.m^{-2}) 
+
+
+  !-
+  ! 3. Climatic constants
+  !-
+  !! Constantes of the Louis scheme 
+  REAL(r_std), PARAMETER :: cb = 5._r_std         !! Constant of the Louis scheme (unitless);
+                                                  !! reference to Louis (1979)
+  REAL(r_std), PARAMETER :: cc = 5._r_std         !! Constant of the Louis scheme (unitless);
+                                                  !! reference to Louis (1979)
+  REAL(r_std), PARAMETER :: cd = 5._r_std         !! Constant of the Louis scheme (unitless);
+                                                  !! reference to Louis (1979)
+  !-
+  REAL(r_std), PARAMETER :: rayt_cste = 125.      !! Constant in the computation of surface resistance (W.m^{-2})
+  REAL(r_std), PARAMETER :: defc_plus = 23.E-3    !! Constant in the computation of surface resistance (K.W^{-1})
+  REAL(r_std), PARAMETER :: defc_mult = 1.5       !! Constant in the computation of surface resistance (K.W^{-1})
+
+  !-
+  ! 4. Soil thermodynamics constants
+  !-
+  ! Look at constantes_soil.f90
+
+
+  !-
+  ! 5. Unit convertions
+  !-
+  REAL(r_std), PARAMETER :: ha_to_m2 = 0.0001       !! Conversion from hectares (forestry) to m2 (rest of the code)
+  REAL(r_std), PARAMETER :: m2_to_ha = 10000.       !! Conversion from m2 to hectares
+  REAL(r_std), PARAMETER :: m_to_cm = 100.          !! Conversion from m to cm
+  REAL(r_std), PARAMETER :: peta_to_unit = 1.0E15   !! Convert Peta to unit
+  REAL(r_std), PARAMETER :: tera_to_unit = 1.0E12   !! Convert Tera to unit 
+  REAL(r_std), PARAMETER :: giga_to_unit = 1.0E09   !! Convert Giga to unit
+  REAL(r_std), PARAMETER :: mega_to_unit = 1.0E06   !! Convert Mega to unit
+  REAL(r_std), PARAMETER :: kilo_to_unit = 1.0E03   !! Convert Kilo to unit
+  REAL(r_std), PARAMETER :: centi_to_unit = 1.0E02  !! Convert centi to unit
+  REAL(r_std), PARAMETER :: milli_to_unit = 1.0E-03 !! Convert milli to unit
+  REAL(r_std), PARAMETER :: carbon_to_kilo = 2.0E-03!! Convert g carbon to kilo biomass
+
+  !
+  ! OPTIONAL PARTS OF THE MODEL
+  !
+  LOGICAL, SAVE     :: long_print = .false.       !! To set for more printing
+!$OMP THREADPRIVATE(long_print)
+  LOGICAL,PARAMETER :: diag_qsat = .TRUE.         !! One of the most frequent problems is a temperature out of range
+                                                  !! we provide here a way to catch that in the calling procedure. 
+                                                  !! (from Jan Polcher)(true/false) 
+  LOGICAL, SAVE     :: almaoutput                 !! Selects the type of output for the model.(true/false)
+                                                  !! Value is read from run.def in intersurf_history
+!$OMP THREADPRIVATE(almaoutput)
+
+  !
+  ! DIVERSE
+  !
+  CHARACTER(LEN=100), SAVE :: stomate_forcing_name='NONE'  !! NV080800 Name of STOMATE forcing file (unitless)
+                                                           ! Compatibility with Nicolas Viovy driver.
+!$OMP THREADPRIVATE(stomate_forcing_name)
+  CHARACTER(LEN=100), SAVE :: stomate_Cforcing_name='NONE' !! NV080800 Name of soil forcing file (unitless)
+                                                           ! Compatibility with Nicolas Viovy driver.
+!$OMP THREADPRIVATE(stomate_Cforcing_name)
+  INTEGER(i_std), SAVE :: forcing_id                 !! Index of the forcing file (unitless)
+!$OMP THREADPRIVATE(forcing_id)
+
+
+
+
+                         !------------------------!
+                         !  SECHIBA PARAMETERS    !
+                         !------------------------!
+ 
+
+  !
+  ! GLOBAL PARAMETERS   
+  !
+  REAL(r_std), SAVE :: min_wind = 0.1      !! The minimum wind (m.s^{-1})
+!$OMP THREADPRIVATE(min_wind)
+  REAL(r_std), SAVE :: snowcri = 1.5       !! Sets the amount above which only sublimation occures (kg.m^{-2})
+!$OMP THREADPRIVATE(snowcri)
+  INTEGER(i_std), SAVE        :: jnlvls = 1                                 !! Number of levels in the multilayer energy budget scheme
+
+  !
+  ! FLAGS ACTIVATING SUB-MODELS
+  !
+! +++CHECK+++
+! Logical flags that affect the flow of the code should 
+! be stored in the control-structure
+
+!!$ Moved to control-structure!!$ Moved to control-structure
+!!$  LOGICAL, SAVE :: ok_herbivores = .FALSE.     !! flag to activate herbivores (true/false)
+!!$ !$OMP THREADPRIVATE(ok_herbivores)
+!!$  LOGICAL, SAVE :: lpj_gap_const_mort = .TRUE. !! constant moratlity (true/false)
+!!$ !$OMP THREADPRIVATE(lpj_gap_const_mort)
+!!$  LOGICAL, SAVE :: lcchange = .FALSE.      !! Land cover change flag (true/false)
+!!$ !$OMP THREADPRIVATE(lcchange)
+!!$ LOGICAL, SAVE :: harvest_agri = .TRUE.       !! flag to harvest aboveground biomass from agricultural PFTs)(true/false)
+!!$ !$OMP THREADPRIVATE(harvest_agri)
+
+  LOGICAL, SAVE :: treat_expansion = .FALSE.   !! Do we treat PFT expansion across a grid point after introduction? (true/false)
+!$OMP THREADPRIVATE(treat_expansion)
+  LOGICAL, SAVE :: disable_fire = .FALSE.      !! flag that disable fire (true/false)
+!$OMP THREADPRIVATE(disable_fire)
+  LOGICAL, SAVE :: spinup_analytic = .FALSE.   !! Flag to activate analytical resolution for spinup (true/false)
+!$OMP THREADPRIVATE(spinup_analytic)
+
+  !
+  ! CONFIGURATION VEGETATION
+  !
+  LOGICAL, SAVE :: agriculture = .TRUE.    !! allow agricultural PFTs (true/false)
+!$OMP THREADPRIVATE(agriculture)
+  LOGICAL, SAVE :: impveg = .FALSE.        !! Impose vegetation ? (true/false)
+!$OMP THREADPRIVATE(impveg)
+  LOGICAL, SAVE :: impsoilt = .FALSE.      !! Impose soil ? (true/false)
+!$OMP THREADPRIVATE(impsoilt)
+  LOGICAL, SAVE :: read_lai = .FALSE.      !! Flag to read a map of LAI if STOMATE is not activated (true/false)
+!$OMP THREADPRIVATE(read_lai)
+  LOGICAL, SAVE :: old_lai = .FALSE.       !! Flag for the old LAI map interpolation (SHOULD BE DROPED ??)(true/false)
+!$OMP THREADPRIVATE(old_lai)
+  LOGICAL, SAVE :: old_veget = .FALSE.     !! Flag to use the old vegetation Map interpolation (SHOULD BE DROPED ?)(true/false)
+!$OMP THREADPRIVATE(old_veget)
+  LOGICAL, SAVE :: land_use = .TRUE.       !! flag to account or not for Land Use  (true/false)
+!$OMP THREADPRIVATE(land_use)
+  LOGICAL, SAVE :: veget_reinit = .TRUE.   !! To change LAND USE file in a run. (true/false)
+!$OMP THREADPRIVATE(veget_reinit)
+! +++++++++++
+
+  !
+  ! PARAMETERS USED BY BOTH HYDROLOGY MODELS
+  !
+  REAL(r_std), SAVE :: max_snow_age = 50._r_std !! Maximum period of snow aging (days)
+!$OMP THREADPRIVATE(max_snow_age)
+  REAL(r_std), SAVE :: snow_trans = 0.3_r_std   !! Transformation time constant for snow (m), reduced from the value 0.3 (04/07/2016) tzjwb
+!$OMP THREADPRIVATE(snow_trans)
+  REAL(r_std), SAVE :: sneige                   !! Lower limit of snow amount (kg.m^{-2})
+!$OMP THREADPRIVATE(sneige)
+  REAL(r_std), SAVE :: maxmass_glacier = 3000.  !! The maximum mass of a glacier (kg.m^{-2})
+!$OMP THREADPRIVATE(maxmass_glacier)
+! tzjwb
+  REAL(r_std), SAVE :: maxmass_snow = 3000.  !! The maximum mass of a snow (kg.m^{-2})
+!$OMP THREADPRIVATE(maxmass_snow)
+  REAL(r_std), SAVE :: vpd_k1 = 1
+  REAL(r_std), SAVE :: vpd_b1 = 0
+  REAL(r_std), SAVE :: ra_max = 1.e-4
+  REAL(r_std), SAVE :: maint_var=2.5 
+  REAL(r_std), SAVE :: cut_limit=0.8
+  REAL(r_std), SAVE :: psileaf_fac=1.0
+  REAL(r_std), SAVE :: psiroot_fac=1.0
+  REAL(r_std), SAVE :: rec_factor=1.0
+  REAL(r_std), SAVE :: day_threshold = 20
+  REAL(r_std), SAVE :: vertical_limit=1
+  REAL(r_std), SAVE :: minpsi=-3.0
+  REAL(r_std), SAVE :: relax_counter = 0
+  REAL(r_std), SAVE :: psi_soil_min = -3
+  REAL(r_std), SAVE :: plc_threshold = 50
+  REAL(r_std), SAVE :: min_kfactroot = 1.3
+  REAL(r_std), SAVE :: coef_max_drain = 0.8 
+  REAL(r_std), SAVE :: yyt_flag_mortality=1
+  REAL(r_std), SAVE :: nicolas_solution=0
+  REAL(r_std), SAVE :: pres_kfact=0
+  REAL(r_std), SAVE :: pres_soil_potential_min = -2.5
+  REAL(r_std), SAVE :: supply_flag=1
+  REAL(r_std), SAVE :: precip_bias_correct=1
+  REAL(r_std), SAVE :: st_cut_fac=3.0
+  REAL(r_std), SAVE :: pleaf_k=-1.46
+  REAL(r_std), SAVE :: pleaf_b=-1.738
+  REAL(r_std), SAVE :: proot_k=-1.67
+  REAL(r_std), SAVE :: proot_b=0.33
+  REAL(r_std), SAVE :: hum_leaf=0.05
+  REAL(r_std), SAVE :: hum_root=0.05
+  REAL(r_std), SAVE :: hum_plc=5
+  !! Heat capacity
+  REAL(r_std), PARAMETER :: capa_ice = 2.228*1.E3       !! Heat capacity of ice (J/kg/K)
+  REAL(r_std), SAVE      :: so_capa_ice                 !! Heat capacity of saturated frozen soil (J/K/m3)
+!$OMP THREADPRIVATE(so_capa_ice)
+  REAL(r_std), PARAMETER :: rho_water = 1000.           !! Density of water (kg/m3)
+  REAL(r_std), PARAMETER :: rho_ice = 920.              !! Density of ice (kg/m3)
+
+  !! Thermal conductivities
+  REAL(r_std), PARAMETER :: cond_water = 0.6            !! Thermal conductivity of liquid water (W/m/K)
+  REAL(r_std), PARAMETER :: cond_ice = 2.2              !! Thermal conductivity of ice (W/m/K)
+  REAL(r_std), PARAMETER :: cond_solid = 2.32           !! Thermal conductivity of mineral soil particles (W/m/K)
+
+  !! Time constant of long-term soil humidity (s) 
+  REAL(r_std), PARAMETER :: lhf = 0.3336*1.E6           !! Latent heat of fusion (J/kg)
+
+  INTEGER(i_std), PARAMETER :: nsnow=3                  !! Number of levels in the snow for explicit snow scheme   
+  REAL(r_std), PARAMETER    :: XMD    = 28.9644E-3 
+  REAL(r_std), PARAMETER    :: XBOLTZ      = 1.380658E-23 
+  REAL(r_std), PARAMETER    :: XAVOGADRO   = 6.0221367E+23 
+  REAL(r_std), PARAMETER    :: XRD    = XAVOGADRO * XBOLTZ / XMD 
+  REAL(r_std), PARAMETER    :: XCPD   = 7.* XRD /2. 
+  REAL(r_std), PARAMETER    :: phigeoth = 0.057 ! 0. DKtest 
+  REAL(r_std), PARAMETER    :: thick_min_snow = .01 
+
+  !! The maximum snow density and water holding characterisicts 
+  REAL(r_std), SAVE         :: xrhosmax = 750.  ! (kg m-3) 
+  REAL(r_std), SAVE         :: xwsnowholdmax1   = 0.03  ! (-) 
+  REAL(r_std), SAVE         :: xwsnowholdmax2   = 0.10  ! (-) 
+  REAL(r_std), SAVE         :: xsnowrhohold     = 200.0 ! (kg/m3) 
+  REAL(r_std), SAVE         :: xrhosmin = 50. 
+  REAL(r_std), PARAMETER    :: xci = 2.106e+3 
+  REAL(r_std), PARAMETER    :: xrv = 6.0221367e+23 * 1.380658e-23 /18.0153e-3 
+
+  !! ISBA-ES Critical snow depth at which snow grid thicknesses constant 
+  REAL(r_std), PARAMETER    :: xsnowcritd = 0.03  ! (m) 
+
+  !! The threshold of snow depth used for preventing numerical problem in thermal calculations
+  REAL(r_std), PARAMETER    :: snowcritd_thermal = 0.01  ! (m)  
+  
+  !! ISBA-ES CROCUS (Pahaut 1976): snowfall density coefficients: 
+  REAL(r_std), PARAMETER       :: snowfall_a_sn = 109.0  !! (kg/m3) 
+  REAL(r_std), PARAMETER       :: snowfall_b_sn =   6.0  !! (kg/m3/K) 
+  REAL(r_std), PARAMETER       :: snowfall_c_sn =  26.0  !! [kg/(m7/2 s1/2)] 
+
+  REAL(r_std), PARAMETER       :: dgrain_new_max=  2.0e-4!! (m) : Maximum grain size of new snowfall 
+  
+  !! Used in explicitsnow to prevent numerical problems as snow becomes vanishingly thin. 
+  REAL(r_std), PARAMETER                :: psnowdzmin = .0001   ! m 
+  REAL(r_std), PARAMETER                :: xsnowdmin = .000001  ! m 
+
+  REAL(r_std), PARAMETER                :: ph2o = 1000.         !! Water density [kg/m3] 
+  
+  ! ISBA-ES Thermal conductivity coefficients from Anderson (1976): 
+  ! see Boone, Meteo-France/CNRM Note de Centre No. 70 (2002) 
+  REAL(r_std), SAVE                     :: ZSNOWTHRMCOND1 = 0.02    ! [W/m/K] 
+  REAL(r_std), SAVE                     :: ZSNOWTHRMCOND2 = 2.5E-6  ! [W m5/(kg2 K)] 
+  
+  ! ISBA-ES Thermal conductivity: Implicit vapor diffn effects 
+  ! (sig only for new snow OR high altitudes) 
+  ! from Sun et al. (1999): based on data from Jordan (1991) 
+  ! see Boone, Meteo-France/CNRM Note de Centre No. 70 (2002) 
+  ! 
+  REAL(r_std), SAVE                       :: ZSNOWTHRMCOND_AVAP  = -0.06023 ! (W/m/K) 
+  REAL(r_std), SAVE                       :: ZSNOWTHRMCOND_BVAP  = -2.5425  ! (W/m) 
+  REAL(r_std), SAVE                       :: ZSNOWTHRMCOND_CVAP  = -289.99  ! (K) 
+  
+  REAL(r_std),SAVE :: xansmax = 0.85      !! Maxmimum snow albedo
+  REAL(r_std),SAVE :: xansmin = 0.50      !! Miniumum snow albedo
+  REAL(r_std),SAVE :: xans_todry = 0.008  !! Albedo decay rate for dry snow
+  REAL(r_std),SAVE :: xans_t = 0.240      !! Albedo decay rate for wet snow
+
+  ! ISBA-ES Thermal conductivity coefficients from Anderson (1976):
+  ! see Boone, Meteo-France/CNRM Note de Centre No. 70 (2002)
+  REAL(r_std), PARAMETER                  :: XP00 = 1.E5
+
+  ! ISBA-ES Thermal conductivity: Implicit vapor diffn effects
+  ! (sig only for new snow OR high altitudes)
+  ! from Sun et al. (1999): based on data from Jordan (1991)
+  ! see Boone, Meteo-France/CNRM Note de Centre No. 70 (2002)
+  !
+  REAL(r_std), SAVE          :: ZSNOWCMPCT_RHOD  = 150.0        !! (kg/m3)
+  REAL(r_std), SAVE          :: ZSNOWCMPCT_ACM   = 2.8e-6       !! (1/s)
+  REAL(r_std), SAVE          :: ZSNOWCMPCT_BCM   = 0.04         !! (1/K) 
+  REAL(r_std), SAVE          :: ZSNOWCMPCT_CCM   = 460.         !! (m3/kg)
+  REAL(r_std), SAVE          :: ZSNOWCMPCT_V0    = 3.7e7        !! (Pa/s) 
+  REAL(r_std), SAVE          :: ZSNOWCMPCT_VT    = 0.081        !! (1/K)
+  REAL(r_std), SAVE          :: ZSNOWCMPCT_VR    = 0.018        !! (m3/kg)
+  !
+  ! PARAMETERS USED BY ALBEDO
+  !
+  CHARACTER(LEN=30), SAVE                 :: albedo_type          !! This stores the type of albedo we are using
+!$OMP THREADPRIVATE(albedo_type)
+  LOGICAL, SAVE                           :: do_new_snow_albedo   !! If true, we use the snow albedo of CLM3 which 
+                                                                  !! distinguishes between diffuse, direct, NIR, and VIS
+!$OMP THREADPRIVATE(do_new_snow_albedo)
+  INTEGER(i_std), PARAMETER               :: nlevels = 1          !! Number of levels in the canopy used in the albedo 
+                                                                  !! calculation and the energy budget for the Pinty
+                                                                  !! two-stream model
+!$OMP THREADPRIVATE(nlevels)
+
+  INTEGER(i_std), SAVE                    :: nlevels_photo        !! Number of levels in the canopy used in the photosynthesis
+                                                                  !! routine per level dictacted by nlevels.  For example, if
+                                                                  !! if nlevels = 2 and nlevels_photo = 3, the photosynthesis
+                                                                  !! will be calculated for 2*3=6 total levels.
+!$OMP THREADPRIVATE(nlevels_photo)
+  INTEGER(i_std), SAVE                    :: nlevels_tot          !! Total number of levels, including photosythensis and energy
+!$OMP THREADPRIVATE(nlevels_tot)
+
+  INTEGER(i_std), SAVE                    :: nlev_top             !! Maximum number of canopy levels that are used to construct the "top"
+                                                                  !! layer of the canopy. The top layer is used in the calculation
+                                                                  !! transpiration.
+!$OMP THREADPRIVATE(nlev_top) 
+
+!  REAL(r_std), PARAMETER, DIMENSION (nlevels)    :: z_level = (/ 0.0, 0.5, 1.0, 1.5, 2.0, 2.5, 3.0, 3.5, 4.0, 4.5/)                                              !! The height of the bottom of each canopy layer
+  REAL(r_std), PARAMETER, DIMENSION (nlevels)    :: z_level = (/ 0.0 /)                                              !! The height of the bottom of each canopy layer
+!  REAL(r_std), PARAMETER, DIMENSION (nlevels)    :: z_level = (/ 0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0/)                                              !! The height of the bottom of each canopy layer
+                                                                     !! @tex $(m)$ @endtex
+!$OMP THREADPRIVATE(z_level)
+
+  ! Parameters for the albedo optimization, only used with Pinty's scheme and more than one layer
+  ! These are all somewhat arbitrary
+  !
+  REAL(r_std), SAVE                       ::  step_size_min       !! the value of the optimization step size below which
+                                                                  !! we give up and say it will not converge
+!$OMP THREADPRIVATE(step_size_min)
+  REAL(r_std), SAVE                       ::  step_size_scale     !! the scale factor of the optimization step size
+!$OMP THREADPRIVATE(step_size_scale)
+  REAL(r_std), SAVE                       ::  converged_limit     !! the value of the optimization function below which
+                                                                  !! the optimization is deemed converged
+!$OMP THREADPRIVATE(converged_limit)
+  INTEGER(i_std), SAVE                    ::  max_steps           !! the maximum number of optimization steps we try
+!$OMP THREADPRIVATE(max_steps)
+
+  !
+  ! Parameters for determining the effective LAI for use in Pinty's albedo scheme
+  !
+  REAL(r_std), SAVE                       ::  laieff_solar_angle  !! the zenith angle of the sun which determines our effective LAI
+                                                                  !! Pinty et al recommend a value of 60 degrees for this regadless of the true
+                                                                  !! solar zenith angle
+!$OMP THREADPRIVATE(laieff_solar_angle)
+  REAL(r_std), SAVE                       ::  laieff_zero_cutoff   ! an arbitrary cutoff to prevent too low of values from being passed to
+                                                                  ! routines in the calculation of the effective LAI
+!$OMP THREADPRIVATE(laieff_zero_cutoff)
+  INTEGER(i_std),PARAMETER                :: ndist_types=6       ! the number of distributions we need in the LAI effective routines
+  INTEGER(i_std),PARAMETER                :: iheight=1         ! the tree height distribution
+  INTEGER(i_std),PARAMETER                :: idiameter=2       ! the trunk diameter distribution
+  INTEGER(i_std),PARAMETER                :: icnvol=3          ! the crown volume distribution
+  INTEGER(i_std),PARAMETER                :: icnarea=4         ! the crown area distribution
+  INTEGER(i_std),PARAMETER                :: icndiaver=5       ! the verticle crown diameter distribution
+  INTEGER(i_std),PARAMETER                :: icndiahor=6       ! the horizontal crown diameter distribution
+
+!+++++ DEBUG ++++
+  REAL(r_std), SAVE                       ::  laieff_set_value_upper
+!$OMP THREADPRIVATE(laieff_set_value_upper)
+  REAL(r_std), SAVE                       ::  laieff_set_value_lower
+!$OMP THREADPRIVATE(laieff_set_value_lower)
+  REAL(r_std), SAVE                       ::  laieff_theta
+!$OMP THREADPRIVATE(laieff_theta)
+  ! These flags are all related to debugging.
+  LOGICAL,PARAMETER                       :: ld_warn=.FALSE.      ! a flag to turn on various warnings 
+  LOGICAL,PARAMETER                       :: ld_stop=.FALSE.      ! a flag to turn on some stop statements.
+                                                                  ! Right now these are in allocation, and
+                                                                  ! some of them were deemed to be
+                                                                  ! not necessary to kill the code.
+  LOGICAL,PARAMETER                       :: ld_forestry=.FALSE.  ! a flag to turn on debug statements
+                                                                  ! related to forestry
+  LOGICAL,PARAMETER                       :: ld_biomass=.FALSE.   ! a flag to turn on debug statements
+                                                                  ! related to biomass
+  LOGICAL,PARAMETER                       :: ld_albedo=.FALSE.    ! a flag to turn on debug statements
+                                                                  ! related to albedo
+  LOGICAL,PARAMETER                       :: ld_alloc=.FALSE.     ! a flag to turn on debug statements 
+                                                                  ! in functional allocation
+  LOGICAL,PARAMETER                       :: ld_trnov=.FALSE.     ! a flag to turn on debug statements
+                                                                  ! in turnover prognostic
+  LOGICAL,PARAMETER                       :: ld_lcc=.FALSE.       ! a flag to turn on debug statements
+                                                                  ! in function land cover
+  LOGICAL,PARAMETER                       :: ld_laieff=.FALSE.     ! a flag to turn on debug statements
+                                                                  ! related to effective LAI
+  LOGICAL,PARAMETER                       :: ld_massbal=.FALSE.   ! a flag to turn on debug statements
+                                                                  ! related to mass balance closure
+  LOGICAL,PARAMETER                       :: ld_hydrolarch=.FALSE.! a flag to turn on debug statements
+  LOGICAL,PARAMETER                       :: ld_vmax=.FALSE.      ! a flag to turn on debug statements
+  LOGICAL,PARAMETER                       :: ld_photo=.FALSE.     ! a flag to turn on debug statements
+                                                                  ! in photosynthesis
+  LOGICAL,PARAMETER                       :: ld_gstest=.FALSE.    ! a temperal flage to write gs/rveget
+  LOGICAL,PARAMETER                       :: ld_pheno=.FALSE.     ! a flag to turn on debug statements
+                                                                  ! in phenology 
+  LOGICAL,PARAMETER                       :: ld_presc=.FALSE.     ! a flag to turn on debug statements
+                                                                  ! in prescribe
+  LOGICAL,PARAMETER                       :: ld_enerbil=.FALSE.   ! a flag to turn on debug statements
+                                                                  ! in the energy budget
+  LOGICAL,PARAMETER                       :: ld_coupled=.FALSE.   ! a flag to turn on debug statements
+                                                                  ! in the coupling
+  LOGICAL,PARAMETER                       :: ld_kill=.FALSE.      ! a flag to turn on debug statements
+                                                                  ! related to plant mortality
+  LOGICAL,PARAMETER                       :: ld_agec=.FALSE.      ! a flag to turn on debug statements
+                                                                  ! related to age classes
+  LOGICAL,PARAMETER                       :: ld_date=.FALSE.      ! writes time stamp to output file
+                                                                  ! used in stomate
+  LOGICAL,PARAMETER                       :: ld_wstress=.FALSE.   ! a flag to turn on relevant write 
+                                                                  ! to debug the waterstress calculated
+                                                                  ! in sechiba and used in stomate
+                                                                  
+  LOGICAL,PARAMETER                       :: ld_fake_height=.FALSE.  ! a flag to turn on the statements
+                                                                     ! related to impose LAI and adjust the canopy 
+                                                                     ! stucture by adjusting tree heigh in each CIRC class  
+  ! JR flags
+  !+++CHECK+++
+  !If this flag really does what the comment text is saying 
+  ! it should be defined in intersurf as an ok% flag because
+  ! it strongly affects the flow of the model
+  LOGICAL,PARAMETER                       :: jr_enerbil = .TRUE.    ! set this to TRUE to activate the new
+                                                                    !  energy budget code
+  !+++++++++++
+  LOGICAL,PARAMETER                       :: james_write = .FALSE.  ! toggle for the write statements within
+                                                                    !  enerbil
+
+!+++++++++
+
+  !
+  ! Hydraulic architecture
+  !
+  REAL(r_std), SAVE, DIMENSION(2)         :: a_viscosity = (/0.556, 0.022/) !! Empirical parameters to adjust the resistance of fine
+                                                                            !! root and sapwood to the temperature dependency of the
+                                                                            !! viscosity of water Cochard et al 2000
+!$OMP THREADPRIVATE(a_viscosity)
+ 
+
+  !
+  ! BVOC : Biogenic activity  for each age class
+  !
+  REAL(r_std), SAVE, DIMENSION(nleafages) :: iso_activity = (/0.5, 1.5, 1.5, 0.5/)     !! Biogenic activity for each 
+                                                                                       !! age class : isoprene (unitless)
+!$OMP THREADPRIVATE(iso_activity)
+  REAL(r_std), SAVE, DIMENSION(nleafages) :: methanol_activity = (/1., 1., 0.5, 0.5/)  !! Biogenic activity for each
+                                                                                       !! age class : methanol (unnitless)
+!$OMP THREADPRIVATE(methanol_activity)
+
+  !
+  ! condveg.f90
+  !
+
+  ! 1. Scalar
+
+  ! 1.1 Flags used inside the module
+
+  LOGICAL, SAVE :: alb_bare_model = .FALSE. !! Switch for choosing values of bare soil 
+                                            !! albedo (see header of subroutine)
+                                            !! (true/false)
+!$OMP THREADPRIVATE(alb_bare_model)
+  LOGICAL, SAVE :: impaze = .FALSE.         !! Switch for choosing surface parameters
+                                            !! (see header of subroutine).  
+                                            !! (true/false)
+!$OMP THREADPRIVATE(impaze)
+  LOGICAL, SAVE :: z0cdrag_ave = .TRUE.     !! Chooses between two methods to calculate the 
+                                            !! grid average of the roughness (see header of subroutine)   
+                                            !! (true/false)
+!$OMP THREADPRIVATE(z0cdrag_ave)
+  ! 1.2 Others 
+
+  REAL(r_std), SAVE :: z0_over_height = un/16.           !! Factor to calculate roughness height from 
+                                                         !! vegetation height (unitless)   
+!$OMP THREADPRIVATE(z0_over_height)
+  REAL(r_std), SAVE :: height_displacement = 0.75        !! Factor to calculate the zero-plane displacement
+                                                         !! height from vegetation height (m)
+!$OMP THREADPRIVATE(height_displacement)
+  REAL(r_std), SAVE :: z0_bare = 0.01                    !! bare soil roughness length (m)
+!$OMP THREADPRIVATE(z0_bare)
+  REAL(r_std), SAVE :: z0_ice = 0.001                    !! ice roughness length (m)
+!$OMP THREADPRIVATE(z0_ice)
+  REAL(r_std), SAVE :: tcst_snowa = 5.0                  !! Time constant of the albedo decay of snow (days)
+!$OMP THREADPRIVATE(tcst_snowa)
+  REAL(r_std), SAVE :: snowcri_alb = 10.                 !! Critical value for computation of snow albedo (cm)
+!$OMP THREADPRIVATE(snowcri_alb)
+  REAL(r_std), SAVE :: fixed_snow_albedo = undef_sechiba !! To choose a fixed snow albedo value (unitless)
+!$OMP THREADPRIVATE(fixed_snow_albedo)
+  REAL(r_std), SAVE :: z0_scal = 0.15                    !! Surface roughness height imposed (m)
+!$OMP THREADPRIVATE(z0_scal)
+  REAL(r_std), SAVE :: roughheight_scal = zero           !! Effective roughness Height depending on zero-plane 
+                                                         !! displacement height (m) (imposed)
+!$OMP THREADPRIVATE(roughheight_scal)
+  REAL(r_std), SAVE :: emis_scal = 1.0                   !! Surface emissivity imposed (unitless)
+!$OMP THREADPRIVATE(emis_scal)
+  ! 2. Arrays
+
+  REAL(r_std), SAVE, DIMENSION(2) :: alb_deadleaf = (/ .12, .35/)    !! albedo of dead leaves, VIS+NIR (unitless)
+!$OMP THREADPRIVATE(alb_deadleaf)
+  REAL(r_std), SAVE, DIMENSION(2) :: alb_ice = (/ .60, .20/)         !! albedo of ice, VIS+NIR (unitless)
+!$OMP THREADPRIVATE(alb_ice)
+  REAL(r_std), SAVE, DIMENSION(2) :: albedo_scal = (/ 0.25, 0.25 /)  !! Albedo values for visible and near-infrared 
+                                                                     !! used imposed (unitless) 
+!$OMP THREADPRIVATE(albedo_scal)
+  REAL(r_std) , SAVE, DIMENSION(classnb) :: vis_dry = (/0.24,&
+       &0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.27/)  !! Soil albedo values to soil colour classification:
+                                                          !! dry soil albedo values in visible range
+!$OMP THREADPRIVATE(vis_dry)
+  REAL(r_std), SAVE, DIMENSION(classnb) :: nir_dry = (/0.48,&
+       &0.44, 0.40, 0.36, 0.32, 0.28, 0.24, 0.20, 0.55/)  !! Soil albedo values to soil colour classification:
+                                                          !! dry soil albedo values in near-infrared range 
+!$OMP THREADPRIVATE(nir_dry)
+  REAL(r_std), SAVE, DIMENSION(classnb) :: vis_wet = (/0.12,&
+       &0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05, 0.15/)  !! Soil albedo values to soil colour classification:
+                                                          !! wet soil albedo values in visible range 
+!$OMP THREADPRIVATE(vis_wet)
+  REAL(r_std), SAVE, DIMENSION(classnb) :: nir_wet = (/0.24,&
+       &0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.31/)  !! Soil albedo values to soil colour classification:
+                                                          !! wet soil albedo values in near-infrared range
+!$OMP THREADPRIVATE(nir_wet)
+  REAL(r_std), SAVE, DIMENSION(classnb) :: albsoil_vis = (/ &
+       &0.18, 0.16, 0.16, 0.15, 0.12, 0.105, 0.09, 0.075, 0.25/)   !! Soil albedo values to soil colour classification:
+                                                                   !! Averaged of wet and dry soil albedo values
+                                                                   !! in visible and near-infrared range
+!$OMP THREADPRIVATE(albsoil_vis) 
+  REAL(r_std), SAVE, DIMENSION(classnb) :: albsoil_nir = (/ &
+       &0.36, 0.34, 0.34, 0.33, 0.30, 0.25, 0.20, 0.15, 0.45/)  !! Soil albedo values to soil colour classification:
+                                                                !! Averaged of wet and dry soil albedo values
+                                                                !! in visible and near-infrared range
+!$OMP THREADPRIVATE(albsoil_nir)
+  REAL(r_std) :: alb_threshold = 0.0000000001_r_std      !! A threshold for the iteration of the
+                                                          !! multilevel albedo.  Could be externalised.
+                                                          !! Fairly arbitrary, although if a level has
+                                                          !! no LAI the absorption often ends up being
+                                                          !! equal to this value, so it should not
+                                                          !! be high.
+!$OMP THREADPRIVATE(alb_threshold)
+
+  !
+  ! diffuco.f90
+  !
+
+  ! 0. Constants
+
+  REAL(r_std), PARAMETER :: Tetens_1 = 0.622         !! Ratio between molecular weight of water vapor and molecular weight  
+                                                     !! of dry air (unitless)
+  REAL(r_std), PARAMETER :: Tetens_2 = 0.378         !!
+  REAL(r_std), PARAMETER :: ratio_H2O_to_CO2 = 1.6   !! Ratio of water vapor diffusivity to the CO2 diffusivity (unitless)
+  REAL(r_std), PARAMETER :: mmol_to_m_1 = 0.0244     !!
+  REAL(r_std), PARAMETER :: RG_to_PAR = 0.5          !!
+  REAL(r_std), PARAMETER :: W_to_mmol = 4.6          !! W_to_mmol * RG_to_PAR = 2.3
+
+  ! 1. Scalar
+
+  INTEGER(i_std), SAVE :: nlai = 20             !! Number of LAI levels (unitless)
+!$OMP THREADPRIVATE(nlai)
+  LOGICAL, SAVE :: ldq_cdrag_from_gcm = .FALSE. !! Set to .TRUE. if you want q_cdrag coming from GCM
+!$OMP THREADPRIVATE(ldq_cdrag_from_gcm)
+  REAL(r_std), SAVE :: laimax = 12.             !! Maximal LAI used for splitting LAI into N layers (m^2.m^{-2})
+!$OMP THREADPRIVATE(laimax)
+  LOGICAL, SAVE :: downregulation_co2 = .FALSE.            !! Set to .TRUE. if you want CO2 downregulation.
+!$OMP THREADPRIVATE(downregulation_co2)
+  REAL(r_std), SAVE :: downregulation_co2_baselevel = 280. !! CO2 base level (ppm)
+!$OMP THREADPRIVATE(downregulation_co2_baselevel)
+  LOGICAL, SAVE :: lscale_lcc_nobio = .FALSE.   !! Set to .TRUE. if you want to scale new land cover maps
+                                                !! (be careful with this.  Please check the documentation)
+!$OMP THREADPRIVATE(lscale_lcc_nobio)
+  LOGICAL, SAVE :: lignore_lcc_stops = .FALSE.  !! Set to .TRUE. if you want the code to keep running past
+                                                !! a few places in land cover change where it would ordinarily
+                                                !! stop.  Only use in very specific cases!
+!$OMP THREADPRIVATE(lignore_lcc_stops)
+
+  ! 3. Coefficients of equations
+
+  REAL(r_std), SAVE :: lai_level_depth = 0.15  !!
+!$OMP THREADPRIVATE(lai_level_depth)
+  REAL(r_std), SAVE, DIMENSION(6) :: dew_veg_poly_coeff = &            !! coefficients of the 5 degree polynomomial used
+  & (/ 0.887773, 0.205673, 0.110112, 0.014843,  0.000824,  0.000017 /) !! in the equation of coeff_dew_veg
+!$OMP THREADPRIVATE(dew_veg_poly_coeff)
+  REAL(r_std), SAVE               :: Oi=210000.    !! Intercellular oxygen partial pressure (ubar)
+!$OMP THREADPRIVATE(Oi)
+
+  !
+  ! slowproc.f90 
+  !
+
+  ! 1. Scalar
+
+  INTEGER(i_std), SAVE :: veget_year_orig = 0        !!  first year for landuse (number)
+!$OMP THREADPRIVATE(veget_year_orig)
+  REAL(r_std), SAVE :: clayfraction_default = 0.2    !! Default value for clay fraction (0-1, unitless)
+!$OMP THREADPRIVATE(clayfraction_default)
+  REAL(r_std), SAVE :: min_vegfrac = 0.001           !! Minimal fraction of mesh a vegetation type can occupy (0-1, unitless)
+!$OMP THREADPRIVATE(min_vegfrac)
+  REAL(r_std), SAVE :: frac_nobio_fixed_test_1 = 0.0 !! Value for frac_nobio for tests in 0-dim simulations (0-1, unitless)
+!$OMP THREADPRIVATE(frac_nobio_fixed_test_1)
+  
+  REAL(r_std), SAVE :: stempdiag_bid = 280.          !! only needed for an initial LAI if there is no restart file
+!$OMP THREADPRIVATE(stempdiag_bid)
+
+
+                           !-----------------------------!
+                           !  STOMATE AND LPJ PARAMETERS !
+                           !-----------------------------!
+
+
+  !
+  ! lpj_constraints.f90
+  !
+  
+  ! 1. Scalar
+
+  REAL(r_std), SAVE  :: too_long = 5.      !! longest sustainable time without 
+                                           !! regeneration (vernalization) (years)
+!$OMP THREADPRIVATE(too_long)
+
+
+  !
+  ! lpj_establish.f90
+  !
+
+  ! 1. Scalar
+
+  REAL(r_std), SAVE :: estab_max_tree = 0.12   !! Maximum tree establishment rate (0-1, unitless)
+!$OMP THREADPRIVATE(estab_max_tree)
+  REAL(r_std), SAVE :: estab_max_grass = 0.12  !! Maximum grass establishment rate (0-1, unitless)
+!$OMP THREADPRIVATE(estab_max_grass)
+  
+  ! 3. Coefficients of equations
+
+  REAL(r_std), SAVE :: establish_scal_fact = 5.  !!
+!$OMP THREADPRIVATE(establish_scal_fact)
+  REAL(r_std), SAVE :: max_tree_coverage = 0.98  !! (0-1, unitless)
+!$OMP THREADPRIVATE(max_tree_coverage)
+  REAL(r_std), SAVE :: ind_0_estab = 0.2         !! = ind_0 * 10.
+!$OMP THREADPRIVATE(ind_0_estab)
+
+
+  !
+  ! lpj_fire.f90
+  !
+
+  ! 1. Scalar
+
+  REAL(r_std), SAVE :: tau_fire = 30.           !! Time scale for memory of the fire index (days).
+!$OMP THREADPRIVATE(tau_fire)
+  REAL(r_std), SAVE :: litter_crit = 200.       !! Critical litter quantity for fire
+                                                !! below which iginitions extinguish 
+                                                !! @tex $(gC m^{-2})$ @endtex
+!$OMP THREADPRIVATE(litter_crit)
+  REAL(r_std), SAVE :: fire_resist_lignin = 0.5 !!
+!$OMP THREADPRIVATE(fire_resist_lignin)
+  ! 2. Arrays
+
+  REAL(r_std), SAVE, DIMENSION(nparts) :: co2frac = &    !! The fraction of the different biomass 
+       & (/ .95, .95, 0., 0.3, 0., 0., .95, .95, .95/)   !! compartments emitted to the atmosphere 
+!$OMP THREADPRIVATE(co2frac)                             !! when burned (unitless, 0-1)  
+
+  ! 3. Coefficients of equations
+
+  REAL(r_std), SAVE, DIMENSION(3) :: bcfrac_coeff = (/ .3,  1.3,  88.2 /)         !! (unitless)
+!$OMP THREADPRIVATE(bcfrac_coeff)
+  REAL(r_std), SAVE, DIMENSION(4) :: firefrac_coeff = (/ 0.45, 0.8, 0.6, 0.13 /)  !! (unitless)
+!$OMP THREADPRIVATE(firefrac_coeff)
+
+  !
+  ! lpj_gap.f90
+  !
+
+  ! 1. Scalar
+
+  REAL(r_std), SAVE :: ref_greff = 0.035         !! Asymptotic maximum mortality rate
+                                                 !! @tex $(year^{-1})$ @endtex
+!$OMP THREADPRIVATE(ref_greff)
+
+  ! 3. Coefficients of equations
+
+  REAL(r_std), SAVE :: availability_fact = 0.1   !!
+!$OMP THREADPRIVATE(availability_fact)
+
+  !               
+  ! lpj_light.f90 
+  !              
+
+  ! 1. Scalar
+  
+  LOGICAL, SAVE :: annual_increase = .TRUE. !! for diagnosis of fpc increase, compare today's fpc to last year's maximum (T) or
+                                            !! to fpc of last time step (F)? (true/false)
+!$OMP THREADPRIVATE(annual_increase)
+  REAL(r_std), SAVE :: min_cover = 0.05     !! For trees, minimum fraction of crown area occupied
+                                            !! (due to its branches etc.) (0-1, unitless)
+                                            !! This means that only a small fraction of its crown area
+                                            !! can be invaded by other trees.
+!$OMP THREADPRIVATE(min_cover)
+
+
+  !
+  ! lpj_pftinout.f90 
+  !
+
+  ! 1. Scalar
+
+  REAL(r_std), SAVE :: min_avail = 0.01         !! minimum availability
+!$OMP THREADPRIVATE(min_avail)
+  REAL(r_std), SAVE :: ind_0 = 0.02             !! initial density of individuals
+!$OMP THREADPRIVATE(ind_0)
+  ! 3. Coefficients of equations
+  
+  REAL(r_std), SAVE :: RIP_time_min = 1.25      !! test whether the PFT has been eliminated lately (years)
+!$OMP THREADPRIVATE(RIP_time_min)
+  REAL(r_std), SAVE :: npp_longterm_init = 10.  !! Initialisation value for npp_longterm (gC.m^{-2}.year^{-1})
+!$OMP THREADPRIVATE(npp_longterm_init)
+  REAL(r_std), SAVE :: everywhere_init = 0.05   !!
+!$OMP THREADPRIVATE(everywhere_init)
+
+
+  !
+  ! stomate_growth_res_lim.f90
+  !
+
+  ! 0. Constants
+
+  REAL(r_std), PARAMETER :: max_possible_lai = 10. !! (m^2.m^{-2})
+  REAL(r_std), PARAMETER :: Nlim_Q10 = 10.         !!
+
+  ! 1. Scalar
+
+  LOGICAL, SAVE :: ok_minres = .TRUE.              !! [DISPENSABLE] Do we try to reach a minimum reservoir even if
+                                                   !! we are severely stressed? (true/false)
+!$OMP THREADPRIVATE(ok_minres)
+  REAL(r_std), SAVE :: tau_leafinit = 10.          !! Time required to develop a minimal LAI
+                                                   !! using the carbohydrate reserve (days)
+!$OMP THREADPRIVATE(tau_leafinit)
+  REAL(r_std), SAVE :: reserve_time_tree = 30.     !! Maximum number of days during which
+                                                   !! carbohydrate reserve may be used for 
+                                                   !! trees (days)
+!$OMP THREADPRIVATE(reserve_time_tree)
+  REAL(r_std), SAVE :: reserve_time_grass = 20.    !! Maximum number of days during which
+                                                   !! carbohydrate reserve may be used for 
+                                                   !! grasses (days)
+!$OMP THREADPRIVATE(reserve_time_grass)
+
+  REAL(r_std), SAVE :: R0 = 0.3                    !! Default root allocation (0-1, unitless)
+!$OMP THREADPRIVATE(R0)
+
+  REAL(r_std), SAVE :: f_fruit = 0.1               !! Default fruit allocation (0-1, unitless)
+!$OMP THREADPRIVATE(f_fruit)
+  
+  REAL(r_std), SAVE :: alloc_sap_above_grass = 1.0 !! fraction of sapwood allocation above ground
+                                                   !! for grass (0-1, unitless)
+!$OMP THREADPRIVATE(alloc_sap_above_grass)
+  REAL(r_std), SAVE :: min_LtoLSR = 0.2            !! Prescribed lower bounds for leaf 
+                                                   !! allocation (0-1, unitless)
+!$OMP THREADPRIVATE(min_LtoLSR)
+  REAL(r_std), SAVE :: max_LtoLSR = 0.5            !! Prescribed upper bounds for leaf 
+                                                   !! allocation (0-1, unitless)
+!$OMP THREADPRIVATE(max_LtoLSR)
+  
+  REAL(r_std), SAVE :: z_nitrogen = 0.2            !! Curvature of the root profile (m)
+!$OMP THREADPRIVATE(z_nitrogen)
+  
+  REAL(r_std), SAVE :: tax_max = 0.8               !! Maximum fraction of allocatable biomass used 
+                                                   !! for maintenance respiration (0-1, unitless)
+!$OMP THREADPRIVATE(tax_max)
+
+  ! 3. Coefficients of equations
+
+!! Moved this to constantes_mtc
+!!  REAL(r_std), SAVE :: lai_max_to_happy = 0.5      !! share of the maximum lai required to sustain
+!!                                                   !! plant growth
+!!$OMP THREADPRIVATE(lai_max_to_happy)
+  
+  REAL(r_std), SAVE :: Nlim_tref = 25.             !! (C)
+!$OMP THREADPRIVATE(Nlim_tref)
+
+
+  !
+  ! stomate_growth_fun_all.f90
+  !
+  ! 1. Scalar  
+  INTEGER(i_std), SAVE :: ncirc                    !! Number of circumference classes used to calculate C allocation
+                                                   !! Used in prescribe.f90 and forestry.f90 - this mimics cohorts
+!$OMP THREADPRIVATE(ncirc)
+
+  INTEGER(i_std), SAVE :: nagec                    !! Number of age classes used to calculate C allocation
+                                                   !! Used in forestry.f90 and lcchange.f90 - this mimics age classes
+!$OMP THREADPRIVATE(nagec)
+  LOGICAL, SAVE :: lbypass_cc                      !! Set to true for a temporary patch of a known bug, though the underlying
+                                                   !! problem still must be fixed.
+!$OMP THREADPRIVATE(lbypass_cc)
+
+  REAL(r_std), SAVE :: min_water_stress = 0.1      !! Minimal value for wstress_fac (unitless, 0-1)
+!$OMP THREADPRIVATE(min_water_stress)
+
+  REAL(r_std), SAVE :: max_delta_KF = 0.1          !! Maximum change in KF from one time step to another (m)
+                                                   !! This is a bit arbitrary. 
+!$OMP THREADPRIVATE(max_delta_KF)
+
+  REAL(r_std), SAVE :: evergreen_reserve = 0.05    !! Fraction of sapwood mass stored in the reserve pool of evergreen 
+                                                   !! trees (unitless, 0-1) 
+!$OMP THREADPRIVATE(evergreen_reserve)
+
+  REAL(r_std), SAVE :: deciduous_reserve = 0.12    !! Fraction of sapwood mass stored in the reserve pool of deciduous 
+                                                   !! trees during the growing season (unitless, 0-1) 
+!$OMP THREADPRIVATE(deciduous_reserve)
+
+  REAL(r_std), SAVE :: senescense_reserve = 0.15   !! Fraction of sapwood mass stored in the reserve pool of deciduous 
+                                                   !! trees during senescense(unitless, 0-1) 
+!$OMP THREADPRIVATE(senescense_reserve)
+
+  REAL(r_std), SAVE :: labile_reserve = 60.        !! The lab_fac is divided by this value to obtain a new parameter
+                                                   !! This new parameter is a fraction that is multiplied with the plant
+                                                   !! biomass to obatin the optimal size of the labile pool. The dependency
+                                                   !! on lab_fac is a nice feature but the whole parameterization is arbitrary
+!$OMP THREADPRIVATE(labile_reserve)
+
+  REAL(r_std), SAVE :: maint_from_labile = 0.2     !! Maintenance respiration should be positive. In case it is 
+                                                   !! very low use ::maint_from_labile of the active labile carbon 
+                                                   !! pool (gC m-2 dt-1)
+!$OMP THREADPRIVATE(maint_from_labile)
+
+  REAL(r_std), SAVE :: maint_from_gpp = 0.8        !! Some carbon needs to remain to support the growth, hence, 
+                                                   !! respiration will be limited. In this case resp_maint 
+                                                   !! (gC m-2 dt-1) should not be more than 80% (::maint_from_gpp) 
+                                                   !! of the GPP (gC m-2 s-1)
+!$OMP THREADPRIVATE(maint_from_gpp)
+ 
+
+  REAL(r_std), SAVE :: sync_threshold = 0.0001     !! The threshold above which a warning is generated when the
+                                                   !! total biomass is being compared to the sum of circ_class_biomass
+!$OMP THREADPRIVATE(sync_threshold)
+
+  !
+  ! stomate_data.f90 
+  !
+
+  ! 1. Scalar 
+
+  ! 1.1 climatic parameters 
+
+  REAL(r_std), SAVE :: precip_crit = 100.        !! minimum precip, in (mm/year)
+!$OMP THREADPRIVATE(precip_crit)
+  REAL(r_std), SAVE :: gdd_crit_estab = 150.     !! minimum gdd for establishment of saplings
+!$OMP THREADPRIVATE(gdd_crit_estab)
+  REAL(r_std), SAVE :: fpc_crit = 0.95           !! critical fpc, needed for light competition and establishment (0-1, unitless)
+!$OMP THREADPRIVATE(fpc_crit)
+
+  ! 1.2 sapling characteristics
+
+  REAL(r_std), SAVE :: alpha_grass = 0.5         !! alpha coefficient for grasses (unitless)
+!$OMP THREADPRIVATE(alpha_grass)
+
+  REAL(r_std), SAVE :: alpha_tree = 1.           !! alpha coefficient for trees (unitless)
+!$OMP THREADPRIVATE(alpha_tree)
+
+!!$  REAL(r_std), SAVE :: tune_c0_alloc = 2.3e-4   !! This parameter was tuned such that the ratio between root carbon and LAI is 
+!!$                                                !! similar for grasses and trees. Only used for grasses and crops (thus NOT for 
+!!$                                                !! trees)(unitless)
+!!$!$OMP THREADPRIVATE(tune_c0_alloc)
+
+!!$  REAL(r_std), SAVE :: struct_to_leaves = 0.05  !! Fraction of structural carbon in grass and crops as a share of the leaf 
+!!$                                                !! carbon pool. Only used for grasses and crops (thus NOT for trees)
+!!$                                                !! (unitless)
+!!$!$OMP THREADPRIVATE(struct_to_leaves)
+
+  REAL(r_std), SAVE :: labile_to_total = 0.01   !! Fraction of the labile pool in trees, grasses and crops as a share of the
+                                                !! total carbon pool (accounting for the N-content of the different tissues).
+                                                !! (unitless)
+!$OMP THREADPRIVATE(labile_to_total)
+
+
+  ! 1.3  time scales for phenology and other processes (in days)
+
+  REAL(r_std), SAVE :: tau_hum_month = 20.               !! (days)       
+!$OMP THREADPRIVATE(tau_hum_month)
+  REAL(r_std), SAVE :: tau_hum_week = 7.                 !! (days)  
+!$OMP THREADPRIVATE(tau_hum_week)
+  REAL(r_std), SAVE :: tau_t2m_month = 20.               !! (days)      
+!$OMP THREADPRIVATE(tau_t2m_month)
+  REAL(r_std), SAVE :: tau_t2m_week = 7.                 !! (days)  
+!$OMP THREADPRIVATE(tau_t2m_week)
+  REAL(r_std), SAVE :: tau_tsoil_month = 20.             !! (days)     
+!$OMP THREADPRIVATE(tau_tsoil_month)
+  REAL(r_std), SAVE :: tau_soilhum_month = 20.           !! (days)     
+!$OMP THREADPRIVATE(tau_soilhum_month)
+  REAL(r_std), SAVE :: tau_gpp_week = 7.                 !! (days)  
+!$OMP THREADPRIVATE(tau_gpp_week)
+  REAL(r_std), SAVE :: tau_gdd = 40.                     !! (days)  
+!$OMP THREADPRIVATE(tau_gdd)
+  REAL(r_std), SAVE :: tau_ngd = 50.                     !! (days)  
+!$OMP THREADPRIVATE(tau_ngd)
+  REAL(r_std), SAVE :: coeff_tau_longterm = 3.           !! (unitless)
+!$OMP THREADPRIVATE(coeff_tau_longterm)
+  REAL(r_std), SAVE :: tau_longterm                      !! (days)  
+!$OMP THREADPRIVATE(tau_longterm)
+  REAL(r_std), SAVE :: tau_hum_growingseason_grass = 30. !! (days)  
+!$OMP THREADPRIVATE(tau_hum_growingseason_grass)
+
+  ! 3. Coefficients of equations
+
+  REAL(r_std), SAVE :: bm_sapl_carbres = 5.             !!
+!$OMP THREADPRIVATE(bm_sapl_carbres)
+  REAL(r_std), SAVE :: bm_sapl_sapabove = 0.5           !!
+!$OMP THREADPRIVATE(bm_sapl_sapabove)
+  REAL(r_std), SAVE :: bm_sapl_heartabove = 0.2         !! Stich et al 2003 has a value of 0.2 (2 is used in the trunk)
+!$OMP THREADPRIVATE(bm_sapl_heartabove)
+  REAL(r_std), SAVE :: bm_sapl_heartbelow = 0.2         !! Stich et al 2003 has a value of 0.2 (2 is used in the trunk
+!$OMP THREADPRIVATE(bm_sapl_heartbelow)
+  REAL(r_std), SAVE :: init_sapl_mass_leaf_nat = 0.1    !! LAI (m2 m-2) of a natural grassland at the time of its sewing. Similar to woody PFT's
+                                                        !! the model starts from small plants rather than seeds.
+!$OMP THREADPRIVATE(init_sapl_mass_leaf_nat)
+  REAL(r_std), SAVE :: init_sapl_mass_leaf_agri = 1.    !! LAI (m2 m-2) of a agricultural grassland at the time of its sewing. Similar to woody PFT's
+                                                        !! the model starts from small plants rather than seeds.
+!$OMP THREADPRIVATE(init_sapl_mass_leaf_agri)
+  REAL(r_std), SAVE :: init_sapl_mass_carbres = 5.      !!
+!$OMP THREADPRIVATE(init_sapl_mass_carbres)
+  REAL(r_std), SAVE :: init_sapl_mass_root = 0.1        !!
+!$OMP THREADPRIVATE(init_sapl_mass_root)
+  REAL(r_std), SAVE :: init_sapl_mass_fruit = 0.3       !!  
+!$OMP THREADPRIVATE(init_sapl_mass_fruit)
+  REAL(r_std), SAVE :: cn_sapl_init = 0.5               !!
+!$OMP THREADPRIVATE(cn_sapl_init)
+  REAL(r_std), SAVE :: migrate_tree = 10.*1.E3          !!
+!$OMP THREADPRIVATE(migrate_tree)
+  REAL(r_std), SAVE :: migrate_grass = 10.*1.E3         !!
+!$OMP THREADPRIVATE(migrate_grass)
+
+  REAL(r_std), SAVE :: lai_initmin_tree = 0.3           !! Minimum lai. If not available C is taken from the reserves to 
+                                                        !! grow a canopy in phenology
+!$OMP THREADPRIVATE(lai_initmin_tree)
+  REAL(r_std), SAVE :: lai_initmin_grass = 0.1          !!
+!$OMP THREADPRIVATE(lai_initmin_grass)
+
+  REAL(r_std), SAVE, DIMENSION(2) :: dia_coeff = (/ 4., 0.5 /)            !!
+!$OMP THREADPRIVATE(dia_coeff)
+  REAL(r_std), SAVE, DIMENSION(2) :: maxdia_coeff =(/ 100., 0.01/)        !!
+!$OMP THREADPRIVATE(maxdia_coeff)
+  REAL(r_std), SAVE, DIMENSION(4) :: bm_sapl_leaf = (/ 4., 4., 0.8, 5./)  !!
+!$OMP THREADPRIVATE(bm_sapl_leaf)
+
+  !
+  ! sapiens_forestry.f90
+  !
+  INTEGER(i_std), SAVE :: ndia_harvest                  !! The number of diameter classes used for 
+                                                        !! the wood harvest pools.
+!$OMP THREADPRIVATE(ndia_harvest) 
+  REAL(r_std), SAVE      :: rdi_limit_upper=1            !! The parameters for self-thinning and yield come
+                                                        !! from different data sets and are not necsassirly
+                                                        !! fully consistent. The forestry code was written
+                                                        !! such that it accounts for this consistency issue.
+                                                        !! However, we still need a parameter that gives
+                                                        !! us the upper_rdi_harvest in case the inconsistency
+                                                        !! occurs.
+!$OMP THREADPRIVATE(rdi_limit_upper)
+  REAL(r_std), SAVE      :: max_harvest_dia             !! The largest diameter for the harvest pools to
+                                                        !! keep track of harvested wood from forests.
+!$OMP THREADPRIVATE(max_harvest_dia)
+  INTEGER(i_std), SAVE   :: n_pai                       !! The number of years used for the cumulative
+                                                        !! averages of the periodic annual increment.                      
+!$OMP THREADPRIVATE(n_pai)
+  LOGICAL, SAVE          :: use_litter_raking           !! If TRUE, this flag will simulate litter raking in 
+                                                        !! in grid squares.  This has the effect of moving litter
+                                                        !! once a year from forest PFTs to agricultural PFTs, if they
+                                                        !! are present on this pixel.  If TRUE, you must also provide
+                                                        !! a map with the litter demand so we know how much litter
+                                                        !! to remove for each pixel.
+!$OMP THREADPRIVATE(use_litter_raking)
+  INTEGER(i_std), SAVE   :: management = 0              !! Use Diego Santarem's optimization for broadleaves
+!$OMP THREADPRIVATE(management)
+    LOGICAL, SAVE        :: fake                        !! The model run is fake model run: a given 
+                                                        !! deltavol is forced clear at the first 
+                                                        !! year (default = FALSE). !VB! Replace 
+                                                        !! "fake" by "pseudo" in the description 
+                                                        !! and in the code 
+!$OMP THREADPRIVATE(fake)
+    LOGICAL, SAVE        :: clearfirst                  !! Start model run with a clearcut (default 
+                                                        !! = TRUE). 
+!$OMP THREADPRIVATE(clearfirst)
+    INTEGER(i_std), SAVE :: early_cut                   !! Flag determining what happens when 
+                                                        !! density gets below dens_target (minima 
+                                                        !! density threshold, see 
+                                                        !! stomate_constants.f90): 0= nothing, 1 = 
+                                                        !! revert to orch-std when density gets 
+                                                        !! below minimal threshold, 2 = clearcut 
+                                                        !! when density gets below minimal 
+                                                        !! threshold 
+!$OMP THREADPRIVATE(early_cut)
+    INTEGER(i_std), SAVE :: itinerary                   !! Itinerary type for coppices: 1 = Popface 
+                                                        !! experiment (Liberloo 2006), 3*6 years, 2 
+                                                        !! = Orsay experiment (Pontailler 1999), 1 
+                                                        !! + 2*5 years 
+!$OMP THREADPRIVATE(itinerary)
+    INTEGER(i_std), SAVE :: age_target_def              !! Age at which clearcut occurs no matter 
+                                                        !! the density of the stand (years). This 
+                                                        !! parameter is read from the run.def file 
+                                                        !! (as others). According to Lanier (1994) 
+                                                        !! and Bottcher (2008), it should most 
+                                                        !! generally be between 100 and 200 years.
+!$OMP THREADPRIVATE(age_target_def)
+    INTEGER(i_std), SAVE :: ntrees_profit               !! The number of trees over which the average
+                                                        !! height is calculated to determine if the
+                                                        !! stand will be profitable to thin.
+!$OMP THREADPRIVATE(ntrees_profit)
+
+  INTEGER(i_std), SAVE   :: bavard_f                    !! If bavard_f=1, then a lot of "print", if 
+                                                        !! bavard_f=2, even more.
+!$OMP THREADPRIVATE(bavard_f)
+
+  ! Variations for sensitivity analysis
+
+  REAL(r_std), SAVE      :: ss_pipe_density = 1.        !! Sensitivity for pipe_density
+!$OMP THREADPRIVATE(ss_pipe_density)
+  REAL(r_std), SAVE      :: ss_selfth_curve = 1.        !! Sensitivity for selfth_curve
+!$OMP THREADPRIVATE(ss_selfth_curve)
+  REAL(r_std), SAVE      :: ss_sigma = 1.               !! Sensitivity for sigma
+!$OMP THREADPRIVATE(ss_sigma)
+  REAL(r_std), SAVE      :: ss_th_strat = 1.            !! Sensitivity for th_strat
+!$OMP THREADPRIVATE(ss_th_strat)
+  REAL(r_std), SAVE      :: ss_tau_spread = 1.          !! Sensitivity for tau_spread
+!$OMP THREADPRIVATE(ss_tau_spread)
+  REAL(r_std), SAVE      :: ss_lambda = 1.              !! Sensitivity for lambda
+!$OMP THREADPRIVATE(ss_lambda)
+  REAL(r_std), SAVE      :: ss_circ_bm = 1.             !! Sensitivity for circ_bm
+!$OMP THREADPRIVATE(ss_circ_bm)
+  REAL(r_std), SAVE      :: ss_height_circ = 1.         !! Sensitivity for height_circ
+!$OMP THREADPRIVATE(ss_height_circ) 
+  REAL(r_std), SAVE      :: ss_min_circ_init = 1.       !! Sensitivity for min_circ_init
+!$OMP THREADPRIVATE(ss_min_circ_init)
+  REAL(r_std), SAVE      :: ss_p_max = 1.               !! Sensitivity for p_max
+!$OMP THREADPRIVATE(ss_p_max)
+  LOGICAL, SAVE          :: lread_fm_map                !! A logical flag determining if we read
+                                                        !! in the forest management strategy from a map.
+!$OMP THREADPRIVATE(lread_fm_map)
+  LOGICAL, SAVE          :: lread_species_change_map = .FALSE.   !! A logical flag determining if we read
+                                                        !! in a map which changes species after a clearcut
+!$OMP THREADPRIVATE(lread_species_change_map)
+  LOGICAL, SAVE          :: lchange_species = .FALSE.   !! A logical flag determining if we change
+                                                        !! species after a clearcut
+!$OMP THREADPRIVATE(lchange_species)
+  INTEGER, SAVE          :: species_change_force        !! This is the PFT number which is replanted after a 
+                                                        !! clearcut, if such a thing is being done.
+!$OMP THREADPRIVATE(species_change_force)
+
+  !
+  ! stomate_litter.f90 
+  !
+
+  ! 0. Constants
+
+  REAL(r_std), PARAMETER :: Q10 = 10.               !!
+
+  ! 1. Scalar
+
+  REAL(r_std), SAVE :: z_decomp = 0.2               !!  Maximum depth for soil decomposer's activity (m)
+!$OMP THREADPRIVATE(z_decomp)
+  REAL(r_std), SAVE :: moistcont_min = 0.25         !! 
+!$OMP THREADPRIVATE(moistcont_min)
+
+  ! 2. Arrays
+
+  REAL(r_std), SAVE :: frac_soil_struct_aa = 0.55   !! corresponding to frac_soil(istructural,iactive,iabove) 
+!$OMP THREADPRIVATE(frac_soil_struct_aa)
+  REAL(r_std), SAVE :: frac_soil_struct_ab = 0.45   !! corresponding to frac_soil(istructural,iactive,ibelow)
+!$OMP THREADPRIVATE(frac_soil_struct_ab)
+  REAL(r_std), SAVE :: frac_soil_struct_sa = 0.7    !! corresponding to frac_soil(istructural,islow,iabove)
+!$OMP THREADPRIVATE(frac_soil_struct_sa)
+  REAL(r_std), SAVE :: frac_soil_struct_sb = 0.7    !! corresponding to frac_soil(istructural,islow,ibelow)
+!$OMP THREADPRIVATE(frac_soil_struct_sb)
+  REAL(r_std), SAVE :: frac_soil_metab_aa = 0.45    !! corresponding to frac_soil(imetabolic,iactive,iabove)
+!$OMP THREADPRIVATE(frac_soil_metab_aa)
+  REAL(r_std), SAVE :: frac_soil_metab_ab = 0.45    !! corresponding to frac_soil(imetabolic,iactive,ibelow)
+!$OMP THREADPRIVATE(frac_soil_metab_ab)
+  REAL(r_std), SAVE, DIMENSION(nparts) :: CN = &    !! C/N ratio of each plant pool (0-100, unitless)
+       & (/ 40., 40., 40., 40., 40., 40., 40., 40., 40./) 
+!$OMP THREADPRIVATE(CN)
+  REAL(r_std), SAVE, DIMENSION(nparts) :: LC = &    !! Lignin/C ratio of different plant parts (0,22-0,35, unitless)
+       & (/ 0.22, 0.35, 0.35, 0.35, 0.35, 0.22, 0.22, 0.22, 0.22 /)
+!$OMP THREADPRIVATE(LC)
+
+  ! 3. Coefficients of equations
+
+  REAL(r_std), SAVE :: metabolic_ref_frac = 0.85    !! used by litter and soilcarbon (0-1, unitless)
+!$OMP THREADPRIVATE(metabolic_ref_frac)
+  REAL(r_std), SAVE :: metabolic_LN_ratio = 0.018   !! (0-1, unitless)   
+!$OMP THREADPRIVATE(metabolic_LN_ratio)
+  REAL(r_std), SAVE :: tau_metabolic = 0.066        !!
+!$OMP THREADPRIVATE(tau_metabolic)
+  REAL(r_std), SAVE :: tau_struct = 0.245           !!
+!$OMP THREADPRIVATE(tau_struct)
+  REAL(r_std), SAVE :: tau_woody = 0.75             !!
+!$OMP THREADPRIVATE(tau_woody)
+  REAL(r_std), SAVE :: soil_Q10 = 0.69              !!= ln 2
+!$OMP THREADPRIVATE(soil_Q10)
+  REAL(r_std), SAVE :: tsoil_ref = 30.              !!
+!$OMP THREADPRIVATE(tsoil_ref)
+  REAL(r_std), SAVE :: litter_struct_coef = 3.      !! 
+!$OMP THREADPRIVATE(litter_struct_coef)
+  REAL(r_std), SAVE, DIMENSION(3) :: moist_coeff = (/ -1.1,  2.4,  -0.29 /) !!
+!$OMP THREADPRIVATE(moist_coeff)
+
+
+  !
+  ! stomate_lpj.f90
+  !
+
+  ! 1. Scalar
+
+  REAL(r_std), SAVE :: frac_turnover_daily = 0.55  !! (0-1, unitless)
+!$OMP THREADPRIVATE(frac_turnover_daily)
+
+
+  !
+  ! stomate_phenology.f90
+  !
+
+  ! 1. Scalar
+
+  LOGICAL, SAVE :: always_init = .FALSE.           !! take carbon from atmosphere if carbohydrate reserve too small? (true/false)
+!$OMP THREADPRIVATE(always_init)
+  REAL(r_std), SAVE :: min_growthinit_time = 300.  !! minimum time since last beginning of a growing season (days)
+!$OMP THREADPRIVATE(min_growthinit_time)
+  REAL(r_std), SAVE :: moiavail_always_tree = 1.0  !! moisture monthly availability above which moisture tendency doesn't matter
+                                                   !!  - for trees (0-1, unitless)
+!$OMP THREADPRIVATE(moiavail_always_tree)
+  REAL(r_std), SAVE :: moiavail_always_grass = 0.6 !! moisture monthly availability above which moisture tendency doesn't matter
+                                                   !! - for grass (0-1, unitless)
+!$OMP THREADPRIVATE(moiavail_always_grass)
+  REAL(r_std), SAVE :: t_always                    !! monthly temp. above which temp. tendency doesn't matter
+!$OMP THREADPRIVATE(t_always)
+  REAL(r_std), SAVE :: t_always_add = 10.          !! monthly temp. above which temp. tendency doesn't matter (C)
+!$OMP THREADPRIVATE(t_always_add)
+
+  ! 3. Coefficients of equations
+  
+  REAL(r_std), SAVE :: gddncd_ref = 603.           !!
+!$OMP THREADPRIVATE(gddncd_ref)
+  REAL(r_std), SAVE :: gddncd_curve = 0.0091       !!
+!$OMP THREADPRIVATE(gddncd_curve)
+  REAL(r_std), SAVE :: gddncd_offset = 64.         !!
+!$OMP THREADPRIVATE(gddncd_offset)
+
+
+  !
+  ! stomate_prescribe.f90
+  !
+
+  ! 1. Scalar
+    REAL(r_std), SAVE                       :: min_circ_init     !! Minimum initial circumferences of the 
+                                                                 !! truncated exponential distribution (cm) 
+!$OMP THREADPRIVATE(min_circ_init)
+    REAL(r_std), SAVE                       :: frac_shoot_init   !! Frac_shoot_init is the same for the 
+                                                                 !! initial distribution and is 
+                                                                 !! parameterized based on Litton (2007) and 
+                                                                 !! Mokany (2006). 
+!$OMP THREADPRIVATE(frac_shoot_init)
+
+  ! 3. Coefficients of equations
+
+  REAL(r_std), SAVE :: bm_sapl_rescale = 40.       !!
+!$OMP THREADPRIVATE(bm_sapl_rescale)
+
+
+  !
+  ! stomate_resp.f90
+  !
+
+  ! 3. Coefficients of equations
+
+  REAL(r_std), SAVE :: maint_resp_min_vmax = 0.3   !!
+!$OMP THREADPRIVATE(maint_resp_min_vmax)
+  
+  REAL(r_std), SAVE :: maint_resp_coeff = 1.4      !!
+!$OMP THREADPRIVATE(maint_resp_coeff)
+  
+  REAL(r_std), SAVE :: maint_resp_c = 1.           !!
+!$OMP THREADPRIVATE(maint_resp_c)
+
+
+  !
+  ! stomate_soilcarbon.f90 
+  !
+
+  ! 2. Arrays 
+
+  ! 2.1 frac_carb_coefficients
+
+  REAL(r_std), SAVE :: frac_carb_ap = 0.004  !! from active pool: depends on clay content  (0-1, unitless)
+                                             !! corresponding to frac_carb(:,iactive,ipassive)
+!$OMP THREADPRIVATE(frac_carb_ap)
+  REAL(r_std), SAVE :: frac_carb_sa = 0.42   !! from slow pool (0-1, unitless)
+                                             !! corresponding to frac_carb(:,islow,iactive)
+!$OMP THREADPRIVATE(frac_carb_sa)
+  REAL(r_std), SAVE :: frac_carb_sp = 0.03   !! from slow pool (0-1, unitless) 
+                                             !! corresponding to frac_carb(:,islow,ipassive)
+!$OMP THREADPRIVATE(frac_carb_sp)
+  REAL(r_std), SAVE :: frac_carb_pa = 0.45   !! from passive pool (0-1, unitless)
+                                             !! corresponding to frac_carb(:,ipassive,iactive)
+!$OMP THREADPRIVATE(frac_carb_pa)
+  REAL(r_std), SAVE :: frac_carb_ps = 0.0    !! from passive pool (0-1, unitless)
+                                             !! corresponding to frac_carb(:,ipassive,islow)
+!$OMP THREADPRIVATE(frac_carb_ps)
+
+  ! 3. Coefficients of equations
+
+  REAL(r_std), SAVE :: active_to_pass_clay_frac = 0.68  !! (0-1, unitless)
+!$OMP THREADPRIVATE(active_to_pass_clay_frac)
+  !! residence times in carbon pools (days)
+  REAL(r_std), SAVE :: carbon_tau_iactive = 0.149   !! residence times in active pool (days)
+!$OMP THREADPRIVATE(carbon_tau_iactive)
+  REAL(r_std), SAVE :: carbon_tau_islow = 5.48      !! residence times in slow pool (days)
+!$OMP THREADPRIVATE(carbon_tau_islow)
+  REAL(r_std), SAVE :: carbon_tau_ipassive = 241.   !! residence times in passive pool (days)
+!$OMP THREADPRIVATE(carbon_tau_ipassive)
+  REAL(r_std), SAVE, DIMENSION(3) :: flux_tot_coeff = (/ 1.2, 1.4, .75/)
+!$OMP THREADPRIVATE(flux_tot_coeff)
+
+
+  !
+  ! stomate_turnover.f90
+  !
+
+  ! 3. Coefficients of equations
+
+  REAL(r_std), SAVE :: new_turnover_time_ref = 20. !!(days)
+!$OMP THREADPRIVATE(new_turnover_time_ref)
+  REAL(r_std), SAVE :: dt_turnover_time = 10.      !!(days)
+!$OMP THREADPRIVATE(dt_turnover_time)
+  REAL(r_std), SAVE :: leaf_age_crit_tref = 20.    !! (C)
+!$OMP THREADPRIVATE(leaf_age_crit_tref)
+  REAL(r_std), SAVE, DIMENSION(3) :: leaf_age_crit_coeff = (/ 1.5, 0.75, 10./) !! (unitless)
+!$OMP THREADPRIVATE(leaf_age_crit_coeff)
+
+
+  !
+  ! stomate_vmax.f90
+  !
+ 
+  ! 1. Scalar
+
+  REAL(r_std), SAVE :: vmax_offset = 0.3        !! minimum leaf efficiency (unitless)
+!$OMP THREADPRIVATE(vmax_offset)
+  REAL(r_std), SAVE :: leafage_firstmax = 0.03  !! relative leaf age at which efficiency
+                                                !! reaches 1 (unitless)
+!$OMP THREADPRIVATE(leafage_firstmax)
+  REAL(r_std), SAVE :: leafage_lastmax = 0.5    !! relative leaf age at which efficiency
+                                                !! falls below 1 (unitless)
+!$OMP THREADPRIVATE(leafage_lastmax)
+  REAL(r_std), SAVE :: leafage_old = 1.         !! relative leaf age at which efficiency
+                                                !! reaches its minimum (vmax_offset) 
+                                                !! (unitless)
+!$OMP THREADPRIVATE(leafage_old)
+
+
+  !
+  ! stomate_season.f90 
+  !
+
+  ! 1. Scalar
+
+  REAL(r_std), SAVE :: gppfrac_dormance = 0.2  !! report maximal GPP/GGP_max for dormance (0-1, unitless)
+!$OMP THREADPRIVATE(gppfrac_dormance)
+  REAL(r_std), SAVE :: tau_climatology = 20.   !! tau for "climatologic variables (years)
+!$OMP THREADPRIVATE(tau_climatology)
+  REAL(r_std), SAVE :: hvc1 = 0.019            !! parameters for herbivore activity (unitless)
+!$OMP THREADPRIVATE(hvc1)
+  REAL(r_std), SAVE :: hvc2 = 1.38             !! parameters for herbivore activity (unitless)
+!$OMP THREADPRIVATE(hvc2)
+  REAL(r_std), SAVE :: leaf_frac_hvc = 0.33    !! leaf fraction (0-1, unitless)
+!$OMP THREADPRIVATE(leaf_frac_hvc)
+  REAL(r_std), SAVE :: tlong_ref_max = 303.1   !! maximum reference long term temperature (K)
+!$OMP THREADPRIVATE(tlong_ref_max)
+  REAL(r_std), SAVE :: tlong_ref_min = 253.1   !! minimum reference long term temperature (K)
+!$OMP THREADPRIVATE(tlong_ref_min)
+  REAL(r_std), SAVE :: tune_waterstress = 1.   !! The calculated values of moiavail are too low to be used as
+                                               !! multiplier for the allocation factors (::KF and ::LF). Hence,
+                                               !! ::moiavail_daily is tuned by this factor to calculate 
+                                               !! ::wstress_fac (unitless) 
+!$OMP THREADPRIVATE(tune_waterstress)
+
+
+  ! 3. Coefficients of equations
+
+  REAL(r_std), SAVE :: ncd_max_year = 3.
+!$OMP THREADPRIVATE(ncd_max_year)
+  REAL(r_std), SAVE :: gdd_threshold = 5.
+!$OMP THREADPRIVATE(gdd_threshold)
+  REAL(r_std), SAVE :: green_age_ever = 2.
+!$OMP THREADPRIVATE(green_age_ever)
+  REAL(r_std), SAVE :: green_age_dec = 0.5
+!$OMP THREADPRIVATE(green_age_dec)
+  REAL(r_std), SAVE :: ngd_min_dormance = 90.
+!$OMP THREADPRIVATE(ngd_min_dormance)
+
+
+
+! stomate_io.f90
+
+  REAL(r_std), SAVE :: mstemp = 13.9            !! Global Annual Mean Surface Temperature taken from 
+                                                !! http://www.ncdc.noaa.gov/monitoring-references/faq/anomalies.php
+!$OMP THREADPRIVATE(mstemp)
+
+
+
+
+END MODULE constantes_var
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parameters/function_library.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parameters/function_library.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parameters/function_library.f90	(revision 7236)
@@ -0,0 +1,2442 @@
+! =================================================================================================================================
+! MODULE       : function_library
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Collection of functions that are used throughout the ORCHIDEE code
+!!
+!!\n DESCRIPTION: Collection of modules to : (1) convert one variable into another i.e. basal area
+!! to diameter, diamter to tree height, diameter to crown area, etc. (2) ...
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	:
+!!
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_stomate/stomate_prescribe.f90 $
+!! $Date: 2013-01-04 16:50:56 +0100 (Fri, 04 Jan 2013) $
+!! $Revision: 1126 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE function_library
+
+  ! modules used:
+
+!$  USE ioipsl_para
+  USE pft_parameters
+  USE constantes
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC calculate_c0_alloc, wood_to_ba_eff_array, wood_to_ba_eff, wood_to_ba, &
+       wood_to_height_eff, wood_to_height, wood_to_qmheight, wood_to_dia_eff, &
+       wood_to_dia, wood_to_qmdia, wood_to_circ, wood_to_cn_array, &
+       wood_to_cn, wood_to_cn_eff, wood_to_cv, wood_to_cv_eff, wood_to_volume, &
+       biomass_to_lai, Nmax, Nmaxyield, Nminyield, distribute_mortality_biomass, &
+       check_biomass_sync, biomass_to_coupled_lai, stem_volume_f, vxmax_f, vrmax_f,  &
+       root_volume_f, vmax_l_f, canopy_leaf_area_f, grav_potential_f, stomatal_conductance_hydro_f,&
+       kstem_f, kroot_f, kleaf_f, kupper_f,kupper_check,P50_vary_class, distribute_mortality_biomass_yyt,distribute_mortality_biomass_new 
+  CONTAINS
+
+
+
+!! ================================================================================================================================
+! tzjh hydraulic architecture function 
+
+! ###########################################################################
+! Define water storage and gravitational potential functions
+! ###########################################################################
+!Stem volume function: Calculate stem volume (m^3) from height and dbh
+FUNCTION stem_volume_f(height,dbh)
+REAL, INTENT(IN) :: height, dbh
+REAL :: stem_volume_f
+   stem_volume_f = height*pi*(dbh/2)**2
+END FUNCTION stem_volume_f
+
+!Stem water storage function: Calculate maximum stem water storage volume in
+!mmol from tree size and water content
+FUNCTION vxmax_f(stem_volume,w_density_stem)
+REAL, INTENT(IN) :: stem_volume,w_density_stem
+REAL :: vxmax_f
+   vxmax_f = stem_volume*w_density_stem
+END FUNCTION vxmax_f
+
+!Root water storage function
+!Calculate maximum root water storage volume in mmol from the root water
+!content, ratio of root to shoot investment and root density     
+FUNCTION vrmax_f(stem_volume, wood_density, root_shoot_ratio, rwc_root)
+REAL, INTENT(IN) :: stem_volume, wood_density, root_shoot_ratio, rwc_root
+REAL :: stem_mass, root_mass,vrmax_f
+   stem_mass = stem_volume * wood_density
+   root_mass = stem_mass *root_shoot_ratio
+   vrmax_f=root_mass*rwc_root
+END FUNCTION vrmax_f
+
+! Root volume function Calculate the volume of the roots in m3 from the stem
+! mass, ratio of root to
+! shoot investment, and root density
+FUNCTION root_volume_f(stem_volume, wood_density, root_shoot_ratio, root_density)
+REAL, INTENT(IN) :: stem_volume, wood_density, root_shoot_ratio, root_density
+REAL :: root_volume_f, stem_mass, root_mass
+        stem_mass = stem_volume*wood_density !g
+        root_mass = stem_mass*root_shoot_ratio !#g
+        root_volume_f = (root_mass/root_density)/(100*100*100) !m3
+END FUNCTION root_volume_f
+
+!Leaf water storage function
+!Calculate the maximum water volume of all of the leaves in mmol from the tree
+!size and leaf dry matter content
+FUNCTION vmax_l_f(dbh, LDMC)
+REAL, INTENT(IN) :: dbh, LDMC
+REAL :: vmax_l_f,leaf_dry_mass, leaf_fresh_mass, water_mass, water_mass_mmol
+   !calculates the leaf dry mass (in kg) from the diameter of the trunk (in
+   !cm), according to the allometry equations in Djomo et al. 2010 Forest
+   !Ecology and Management
+   leaf_dry_mass = -0.1009 + 0.0626*(dbh*100) + 0.0027*(dbh*100)**2
+   !calculates leaf fresh mass (in kg) from the leaf dry matter content (g
+   !dry mass g-1 fresh mass)
+   leaf_fresh_mass = leaf_dry_mass*(1/LDMC)
+   !calculates the mass of water in the leaf (in kg)
+   water_mass = leaf_fresh_mass - leaf_dry_mass
+   ! converts water mass into mmol for consistency with other units
+   water_mass_mmol =  water_mass*1000*1000/18
+   vmax_l_f = water_mass_mmol
+END FUNCTION vmax_l_f
+
+! Canopy leaf area function: Calculate the leaf area of the canopy from the tree
+! size and SLA 
+FUNCTION canopy_leaf_area_f(dbh, sla_hydro)
+REAL, INTENT(IN) :: dbh, sla_hydro
+REAL :: leaf_dry_mass, canopy_leaf_area_f
+   leaf_dry_mass = -0.1009 + 0.0626*(dbh*100) + 0.0027*(dbh*100)**2
+   canopy_leaf_area_f = leaf_dry_mass*sla_hydro
+END FUNCTION canopy_leaf_area_f
+
+! Gravitational potential function 
+! Calculate how much of a water potential gradient is needed to pull water up
+! along the height of the tree
+! This assumes that the stem capacitor is at half the total tree height, and all
+! of the leaves are at the tree height
+! This also treats the distance the water has to be pulled up from the root to
+! the ground level as negligible- I think quantitatively it should be small
+! compared to the effect of stem height, and I think it would be hard to
+! accurately model this, since it depends on the spread of the roots, the soil
+! depth at which most water uptake occurs, the root length to mass ratio- but we
+! should talk about this
+FUNCTION grav_potential_f(height)
+REAL, INTENT(IN) :: height
+REAL ::  grav_potential_f
+   grav_potential_f = (height*1000*9.81)/1000000
+END FUNCTION grav_potential_f
+
+
+! Define physiology functions
+! #####################################################################################
+! Stomatal conductance function for hydraulics
+!FUNCTION stomatal_conductance_hydro_f(gmax, light, klight, VPD, gpsi, psi_leaf, gpsi_50, gmin)
+!REAL, INTENT(IN) :: gmax, light, klight, VPD, gpsi, psi_leaf, gpsi_50, gmin
+!REAL :: stomatal_conductance_hydro_f
+!   stomatal_conductance_hydro_f =  (gmax*(light/(ligh + klight))*(EXP(-VPD))/(1 + EXP(gpsi*(psi_leaf +gpsi_50)))) + gmin
+!END FUNCTION stomatal_conductance_hydro_f
+
+FUNCTION stomatal_conductance_hydro_f(gmax, light,klight, gpsi, psi_leaf, gpsi_50, gmin)
+REAL, INTENT(IN) :: gmax, light, klight, gpsi, psi_leaf, gpsi_50, gmin
+REAL :: stomatal_conductance_hydro_f
+   stomatal_conductance_hydro_f =  (gmax*(light/(light + klight)))/(1 + EXP(gpsi*(psi_leaf +gpsi_50))) + gmin
+END FUNCTION stomatal_conductance_hydro_f
+
+! Stem conductivity (cavitation) function
+! Calculates the stem conductivity for the next timestep using the psi_stem for
+! the next timestep
+FUNCTION kstem_f(kmax_stem, P50_stem, a_stem, psi_stem)
+REAL, INTENT(IN) :: kmax_stem, P50_stem, a_stem, psi_stem
+REAL :: kstem_f
+   kstem_f = kmax_stem/(1 + exp(a_stem*(psi_stem + P50_stem)))
+END FUNCTION kstem_f
+
+! Root conductivity (cavitation) function
+! Calculates the root conductivity for the next timestep using the psi_root for
+! the next timestep
+FUNCTION kroot_f(kmax_root, P50_root, a_root, psi_root)
+REAL, INTENT(IN) :: kmax_root, P50_root, a_root, psi_root
+REAL :: kroot_f
+   kroot_f = kmax_root/(1 + EXP(a_root*(psi_root + P50_root)))
+END FUNCTION kroot_f
+
+! Leaf conductivity (cavitation) function
+! Calculates the leaf conductivity for the next timestep using the psi_leaf for
+! the next timestep
+FUNCTION kleaf_f(kmax_leaf, P50_leaf, a_leaf, psi_leaf)
+REAL, INTENT(IN) :: kmax_leaf, P50_leaf, a_leaf, psi_leaf
+REAL :: kleaf_f
+   kleaf_f = kmax_leaf/(1 + EXP(a_leaf*(psi_leaf + P50_leaf)))
+END FUNCTION kleaf_f
+
+! Plant conductivity function
+! Optimized with the psi_leaf function to calculate k_leaf and psi_leaf
+! simultaneously, because these variables are functions of each other.  
+FUNCTION kupper_f(kmax_leaf, P50_leaf, a_leaf, psi_leaf, kstem)
+REAL, INTENT(IN) :: kmax_leaf, P50_leaf, a_leaf, psi_leaf, kstem
+REAL :: kleaf, kupper_f
+   kleaf = kmax_leaf/(1 + EXP(a_leaf*(psi_leaf + P50_leaf)))
+   kupper_f = 1/((1/kleaf) + (1/(2*kstem)))
+END FUNCTION kupper_f
+
+FUNCTION kupper_check(kmax_leaf, P50_leaf, a_leaf, psi_leaf, kstem)
+REAL, INTENT(IN) :: kmax_leaf, P50_leaf, a_leaf, psi_leaf, kstem
+REAL :: kleaf, kupper_check
+   kleaf = kmax_leaf/(1 + EXP(a_leaf*(psi_leaf + P50_leaf)))
+   kupper_check = 1/((1/kleaf) + (1/(2*kstem)))
+   print*,'IIIIIIIIIII check', kmax_leaf,a_leaf,psi_leaf,P50_leaf,kleaf,kupper_check
+END FUNCTION kupper_check
+
+
+
+
+
+
+!! ================================================================================================================================
+
+
+!! ================================================================================================================================
+!! FUNCTION    : biomass_to_coupled_lai
+!!
+!>\BRIEF        Calculate the coupled_LAI based on biomass and veget of each pft
+!!
+!! DESCRIPTION : Calculates the lai that coupled with the atmosphere  
+!! 
+!!             
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : ::coupled_lai (m2/m2)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION biomass_to_coupled_lai(biomass_leaf, veget, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+    INTEGER(i_std)                                       :: pft                    !! PFT number (-)
+    REAL(r_std)                                          :: veget                  !! 1-Pgap or the vegetation cover
+    REAL(r_std)                                          :: biomass_leaf           !! Biomass of an individual tree within a circ 
+                                                                                   !! class @tex $(m^{2} ind^{-1})$ @endtex 
+
+    !! 0.2 Output variables         
+    REAL(r_std)                                          :: biomass_to_coupled_lai !! The fraction of the LAI that is assumed to interact
+                                                                                   !! with the atmosphere @tex $(m^{2} m^{-2})$ @endtex
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std)                                          :: lai                    !! Leaf area index 
+                                                                                   !! @tex $(m^{2} m^{-2})$ @endtex               
+!_ ================================================================================================================================
+ 
+    lai = biomass_to_lai(biomass_leaf, pft) 
+   
+    !+++CHECK+++
+    ! In a closed canopy not all the leaves fully interact with the 
+    ! atmosphere because leaves can shelter each other. In a more 
+    ! open canopy most leaves can interact with the atmosphere.
+    ! For the moment we are not clear how to calculate the fraction of
+    ! the canopy that is coupled to the atmosphere. Also, based on the
+    ! simulated evapotranspiration we need the entire canopy to be
+    ! coupled to the atmosphere to obtain simulations which are close
+    ! to the observations (Jung's upscaled product).
+    IF (veget .GT. min_sechiba) THEN
+     
+       biomass_to_coupled_lai = lai   
+
+    ELSE
+   
+       ! There are so many gaps that veget is extremely small. It is fair to
+       ! assume that the whole canopy is coupled to the atmosphere.
+       biomass_to_coupled_lai = lai
+      
+    ENDIF
+
+  END FUNCTION biomass_to_coupled_lai
+ 
+  
+!! ================================================================================================================================
+!! FUNCTION     : calculate_c0_alloc
+!!
+!>\BRIEF        Calculate the baseline root vs sapwood allocation
+!!
+!! DESCRIPTION : Calculates the baseline root vs sapwood allocation based on the 
+!! parameters of the pipe model (hydraulic conductivities) and the
+!! turnover of the different components              
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : ::c0_alloc (m)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION calculate_c0_alloc(pts, pft, tau_eff_root, tau_eff_sap)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                             :: pts               !! Pixel number (-)
+    INTEGER(i_std)                             :: pft               !! PFT number (-)
+    REAL(r_std)                                :: tau_eff_root      !! Effective longivety for leaves (days)
+    REAL(r_std)                                :: tau_eff_sap       !! Effective longivety for leaves (days)
+    
+    !! 0.2 Output variables
+                
+    REAL(r_std)                                :: calculate_c0_alloc  !! quadratic mean height (m) 
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std)                                :: sapwood_density
+    REAL(r_std)                                :: qm_dia            !! quadratic mean diameter (m)
+
+!_ ================================================================================================================================
+ 
+    !! 1. Calculate c0_alloc
+    IF ( is_tree(pft) ) THEN
+
+       sapwood_density = deux * pipe_density(pft) / kilo_to_unit
+       calculate_c0_alloc = sqrt(k_root(pft)/k_sap(pft)*tau_eff_sap/tau_eff_root*sapwood_density)
+
+    ! Grasses and croplands   
+    ELSE
+
+       !+++CHECK+++
+       ! Simply copied the same formulation as for trees but note
+       ! that the sapwood in trees vs grasses and crops has a very
+       ! meaning. In grasses and crops is structural carbon to ensure
+       ! that the allocation works. In trees it really is the sapwood
+       sapwood_density = deux * pipe_density(pft) / kilo_to_unit
+       calculate_c0_alloc = sqrt(k_root(pft)/k_sap(pft)*tau_eff_sap/tau_eff_root*sapwood_density)
+       !+++++++++++
+
+    ENDIF ! is_tree(j)
+
+ END FUNCTION calculate_c0_alloc
+
+
+
+!! ================================================================================================================================
+!! FUNCTION     : wood_to_ba_eff_array
+!!
+!>\BRIEF        Calculate the effective basal area from woody biomass making use of allometric relationships.
+!!
+!! DESCRIPTION : Calculate basal area of an individual tree from the woody biomass of that tree making 
+!! use of allometric relationships. Effective basal area accounts for both above and below ground carbon
+!! and is the basis for the application of the rule of Deleuze and Dhote
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : effective basal area (m2 ind-1)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION wood_to_ba_eff_array(biomass_temp, npts, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                                          :: pft                  !! PFT number (-)
+    INTEGER(i_std)                                          :: npts                 !! Number of pixels
+    REAL(r_std), DIMENSION(:,:,:)                           :: biomass_temp         !! Biomass of an individual tree within a circ 
+                                                                                    !! class @tex $(m^{2} ind^{-1})$ @endtex 
+
+    !! 0.2 Output variables
+                
+    REAL(r_std), DIMENSION(npts,ncirc)                      :: wood_to_ba_eff_array !! Effective basal area of an individual tree within a circ
+                                                                                    !! class @tex $(m^{2} ind^{-1})$ @endtex
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                          :: l                    !! Index
+    REAL(r_std), DIMENSION(npts)                            :: woodmass_ind         !! Woodmass of an individual tree
+                                                                                    !! @tex $(gC ind{-1})$ @endtex
+
+!_ ================================================================================================================================
+ 
+ !! 1. Calculate effective basal area from woodmass
+
+    IF ( is_tree(pft) ) THEN
+       
+       DO l = 1,ncirc
+         
+          ! Woodmass of an individual tree. Note that for the effective basal area 
+          ! both the above and belowground biomass are used.
+          woodmass_ind(:) = biomass_temp(:,l,isapabove) + biomass_temp(:,l,isapbelow) + &
+             biomass_temp(:,l,iheartabove) + biomass_temp(:,l,iheartbelow)
+
+          ! Basal area of that individual (m2 ind-1)  
+          wood_to_ba_eff_array(:,l) = (pi/4*(woodmass_ind(:)/&
+               (tree_ff(pft)*pipe_density(pft)*pipe_tune2(pft))) &
+               **(2./pipe_tune3(pft)))**(pipe_tune3(pft)/(pipe_tune3(pft)+2))
+                 
+       ENDDO
+
+    ELSE
+
+       WRITE(numout,*) 'function wood_to_ba_eff_array is not defined for this PFT'
+       WRITE(numout,*) 'pft ',pft
+       CALL ipslerr_p (3,'wood_to_ba_eff_array', &
+            'wood_to_ba_eff_array is not defined for this PFT.', &
+            'See the output file for more details.','')
+
+
+    ENDIF
+
+  END FUNCTION wood_to_ba_eff_array
+
+
+!! ================================================================================================================================
+!! FUNCTION     : wood_to_ba_eff
+!!
+!>\BRIEF        Calculate effective basal area from woody biomass making use of allometric relationships
+!!
+!! DESCRIPTION :  Calculate basal area of an individual tree from the woody biomass of that tree making 
+!! use of allometric relationships. Effective basal area accounts for both above and below ground carbon
+!! and is the basis for the application of the rule of Deleuze and Dhote.
+!! (i) woodmass = tree_ff * pipe_density*ba*height
+!! (ii) height = pipe_tune2 * sqrt(4/pi*ba) ** pipe_tune_3  
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : effective basal area (m2 ind-1)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+ 
+ FUNCTION wood_to_ba_eff(biomass_temp, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                                          :: pft                  !! PFT number (-)
+    REAL(r_std), DIMENSION(:,:)                             :: biomass_temp         !! Biomass of an individual tree within a circ 
+                                                                                    !! class @tex $(m^{2} ind^{-1})$ @endtex 
+
+    !! 0.2 Output variables
+                
+    REAL(r_std), DIMENSION(ncirc)                           :: wood_to_ba_eff       !! Effective basal area of an individual tree within a circ
+                                                                                    !! class @tex $(m^{2} ind^{-1})$ @endtex
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                          :: l                    !! Index
+    REAL(r_std)                                             :: woodmass_ind         !! Woodmass of an individual tree
+                                                                                    !! @tex $(gC ind^{-1})$ @endtex
+
+!_ ================================================================================================================================
+ 
+ !! 1. Calculate basal area from woodmass
+
+    IF ( is_tree(pft) ) THEN
+       
+       DO l = 1,ncirc
+         
+          ! Woodmass of an individual tree
+          woodmass_ind = biomass_temp(l,isapabove) + biomass_temp(l,isapbelow) + &
+             biomass_temp(l,iheartabove) + biomass_temp(l,iheartbelow)
+
+          ! Basal area of that individual (m2 ind-1)  
+          wood_to_ba_eff(l) = (pi/4*(woodmass_ind/(tree_ff(pft)*pipe_density(pft)*pipe_tune2(pft))) &
+                  **(2./pipe_tune3(pft)))**(pipe_tune3(pft)/(pipe_tune3(pft)+2))
+                 
+       ENDDO
+
+    ELSE
+
+       WRITE(numout,*) 'pft ',pft
+       CALL ipslerr_p (3,'wood_to_ba_eff', &
+            'wood_to_ba_eff is not defined for this PFT.', &
+            'See the output file for more details.','')
+
+    ENDIF
+
+ END FUNCTION wood_to_ba_eff
+
+
+
+!! ================================================================================================================================
+!! FUNCTION     : wood_to_ba
+!!
+!>\BRIEF        Calculate basal area from woody biomass making use of allometric relationships
+!!
+!! DESCRIPTION : Calculate basal area of an individual tree from the woody biomass of that tree making 
+!! use of allometric relationships given below. Here basal area is defined in line with its classical 
+!! forestry meaning.
+!! (i) woodmass = tree_ff * pipe_density*ba*height
+!! (ii) height = pipe_tune2 * sqrt(4/pi*ba) ** pipe_tune_3  
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : basal area (m2 ind-1)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+ 
+ FUNCTION wood_to_ba(biomass_temp, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                                          :: pft               !! PFT number (-)
+    REAL(r_std), DIMENSION(:,:)                             :: biomass_temp      !! Biomass of an individual tree within a circ 
+                                                                                 !! class @tex $(m^{2} ind^{-1})$ @endtex 
+
+    !! 0.2 Output variables
+                
+    REAL(r_std), DIMENSION(ncirc)                           :: wood_to_ba        !! Basal area of an individual tree within a circ
+                                                                                 !! class @tex $(m^{2} ind^{-1})$ @endtex
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                          :: l                 !! Index
+    REAL(r_std)                                             :: woodmass_ind      !! Woodmass of an individual tree
+                                                                                 !! @tex $(gC ind^{-1})$ @endtex
+
+!_ ================================================================================================================================
+ 
+ !! 1. Calculate basal area from woodmass
+
+    IF ( is_tree(pft) ) THEN
+       
+       DO l = 1,ncirc
+         
+          ! Woodmass of an individual tree
+          woodmass_ind = biomass_temp(l,iheartabove) + biomass_temp(l,isapabove)
+
+
+          ! Basal area of that individual (m2 ind-1)  
+          wood_to_ba(l) = (pi/4*(woodmass_ind/(tree_ff(pft)*pipe_density(pft)*pipe_tune2(pft))) &
+                  **(2./pipe_tune3(pft)))**(pipe_tune3(pft)/(pipe_tune3(pft)+2))
+                 
+       ENDDO
+
+    ELSE
+
+       WRITE(numout,*) 'pft ',pft
+       CALL ipslerr_p (3,'wood_to_ba', &
+            'wood_to_ba is not defined for this PFT.', &
+            'See the output file for more details.','')
+
+    ENDIF
+
+ END FUNCTION wood_to_ba
+
+
+!! ================================================================================================================================
+!! FUNCTION     : wood_to_height_eff
+!!
+!>\BRIEF        Calculate the effective tree height from woody biomass making use of allometric relationships
+!!
+!! DESCRIPTION : Calculate the effective height of an individual tree from the woody biomass of that tree making 
+!! use of allometric relationships. Effective height makes use of both above and belowground biomass and is
+!! used in the calculation of the allocation according to deleuze and dhote, hydraulic architecture because also
+!! the height of the belowground part should be included.
+!! (i) height(:) = pipe_tune2(j)*(4/pi*ba(:))**(pipe_tune3(j)/2) and
+!! (ii) woodmass_ind = tree_ff*pipe_density*ba*height   
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : height (m)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION wood_to_height_eff(biomass_temp, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                                          :: pft                !! PFT number (-)
+    REAL(r_std), DIMENSION(:,:)                             :: biomass_temp       !! Biomass of an individual tree within a circ 
+                                                                                  !! class @tex $(m^{2} ind^{-1})$ @endtex 
+
+    !! 0.2 Output variables
+                
+    REAL(r_std), DIMENSION(ncirc)                           :: wood_to_height_eff !! Effective height of an individual tree within a circ
+                                                                                  !! class (m)
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                          :: l                  !! Index
+    REAL(r_std)                                             :: woodmass_ind       !! Woodmass of an individual tree
+                                                                                  !! @tex $(gC ind{-1})$ @endtex
+                                                                                  
+    CHARACTER(len=256)  :: tmp_var_name                                           !! temporal variable for a text reading (from run.def)   
+    REAL(r_std)         :: tmp_ratio                                              !! temporal variable for adjusting the height   
+!_ ================================================================================================================================
+ 
+ !! 1. Calculate height from woodmass
+
+    IF ( is_tree(pft) ) THEN
+       
+       DO l = 1,ncirc
+         
+          ! Woodmass of an individual tree. Both above and belowground biomass are used
+          woodmass_ind = biomass_temp(l,isapabove) + biomass_temp(l,isapbelow) + &
+             biomass_temp(l,iheartabove) + biomass_temp(l,iheartbelow)
+
+          ! Height of that individual
+          wood_to_height_eff(l) = (((woodmass_ind/(tree_ff(pft)*pipe_density(pft))*4/pi)**(pipe_tune3(pft)/2))&
+               *pipe_tune2(pft))**(1/(pipe_tune3(pft)/2+1))
+          
+          !+++++++ TEMP ++++++++++
+          ! This code is only used evaluation of the performance of the multi-layer energy budget. 
+          ! To reduce the complexity of the tests we want to impose the LAI and its vertical distribution. 
+          ! The solution is not very elegant but it works. 
+          ! This part of code use the CIRC_HEIGHT_RATIO to adjust the original heigth in each circonferance class.
+          ! By doing so, the canopy sturcture can be adjust to match the site level observations. 
+               IF (ld_fake_height)  THEN
+          !        WRITE(numout,*)'+++ fake wood to height function +++'
+                   !set initial the tmp_ratio reaul to 1.0
+                   tmp_ratio=1.0
+                   WRITE(tmp_var_name, '(A19,I5.5)') "CIRC_HEIGHT_RATIO__", l
+                   CALL getin_p(TRIM(tmp_var_name),  tmp_ratio)
+                   wood_to_height_eff(l) =tmp_ratio*wood_to_height_eff(l)        
+           !       WRITE(numout,*) 'SET CIRC_', l, '_HEIGHT = ', wood_to_height_eff(l) 
+               ENDIF                       
+           !++++++++++++++++++++++                
+ 
+       ENDDO
+
+    ELSE
+
+       WRITE(numout,*) 'pft ',pft
+       CALL ipslerr_p (3,'wood_to_height_eff', &
+            'wood_to_height_eff is not defined for this PFT.', &
+            'See the output file for more details.','')
+
+    ENDIF
+
+ END FUNCTION wood_to_height_eff
+
+
+!! ================================================================================================================================
+!! FUNCTION     : wood_to_height
+!!
+!>\BRIEF        Calculate tree height from woody biomass making use of allometric relationships
+!!
+!! DESCRIPTION : Calculate height of an individual tree from the woody biomass of that tree making 
+!! use of allometric relationships. This is the height used in forestry and for calculating the aerodynamic
+!! interactions 
+!! (i) height(:) = pipe_tune2(j)*(4/pi*ba(:))**(pipe_tune3(j)/2) and
+!! (ii) woodmass_ind = tree_ff*pipe_density*ba*height   
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : height (m)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION wood_to_height(biomass_temp, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                                          :: pft                !! PFT number (-)
+    REAL(r_std), DIMENSION(:,:)                             :: biomass_temp       !! Biomass of an individual tree within a circ 
+                                                                                  !! class @tex $(m^{2} ind^{-1})$ @endtex 
+
+    !! 0.2 Output variables
+                
+    REAL(r_std), DIMENSION(ncirc)                           :: wood_to_height     !! Height of an individual tree within a circ
+                                                                                  !! class (m)
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                          :: l                  !! Index
+    REAL(r_std)                                             :: woodmass_ind       !! Woodmass of an individual tree
+                                                              !! @tex $(gC ind{-1})$ @endtex
+
+!_ ================================================================================================================================
+ 
+ !! 1. Calculate height from woodmass
+
+    IF ( is_tree(pft) ) THEN
+       
+       DO l = 1,ncirc
+         
+          ! Woodmass of an individual tree (only the aboveground component)
+          woodmass_ind = biomass_temp(l,isapabove) + biomass_temp(l,iheartabove)
+
+          ! Height of that individual
+          wood_to_height(l) = (((woodmass_ind/(tree_ff(pft)*pipe_density(pft))*4/pi)**(pipe_tune3(pft)/2))&
+               *pipe_tune2(pft))**(1/(pipe_tune3(pft)/2+1))
+            
+       ENDDO
+
+    ELSE
+
+       WRITE(numout,*) 'pft ',pft
+       CALL ipslerr_p (3,'wood_to_height', &
+            'wood_to_height is not defined for this PFT.', &
+            'See the output file for more details.','')
+
+    ENDIF
+
+ END FUNCTION wood_to_height
+
+
+!! ================================================================================================================================
+!! FUNCTION     : wood_to_qmheight
+!!
+!>\BRIEF        Calculate the quadratic mean height from the biomass
+!!
+!! DESCRIPTION : Calculates the quadratic mean height from the biomass
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : ::qm_height (m)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION wood_to_qmheight(biomass_temp, ind, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                             :: pft               !! PFT number (-)
+    REAL(r_std), DIMENSION(ncirc,nparts)       :: biomass_temp      !! Biomass of the leaves @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)              :: ind               !! Number of individuals @tex $(m^{-2})$ @endtex
+
+
+    !! 0.2 Output variables
+                
+    REAL(r_std)                                :: wood_to_qmheight  !! quadratic mean height (m) 
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std), DIMENSION(ncirc)              :: circ_class_ba     !! basal area for each circ_class @tex $(m^{2})$ @endtex
+    REAL(r_std)                                :: qm_dia            !! quadratic mean diameter (m)
+
+!_ ================================================================================================================================
+ 
+    !! 1. Calculate qm_height from the biomass
+    IF ( is_tree(pft) ) THEN
+
+       ! Basal area at the tree level (m2 tree-1)
+       circ_class_ba(:) = wood_to_ba(biomass_temp(:,:),pft) 
+       
+       IF (SUM(ind(:)) .NE. zero) THEN
+
+          qm_dia = SQRT( 4/pi*SUM(circ_class_ba(:)*ind(:))/SUM(ind(:)) )
+          
+       ELSE
+          
+          qm_dia = zero
+
+       ENDIF
+       
+       wood_to_qmheight = pipe_tune2(pft)*(qm_dia**pipe_tune3(pft))
+             
+
+    ! Grasses and croplands   
+    ELSE
+
+       ! Calculate height as a function of the leaf and structural biomass. Use structural
+       ! biomass to make sure that the grasslands have a roughness length during the winter
+       ! If the biomass increases, vegetation height will increase as well. Divide by 
+       ! ind(ipts,j) to obtain the height of the individual. biomass(ileaf) is in gC m-2 
+       ! whereas qm is the height of the individual.
+       IF (SUM(ind(:)) .NE. zero) THEN
+
+          wood_to_qmheight = SUM(biomass_temp(:,ileaf) + biomass_temp(:,isapabove)) / &
+               SUM(ind(:)) * sla(pft) * lai_to_height(pft)
+
+       ELSE
+
+          wood_to_qmheight = zero
+
+       ENDIF
+
+    ENDIF ! is_tree(j)
+
+ END FUNCTION wood_to_qmheight
+
+
+
+!! ================================================================================================================================
+!! FUNCTION     : wood_to_dia_eff
+!!
+!>\BRIEF        Calculate effective diameter from woody biomass making use of allometric relationships
+!!
+!! DESCRIPTION : Calculate the effective diameter of an individual tree from the woody biomass of that tree making 
+!! use of allometric relationships. Effective diameter accounts for both above and belowground biomass. 
+!! (i) woodmass_ind = tree_ff * pipe_density * height * pi/4*dia**2
+!! (ii) height = pipe_tune2 * dia * pipe_tune3 
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : diameter (m)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION wood_to_dia_eff(biomass_temp, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                                          :: pft               !! PFT number (-)
+    REAL(r_std), DIMENSION(:,:)                             :: biomass_temp      !! Biomass of an individual tree within a circ 
+                                                                                 !! class @tex $(m^{2} ind^{-1})$ @endtex 
+
+    !! 0.2 Output variables
+                
+    REAL(r_std), DIMENSION(ncirc)                           :: wood_to_dia_eff   !! Diameter of an individual tree within a circ
+                                                                                 !! class (m)
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                          :: l                 !! Index
+    REAL(r_std)                                             :: woodmass_ind      !! Woodmass of an individual tree
+                                                                                 !! @tex $(gC ind^{-1})$ @endtex
+
+!_ ================================================================================================================================
+ 
+ !! 1. Calculate basal area from woodmass
+
+    IF ( is_tree(pft) ) THEN
+       
+       DO l = 1,ncirc
+         
+          ! Woodmass of an individual tree
+          woodmass_ind = biomass_temp(l,isapabove) + biomass_temp(l,isapbelow) + &
+             biomass_temp(l,iheartabove) + biomass_temp(l,iheartbelow)
+
+          ! Basal area of that individual (m2 ind-1)  
+          wood_to_dia_eff(l) = (4/pi*woodmass_ind/(tree_ff(pft)*pipe_density(pft)*pipe_tune2(pft))) ** &
+                  (1./(2+pipe_tune3(pft)))
+                 
+       ENDDO
+
+    ELSE
+
+       WRITE(numout,*) 'pft ',pft
+       CALL ipslerr_p (3,'wood_to_dia_eff', &
+            'wood_to_dia_eff is not defined for this PFT.', &
+            'See the output file for more details.','')
+
+    ENDIF
+
+ END FUNCTION wood_to_dia_eff
+
+
+
+!! ================================================================================================================================
+!! FUNCTION     : wood_to_dia
+!!
+!>\BRIEF        Calculate diameter from woody biomass making use of allometric relationships
+!!
+!! DESCRIPTION : Calculate diameter of an individual tree from the woody biomass of that tree making 
+!! use of allometric relationships. Makes only use of the aboveground biomass and relates to the
+!! typical forestry diameter (but not normalized at 1.3 m)
+!! (i) woodmass_ind = tree_ff * pipe_density * height * pi/4*dia**2
+!! (ii) height = pipe_tune2 * dia * pipe_tune3 
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : diameter (m)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION wood_to_dia(biomass_temp, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                                          :: pft               !! PFT number (-)
+    REAL(r_std), DIMENSION(:,:)                             :: biomass_temp      !! Biomass of an individual tree within a circ 
+                                                                                 !! class @tex $(m^{2} ind^{-1})$ @endtex 
+
+    !! 0.2 Output variables
+                
+    REAL(r_std), DIMENSION(ncirc)                           :: wood_to_dia       !! Diameter of an individual tree within a circ
+                                                                                 !! class (m)
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                          :: l                 !! Index
+    REAL(r_std)                                             :: woodmass_ind      !! Woodmass of an individual tree
+                                                                                 !! @tex $(gC ind^{-1})$ @endtex
+
+!_ ================================================================================================================================
+ 
+ !! 1. Calculate basal area from woodmass
+
+    IF ( is_tree(pft) ) THEN
+       
+       DO l = 1,ncirc
+         
+          ! Woodmass of an individual tree
+          woodmass_ind = biomass_temp(l,isapabove) + biomass_temp(l,iheartabove)
+
+          ! Basal area of that individual (m2 ind-1)  
+          wood_to_dia(l) = (4/pi*woodmass_ind/(tree_ff(pft)*pipe_density(pft)*pipe_tune2(pft))) ** &
+                  (1./(2+pipe_tune3(pft)))
+                 
+       ENDDO
+
+    ELSE
+
+       WRITE(numout,*) 'pft ',pft
+       CALL ipslerr_p (3,'wood_to_dia', &
+            'wood_to_dia is not defined for this PFT.', &
+            'See the output file for more details.','')
+
+    ENDIF
+
+ END FUNCTION wood_to_dia
+
+
+!! ================================================================================================================================
+!! FUNCTION     : wood_to_qmdia
+!!
+!>\BRIEF        Calculate the quadratic mean diameter from the biomass
+!!
+!! DESCRIPTION : Calculates the quadratic mean diameter from the aboveground biomss
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : ::qm_dia (m)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION wood_to_qmdia(biomass_temp, ind, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                             :: pft               !! PFT number (-)
+    REAL(r_std), DIMENSION(ncirc,nparts)       :: biomass_temp      !! Biomass of the leaves @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(ncirc)              :: ind               !! Number of individuals @tex $(m^{-2})$ @endtex
+
+    !! 0.2 Output variables
+                
+    REAL(r_std)                                :: wood_to_qmdia     !! quadratic mean diameter (m) 
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std), DIMENSION(ncirc)              :: circ_class_ba     !! basal area for each circ_class @tex $(m^{2})$ @endtex
+
+!_ ================================================================================================================================
+ 
+    !! 1. Calculate qm_dia from the biomass
+    IF ( is_tree(pft) ) THEN
+
+       ! Basal area at the tree level (m2 tree-1)
+       circ_class_ba(:) = wood_to_ba(biomass_temp(:,:),pft) 
+       
+       IF (SUM(ind(:)) .NE. zero) THEN
+
+          wood_to_qmdia = SQRT( 4/pi*SUM(circ_class_ba(:)*ind(:))/SUM(ind(:)) )
+          
+       ELSE
+          
+          wood_to_qmdia = zero
+
+       ENDIF
+
+
+    ! Grasses and croplands   
+    ELSE
+
+       wood_to_qmdia = zero   
+       
+    ENDIF ! is_tree(pft)
+
+ END FUNCTION wood_to_qmdia
+
+
+!! ================================================================================================================================
+!! FUNCTION     : wood_to_circ
+!!
+!>\BRIEF        Calculate circumference from woody biomass making use of allometric relationships
+!!
+!! DESCRIPTION : All this does it computer the diameter using a different routine, and then
+!!               convert that into a circumference.  
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : circumference (m)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION wood_to_circ(biomass_temp, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                                          :: pft               !! PFT number (-)
+    REAL(r_std), DIMENSION(:,:)                             :: biomass_temp      !! Biomass of an individual tree within a circ 
+                                                                                 !! class @tex $(m^{2} ind^{-1})$ @endtex 
+
+    !! 0.2 Output variables
+                
+    REAL(r_std), DIMENSION(ncirc)                           :: wood_to_circ      !! Circumference of an individual tree within a circ
+                                                                                 !! class (m)
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+!_ ================================================================================================================================
+ 
+    !! 1. Calculate diameter from woodmass
+
+    wood_to_circ(:)=val_exp
+
+    wood_to_circ(:)=wood_to_dia(biomass_temp(:,:),pft)
+
+    ! convert to a circumference (m)
+    wood_to_circ(:) =  wood_to_circ(:)*pi
+
+ END FUNCTION wood_to_circ
+
+
+
+!! ================================================================================================================================
+!! FUNCTION     : wood_to_cn_array
+!!
+!>\BRIEF        Calculate crown area from woody biomass making use of allometric relationships
+!!
+!! DESCRIPTION : Calculate crown area of an individual tree from the woody biomass of that tree
+!! making use of allometric relationship that relates crown area (cn) to diameter (dia) as 
+!! pipe_tune1*dia**pipe_tune_exp_coeff where the pipe_tune parameters are pft-specific. 
+!! (i) Basal area is written as a function of wood_mass: woodmass_ind = tree_ff*pipe_density*ba*height
+!! (ii) height = pipe_tune2*sqrt(4/pi*ba)**pipe_tune3
+!! (iii) cn = pipe_tune1*sqrt(4/pi*ba)**pipe_tune_exp_coeff   
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : crown area (m2 ind-1)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+
+  FUNCTION wood_to_cn_array(biomass_temp, npts, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                           :: pft              !! PFT number (-)
+    INTEGER(i_std)                           :: npts             !! Pixel(s), this variable defines the dimensions of ba
+    REAL(r_std), DIMENSION(:,:,:)            :: biomass_temp     !! Biomass of an individual tree within a circ 
+                                                                 !! class @tex $(m^{2} ind^{-1})$ @endtex 
+    
+
+    !! 0.2 Output variables
+                
+    REAL(r_std), DIMENSION(npts,ncirc)       :: wood_to_cn_array !! Crown area of an individual tree @tex $(m^{2} ind{-1})$ @endtex
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+ 
+    INTEGER(i_std)                           :: l                !! index
+    REAL(r_std), DIMENSION(npts)             :: woodmass_ind     !! Woodmass of an individual tree @tex $(gC ind{-1})$ @endtex
+
+!_ ================================================================================================================================
+ 
+ !! 1. Calculate crown area from basal area
+
+    IF ( is_tree(pft) ) THEN
+       
+       DO l = 1,ncirc
+
+          ! Woodmass of an individual tree
+          woodmass_ind(:) = biomass_temp(:,l,isapabove) + biomass_temp(:,l,iheartabove)
+
+          ! Crown area of that individual
+          ! cn = pipe_tune1*sqrt(4/pi*ba)**pipe_tune_exp_coeff 
+          wood_to_cn_array(:,l) = pipe_tune1(pft) * SQRT( 4/pi*(pi/4*(woodmass_ind(:)/&
+               (tree_ff(pft)*pipe_density(pft)*pipe_tune2(pft)))**(2./pipe_tune3(pft)))**&
+               (pipe_tune3(pft)/(pipe_tune3(pft)+2)) ) ** pipe_tune_exp_coeff(pft)
+
+       ENDDO
+
+    ELSE
+
+       WRITE(numout,*) 'pft ',pft
+       CALL ipslerr_p (3,'wood_to_cn_array', &
+            'wood_to_cn_array is not defined for this PFT.', &
+            'See the output file for more details.','')
+
+    ENDIF
+
+  END FUNCTION wood_to_cn_array
+
+
+!! ================================================================================================================================
+!! FUNCTION     : wood_to_cn
+!!
+!>\BRIEF        Calculate crown area from woody biomass making use of allometric relationships
+!!
+!! DESCRIPTION : Calculate crown area of an individual tree from the woody biomass of that tree 
+!! making use of allometric relationship that relates crown area (cn) to diameter (dia) as 
+!! pipe_tune1*dia**pipe_tune_exp_coeff where the pipe_tune parameters are pft-specific. 
+!! (i) Basal area is written as a function of wood_mass: woodmass_ind = tree_ff*pipe_density*ba*height
+!! (ii) height = pipe_tune2*sqrt(4/pi*ba)**pipe_tune3
+!! (iii) cn = pipe_tune1*sqrt(4/pi*ba)**pipe_tune_exp_coeff   
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : crown area (m2 ind-1)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION wood_to_cn(biomass_temp, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                                          :: pft               !! PFT number (-)
+    REAL(r_std), DIMENSION(:,:)                             :: biomass_temp      !! biomass of an individual tree within a circ 
+                                                                                 !! class @tex $(m^{2} ind^{-1})$ @endtex 
+
+    !! 0.2 Output variables
+                
+    REAL(r_std), DIMENSION(ncirc)                           :: wood_to_cn        !! Crown area of an individual tree within a circ
+                                                                                 !! class @tex $(m^{2} ind-1)$ @endtex
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                          :: l                 !! Index
+    REAL(r_std)                                             :: woodmass_ind      !! Woodmass of an individual tree
+                                                                                 !! @tex $(gC ind{-1})$ @endtex
+
+!_ ================================================================================================================================
+ 
+ !! 1. Calculate crown area from woodmass
+
+    IF ( is_tree(pft) ) THEN
+       
+       DO l = 1,ncirc
+         
+          ! Woodmass of an individual tree
+          woodmass_ind = biomass_temp(l,isapabove) + biomass_temp(l,iheartabove)
+ 
+          ! Crown area of that individual
+          ! cn = pipe_tune1*sqrt(4/pi*ba)**pipe_tune_exp_coeff 
+          wood_to_cn(l) = pipe_tune1(pft) * SQRT( 4/pi*(pi/4*(woodmass_ind/&
+               (tree_ff(pft)*pipe_density(pft)*pipe_tune2(pft)))**(2./pipe_tune3(pft)))**&
+               (pipe_tune3(pft)&
+               /(pipe_tune3(pft)+2)) ) ** pipe_tune_exp_coeff(pft)
+                
+       ENDDO
+
+    ELSE
+
+       WRITE(numout,*) 'pft ',pft
+       CALL ipslerr_p (3,'wood_to_cn', &
+            'wood_to_cn is not defined for this PFT.', &
+            'See the output file for more details.','')
+
+    ENDIF
+
+ END FUNCTION wood_to_cn
+
+!! ================================================================================================================================
+!! FUNCTION     : wood_to_cn_eff
+!!
+!>\BRIEF        Calculate crown area from woody biomass making use of allometric relationships
+!!
+!! DESCRIPTION : Calculate crown area of an individual tree from the woody biomass of that tree 
+!! making use of allometric relationship that relates crown area (cn) to diameter (dia) as 
+!! pipe_tune1*dia**pipe_tune_exp_coeff where the pipe_tune parameters are pft-specific. 
+!! (i) Basal area is written as a function of wood_mass: woodmass_ind = tree_ff*pipe_density*ba*height
+!! (ii) height = pipe_tune2*sqrt(4/pi*ba)**pipe_tune3
+!! (iii) cn = pipe_tune1*sqrt(4/pi*ba)**pipe_tune_exp_coeff   
+!!
+!! NOTE: This is different from wood_to_cn because this uses both the aboveground and
+!!       belowground wood mass.
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : crown area (m2 ind-1)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION wood_to_cn_eff(biomass_temp, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                                          :: pft               !! PFT number (-)
+    REAL(r_std), DIMENSION(:,:)                             :: biomass_temp      !! biomass of an individual tree within a circ 
+                                                                                 !! class @tex $(m^{2} ind^{-1})$ @endtex 
+
+    !! 0.2 Output variables
+                
+    REAL(r_std), DIMENSION(ncirc)                           :: wood_to_cn_eff    !! Crown area of an individual tree within a circ
+                                                                                 !! class @tex $(m^{2} ind-1)$ @endtex
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                          :: l                 !! Index
+    REAL(r_std)                                             :: woodmass_ind      !! Woodmass of an individual tree
+                                                                                 !! @tex $(gC ind{-1})$ @endtex
+
+!_ ================================================================================================================================
+ 
+ !! 1. Calculate crown area from woodmass
+
+    IF ( is_tree(pft) ) THEN
+       
+       DO l = 1,ncirc
+         
+          ! Woodmass of an individual tree
+          woodmass_ind = biomass_temp(l,isapabove) + biomass_temp(l,iheartabove) + &
+               biomass_temp(l,isapbelow) + biomass_temp(l,iheartbelow)
+ 
+          ! Crown area of that individual
+          ! cn = pipe_tune1*sqrt(4/pi*ba)**pipe_tune_exp_coeff 
+          wood_to_cn_eff(l) = pipe_tune1(pft) * SQRT( 4/pi*(pi/4*(woodmass_ind/&
+               (tree_ff(pft)*pipe_density(pft)*pipe_tune2(pft)))**(2./pipe_tune3(pft)))**&
+               (pipe_tune3(pft)&
+               /(pipe_tune3(pft)+2)) ) ** pipe_tune_exp_coeff(pft)
+                
+       ENDDO
+
+    ELSE
+
+       WRITE(numout,*) 'pft ',pft
+       CALL ipslerr_p (3,'wood_to_cn_eff', &
+            'wood_to_cn_eff is not defined for this PFT.', &
+            'See the output file for more details.','')
+
+    ENDIF
+
+  END FUNCTION wood_to_cn_eff
+
+
+!! ================================================================================================================================
+!! FUNCTION     : wood_to_cv
+!!
+!>\BRIEF        Calculate crown volume from woody biomass making use of allometric relationships
+!!
+!! DESCRIPTION : Calculate basal areadiameter of an individual tree from the woody biomass of that tree making 
+!! use of allometric relationships:
+!! (i) Basal area is written as a function of wood_mass: woodmass_ind = tree_ff*pipe_density*ba*height
+!! (ii) height = pipe_tune2 * sqrt( 4/pi*ba ) ** pipe_tune3
+!! (iii) cn = pipe_tune1 * sqrt( 4/pi*ba ) ** pipe_tune_exp_coeff  
+!! (iv) cv = 4.0 / 3.0 * pi * ( SQRT( cn/pi ) ) ** 3
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : diameter (m3 ind-1)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION wood_to_cv(biomass_temp, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                                          :: pft               !! PFT number (-)
+    REAL(r_std), DIMENSION(:,:)                             :: biomass_temp      !! Biomass of an individual tree within a circ 
+                                                                                 !! class @tex $(m^{2} ind^{-1})$ @endtex 
+
+    !! 0.2 Output variables
+                
+    REAL(r_std), DIMENSION(ncirc)                           :: wood_to_cv        !! Crown volume of an individual tree 
+                                                                                 !! @tex $(m^{2} ind{-1})$ @endtex
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                          :: l                 !! Index
+    REAL(r_std)                                             :: woodmass_ind      !! Woodmass of an individual tree
+                                                                                 !! @tex $(gC ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                           :: dia               !! Diameter of an individual tree (m)
+
+!_ ================================================================================================================================
+ 
+ !! 1. Calculate crown volume from woodmass
+
+    IF ( is_tree(pft) ) THEN
+
+       ! Crown diameter of the individual tree (m2 ind-1)  
+       dia(:) = (4./pi*wood_to_cn(biomass_temp(:,:),pft))**(1./2.)
+       wood_to_cv(:) = pi/6.*dia(:)**3.  
+       ! WRITE(numout,*) 'wood_to_cv, ', wood_to_cv(:)
+
+    ELSE
+
+       WRITE(numout,*) 'pft ',pft
+       CALL ipslerr_p (3,'wood_to_cv', &
+            'wood_to_cv is not defined for this PFT.', &
+            'See the output file for more details.','')
+
+    ENDIF
+
+ END FUNCTION wood_to_cv 
+
+   !! ================================================================================================================================
+!! FUNCTION     : wood_to_cv_eff
+!!
+!>\BRIEF        Calculate crown volume from woody biomass making use of allometric relationships
+!!
+!! DESCRIPTION : Calculate basal areadiameter of an individual tree from the woody biomass of that tree making 
+!! use of allometric relationships:
+!! (i) Basal area is written as a function of wood_mass: woodmass_ind = tree_ff*pipe_density*ba*height
+!! (ii) height = pipe_tune2 * sqrt( 4/pi*ba ) ** pipe_tune3
+!! (iii) cn = pipe_tune1 * sqrt( 4/pi*ba ) ** pipe_tune_exp_coeff  
+!! (iv) cv = 4.0 / 3.0 * pi * ( SQRT( cn/pi ) ) ** 3
+!! 
+!! NOTE: the difference between this and wood_to_cv is that this include aboveground and belowground
+!!       biomass in the calculation
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : diameter (m3 ind-1)
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION wood_to_cv_eff(biomass_temp, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                                          :: pft               !! PFT number (-)
+    REAL(r_std), DIMENSION(:,:)                             :: biomass_temp      !! Biomass of an individual tree within a circ 
+                                                                                 !! class @tex $(m^{2} ind^{-1})$ @endtex 
+
+    !! 0.2 Output variables
+                
+    REAL(r_std), DIMENSION(ncirc)                           :: wood_to_cv_eff    !! Crown volume of an individual tree 
+                                                                                 !! @tex $(m^{2} ind{-1})$ @endtex
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                          :: l                 !! Index
+    REAL(r_std)                                             :: woodmass_ind      !! Woodmass of an individual tree
+                                                                                 !! @tex $(gC ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                           :: dia               !! Diameter of an individual tree (m)
+
+!_ ================================================================================================================================
+ 
+ !! 1. Calculate crown volume from woodmass
+
+    IF ( is_tree(pft) ) THEN
+
+       ! Crown diameter of the individual tree (m2 ind-1)  
+       dia(:) = (4./pi*wood_to_cn_eff(biomass_temp(:,:),pft))**(1./2.)
+       wood_to_cv_eff(:) = pi/6.*dia(:)**3.  
+       ! WRITE(numout,*) 'wood_to_cv_eff, ', wood_to_cv_eff(:)
+
+    ELSE
+
+       WRITE(numout,*) 'pft ',pft
+       CALL ipslerr_p (3,'wood_to_cv_eff', &
+            'wood_to_cv_eff is not defined for this PFT.', &
+            'See the output file for more details.','')
+
+    ENDIF
+
+  END FUNCTION wood_to_cv_eff
+
+
+
+!! ================================================================================================================================
+!! FUNCTION     : wood_to_volume
+!!
+!>\BRIEF        This allometric function computes volume as a function of 
+!! biomass at stand scale. Volume \f$(m^3 m^{-2}) = f(biomass (gC m^{-2}))\f$
+!!
+!! DESCRIPTION : None
+!!
+!! RECENT CHANGE(S): None
+!! 
+!! RETURN VALUE : biomass_to_volume
+!!
+!! REFERENCE(S)	: See above, module description.
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+
+  FUNCTION wood_to_volume(biomass,pft,branch_ratio,inc_branches)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    REAL(r_std), DIMENSION(:)   :: biomass              !! Stand biomass @tex $(gC m^{-2})$ @endtex  
+    REAL(r_std)                 :: branch_ratio         !! Branch ratio of sap and heartwood biomass
+                                                        !! unitless
+    INTEGER(i_std)              :: pft                  !! Plant functional type (unitless)
+    INTEGER(i_std)              :: inc_branches         !! Include the branches in the volume calculation?
+                                                        !! 0: exclude the branches from the volume calculation 
+                                                        !! (thus correct the biomass for the branch ratio)
+                                                        !! 1: include the branches in the volume calculation
+                                                        !! (thus use all aboveground biomass)
+                                    
+    
+
+    !! 0.2 Output variables
+
+    REAL(r_std)                 :: wood_to_volume       !! The volume of wood per square meter 
+                                                        !!  @tex $(m^3 m^{-2})$ @endtex
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    
+    REAL(r_std)                 :: woody_biomass        !! Woody biomass at the stand level 
+                                                        !! @tex $(gC m^{-2})$ @endtex
+
+!_ ================================================================================================================================
+
+ !! 1. Volume to biomass
+
+    ! Woody biomass used in the calculation
+    IF (inc_branches .EQ. 0) THEN
+
+       woody_biomass=(biomass(isapabove)+biomass(iheartabove))*(un - branch_ratio)
+
+    ELSEIF (inc_branches .EQ. 1) THEN
+
+       woody_biomass=(biomass(isapabove)+biomass(iheartabove))
+
+    ELSE
+
+    ENDIF
+
+    ! Wood volume expressed in m**3 / m**2
+    wood_to_volume = woody_biomass/(pipe_density(pft))
+
+  END FUNCTION wood_to_volume
+
+
+
+!! ================================================================================================================================
+!! FUNCTION     : biomass_to_lai
+!!
+!>\BRIEF        Calculate the LAI based on the leaf biomass
+!!
+!! DESCRIPTION : Calculates the LAI of a PFT/grid square based on the leaf biomass
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : ::LAI [m**2 m**{-2}]
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION biomass_to_lai(leaf_biomass, pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std)                                          :: pft               !! PFT number (-)
+    REAL(r_std)                                             :: leaf_biomass      !! Biomass of the leaves
+                                                                                 !! @tex $(gC m^{-2})$ @endtex 
+
+
+    !! 0.2 Output variables
+                
+    REAL(r_std)                                             :: biomass_to_lai    !! Leaf area index 
+                                                                                 !! @tex $(m^{2} m^{-2})$ @endtex 
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std)                                             :: impose_lai         !! LAI read from run.def
+!_ ================================================================================================================================
+ 
+    !! 1. Calculate the LAI from the leaf biomass
+
+    biomass_to_lai = leaf_biomass * sla(pft)
+     
+!!$    !+++++++++ TEMP ++++++++++
+!!$    ! This is a perfect place to hack the code to make it run with
+!!$    ! constant lai
+!!$    WRITE(numout,*) 'WARNING ERROR: Using fake lai values for testing!'
+!!$    biomass_to_lai=3.79052
+!!$    !+++++++++++++++++++++++++
+
+            !+++++++ TEMP ++++++++++
+            ! This code is only used evaluation of the performance of the multi-layer energy budget. 
+            ! To reduce the complexity of the tests we want to impose the LAI and its vertical distribution. 
+            ! The solution is not very elegant but it works. 
+              IF (ld_fake_height) THEN
+            ! In order to imposed lai, we read the TOTAL_LAI from run.def
+              CALL getin_p('TOTAL_LAI', impose_lai)
+            ! This part of code reset the sla vale to match which alow modeled LAI equal to TOTAL LAI. 
+            ! Althought this is ugly way to match the modeled LAI and impose LAI. 
+            ! You probably need to go to your ORCHIDEE out put file to find out the suitable SLA value 
+            ! and reset it agin in the run.def.
+            ! So, we impose LAI & structure for a quick testing the performance of multilayer energy budget
+            ! without changing the leaf_biomass.    
+                 IF ( leaf_biomass .GT. 0.0) THEN
+                    sla(pft)=impose_lai/leaf_biomass
+                      WRITE(numout,'(A,F20.8)') 'USE A FAKE SLA BASED ON imposed LAI/LEAFMASS=', sla(pft)
+                 ENDIF 
+                    biomass_to_lai=leaf_biomass*sla(pft) 
+              ENDIF 
+           !++++++++++++++++++++++++
+
+     END FUNCTION biomass_to_lai
+
+
+!! ================================================================================================================================
+!! FUNCTION     : Nmax
+!!
+!>\BRIEF        This function determines the maximum number of trees per hectare for 
+!! a given quadratic mean diameter (Dg). It applies the self-thinning principle 
+!! of Reineke (1933), with Dg instead of mean diameter (Dhote 1999).
+!! Parameterization: Dhote (1999) for broad-leaved and Vacchiano (2008)
+!! for needle-leaved.
+!!
+!! DESCRIPTION : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : Nmax
+!!
+!! REFERENCE(S)   : See above, module description.
+!!
+!! FLOWCHART   : None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION Nmax(Dg,no_pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    REAL(r_std)      :: Dg              !! Quadratic mean diameter (cm)
+    INTEGER(i_std)   :: no_pft          !! Plant functional type (unitless) 
+
+    !! 0.2 Output variables
+
+    REAL(r_std)      :: Nmax            !! Maximum number of trees according to the self-thinning model
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+!_ ================================================================================================================================
+ !! 1. maximum number of trees per hectare for a given quadratic mean diameter
+
+    IF (is_tree(no_pft)) THEN
+
+       ! thinning curve of the MTC
+       Nmax = (Dg/alpha_self_thinning(no_pft))**(un/beta_self_thinning(no_pft))
+
+       ! Truncate the range to avoid huge numbers due the exponental model used to describe self-thinning
+       Nmax = MIN( Nmax, nmaxtrees(no_pft) )
+       Nmax = MAX( Nmax, dens_target(no_pft) )
+
+    ELSE
+
+       WRITE(numout,*) 'Self thinning is not defined for PFT, ', no_pft
+       CALL ipslerr_p (3,'nmax', &
+            'Self thinning is not defined for this PFT.', &
+            'See the output file for more details.','')
+
+    ENDIF
+
+  END FUNCTION Nmax
+
+
+!! ================================================================================================================================
+!! FUNCTION     : Nmaxyield
+!!
+!>\BRIEF        This function determines the maximum number of trees per hectare for 
+!! a given quadratic mean diameter (Dg). It applies the 75 percentile  of the European 
+!! yield tables
+!!
+!! DESCRIPTION : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : Nmaxyield
+!!
+!! REFERENCE(S)   : See above, module description.
+!!
+!! FLOWCHART   : None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION Nmaxyield(Dg,no_pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    REAL(r_std)      :: Dg              !! Quadratic mean diameter (cm)
+    INTEGER(i_std)   :: no_pft          !! Plant functional type (unitless) 
+
+    !! 0.2 Output variables
+
+    REAL(r_std)      :: Nmaxyield       !! Maximum number of trees according to the self-thinning model
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+!_ ================================================================================================================================
+ !! 1. maximum number of trees per hectare for a given quadratic mean diameter
+
+    IF (is_tree(no_pft)) THEN
+
+       ! thinning curve of the MTC
+       Nmaxyield = (Dg/alpha_rdi_upper(no_pft))**(un/beta_rdi_upper(no_pft))
+
+       ! Truncate the range to avoid huge numbers due the exponental model used to describe self-thinning
+       Nmaxyield = MIN( Nmaxyield, nmaxtrees(no_pft) )
+       Nmaxyield = MAX( Nmaxyield, dens_target(no_pft) )
+
+    ELSE
+
+       WRITE(numout,*) 'Self thinning is not defined for PFT, ', no_pft
+       CALL ipslerr_p (3,'Nmaxyield', &
+            'Self thinning is not defined for this PFT.', &
+            'See the output file for more details.','')
+
+    ENDIF
+
+  END FUNCTION Nmaxyield
+
+
+!! ================================================================================================================================
+!! FUNCTION     : Nminyield
+!!
+!>\BRIEF        This function determines the minimum number of trees per hectare for 
+!! a given quadratic mean diameter (Dg). It applies the 25 percentile of the European 
+!! yield tables
+!!
+!! DESCRIPTION : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : Nminyield
+!!
+!! REFERENCE(S)   : See above, module description.
+!!
+!! FLOWCHART   : None
+!! \n
+!_ ================================================================================================================================
+   
+  FUNCTION Nminyield(Dg,no_pft)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    REAL(r_std)      :: Dg              !! Quadratic mean diameter (cm)
+    INTEGER(i_std)   :: no_pft          !! Plant functional type (unitless) 
+
+    !! 0.2 Output variables
+
+    REAL(r_std)      :: Nminyield       !! Minimum number of trees according to the self-thinning model
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+!_ ================================================================================================================================
+ !! 1. minimum number of trees per hectare for a given quadratic mean diameter
+
+    IF (is_tree(no_pft)) THEN
+
+       ! thinning curve of the MTC
+       Nminyield = (Dg/alpha_rdi_lower(no_pft))**(un/beta_rdi_lower(no_pft))
+
+       ! Truncate the range to avoid huge numbers due the exponental model used to describe self-thinning
+        
+       Nminyield = MIN( Nminyield, nmaxtrees(no_pft) )
+       Nminyield = MAX( Nminyield, dens_target(no_pft) )
+
+    ELSE
+
+       WRITE(numout,*) 'Self thinning is not defined for PFT, ', no_pft
+       CALL ipslerr_p (3,'Nminyield', &
+            'Self thinning is not defined for this PFT.', &
+            'See the output file for more details.','')
+
+
+    ENDIF
+
+  END FUNCTION Nminyield
+
+
+!! ================================================================================================================================
+!! SUBROUTINE  : distribute_mortality_biomass
+!!
+!>\BRIEF       Distributes biomass that is going to be killed by natural
+!!             causes (not self thinning) over circ classes.
+!!
+!! DESCRIPTION : Mortality is going to kill a certain amount of biomass
+!!               in forests every day.  Since we have circumference classes
+!!               now for our forests, we need to determine which classes
+!!               of trees will suffer from this environmental mortality.
+!!               Right now we are taking an exponential distribution.
+!!               Notice that this is NOT the same as redistributing biomass
+!!               after one of the circ classes becomes empty.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::circ_class_kill
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+  SUBROUTINE distribute_mortality_biomass ( bm_difference, ddf_temp, circ_class_n_temp, &
+       circ_class_biomass_temp, circ_class_kill_temp )
+
+ !! 0. Variable and parameter description
+
+    !! 0.1 Input variables
+    REAL(r_std),INTENT(in)                                    :: bm_difference !! the biomass to distribute
+    REAL(r_std),INTENT(in)                                    :: ddf_temp !! the death_distribution_factor for this pft
+    REAL(r_std),DIMENSION(:),INTENT(in)                       :: circ_class_n_temp !! circ_class_n for this point/PFT
+    REAL(r_std),DIMENSION(:,:),INTENT(in)                     :: circ_class_biomass_temp !! circ_class_biomass for 
+                                                                          !! this point/PFT
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+    REAL(r_std),DIMENSION(:),INTENT(inout)                    :: circ_class_kill_temp !! circ_class_kill for 
+                                                                                      !! this point/PFT/pool
+    !! 0.4 Local variables
+    REAL(r_std), DIMENSION(ncirc)                             :: biomass_desired    !! The biomass that dies naturally
+    REAL(r_std), DIMENSION(ncirc)                             :: death_distribution !! The fraction of biomass taken from
+                                                                                    !! each circ class for mortality.
+    LOGICAL                                                   :: ldone              !! Flag to exit a loop
+    REAL(r_std)                                               :: scale_factor       !! 
+    REAL(r_std)                                               :: sum_total          !! 
+    REAL(r_std)                                               :: leftover_bm        !! excess biomass that we need to kill 
+    REAL(r_std)                                               :: living_biomass      !! summed biomass
+    REAL(r_std)                                               :: living_trees       !! summed biomass
+    INTEGER                                                   :: icir
+
+!_ ================================================================================================================================
+
+    IF(ncirc == 1)THEN
+
+       ! This is the easy case.  All of our biomass will be taken from the only
+       ! circumference class that we have.
+       circ_class_kill_temp(1)=circ_class_kill_temp(1)+&
+            bm_difference/SUM(circ_class_biomass_temp(1,:))
+
+       RETURN
+    ENDIF
+
+    ! Here we assume an exponential distribution, arranged so that
+    ! ddf_temp times more biomass is taken from the largest circ class
+    ! compared to the smallest.
+    biomass_desired(:)=zero
+    death_distribution(:)=un
+    scale_factor=ddf_temp**(un/REAL(ncirc-1))
+    DO icir=2,ncirc
+       death_distribution(icir)=death_distribution(icir-1)*scale_factor
+    ENDDO
+    ! Normalize it
+    ! added by yitong yao Feb 24 2020 15:33  
+    ! only kill circ meet the condition 
+    ! added by yitong yao Feb 24 2020 15:40 
+
+    sum_total=SUM(death_distribution(:))
+    death_distribution(:)=death_distribution(:)/sum_total
+
+    ! Ideally, how much is killed from each class?  Be careful to include
+    ! what was killed in self-thinning here!  If we don't, we may try to kill
+    ! more biomass than is available in the loop below.
+    DO icir=1,ncirc
+       biomass_desired(icir)=death_distribution(icir)*bm_difference !+&
+    !        circ_class_kill_temp(icir)*SUM(circ_class_biomass_temp(icir,:))
+    ENDDO
+
+    ! Right now, we know how much biomass we want to kill in each
+    ! class (biomass_desired).  What we will do now is to loop through
+    ! all the circ_classes and see if we have this much biomass
+    ! in each class still alive.  The total amount of vegetation still
+    ! alive is circ_class_n_temp(icir)-circ_class_kill_temp(icir).  If
+    ! this number of individuals cannot give us the total biomass that
+    ! we need, we keep track of a residual quantity, leftover_bm, which
+    ! we try to take from other circ_classes.  It's possible that we
+    ! will have to loop several times, which makes things more complicated.
+
+    ldone=.FALSE.
+    leftover_bm=zero
+    DO
+       DO icir=ncirc,1,-1
+
+          living_trees=circ_class_n_temp(icir)-circ_class_kill_temp(icir)
+          living_biomass=&
+               SUM(circ_class_biomass_temp(icir,:))*living_trees
+          biomass_desired(icir)=biomass_desired(icir)+leftover_bm
+
+          IF(living_biomass .LE. biomass_desired(icir))THEN
+
+             ! We can't get everything from this class, so we kill whatever is left.
+             leftover_bm=biomass_desired(icir)-living_biomass
+             biomass_desired(icir)=zero
+             circ_class_kill_temp(icir)=circ_class_kill_temp(icir)+&
+                  living_trees
+
+          ELSE
+
+             ! We have enough in this class.
+             circ_class_kill_temp(icir)=circ_class_kill_temp(icir)+&
+                  biomass_desired(icir)/SUM(circ_class_biomass_temp(icir,:))
+             biomass_desired(icir)=zero
+             leftover_bm=zero
+
+          ENDIF ! living_biomass .LE. biomass_desired(icir)
+
+       ENDDO ! loop over circ classes
+
+       IF(leftover_bm .LE. min_stomate) EXIT
+
+       ! it's possible that we don't have enough biomass left to kill what needs to be
+       ! killed, so everything just dies.  I cannot think of a case where this
+       ! would happen, though, since mortality should always be a percentage of the
+       ! total biomass.
+       ldone=.TRUE.
+       DO icir=1,ncirc
+
+          IF( circ_class_kill_temp(icir) .LT. circ_class_n_temp(icir) ) &
+               ldone=.FALSE.  
+
+       ENDDO
+
+       IF(ldone)EXIT ! All our biomass is dead, and we still want to kill more!
+
+    ENDDO
+
+    
+
+  END SUBROUTINE distribute_mortality_biomass
+  
+  ! added by yitong yao 07 Jan 10:05
+        
+
+  ! added by yitong yao Feb 24 2020 15:47 
+  ! new distribute routine 
+
+  SUBROUTINE distribute_mortality_biomass_yyt ( bm_difference, ddf_temp, circ_class_n_temp, &
+       circ_class_biomass_temp, circ_class_kill_temp, circ_class_mor_temp )
+
+ !! 0. Variable and parameter description
+
+    !! 0.1 Input variables
+    REAL(r_std),INTENT(in)                                    :: bm_difference !! the biomass to distribute
+    REAL(r_std),INTENT(in)                                    :: ddf_temp !! the death_distribution_factor for this pft
+    REAL(r_std),DIMENSION(:),INTENT(in)                       :: circ_class_n_temp !! circ_class_n for this point/PFT
+    REAL(r_std),DIMENSION(:,:),INTENT(in)                     :: circ_class_biomass_temp !! circ_class_biomass for 
+                                                                          !! this point/PFT
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+    REAL(r_std),DIMENSION(:),INTENT(inout)                    :: circ_class_kill_temp !! circ_class_kill for 
+                                                                                      !! this point/PFT/pool
+    REAL(r_std),DIMENSION(:),INTENT(in)                       :: circ_class_mor_temp 
+    !! 0.4 Local variables
+    REAL(r_std), DIMENSION(ncirc)                             :: biomass_desired    !! The biomass that dies naturally
+    REAL(r_std), DIMENSION(ncirc)                             :: death_distribution !! The fraction of biomass taken from
+                                                                                    !! each circ class for mortality.
+    LOGICAL                                                   :: ldone              !! Flag to exit a loop
+    REAL(r_std)                                               :: scale_factor       !! 
+    REAL(r_std)                                               :: sum_total          !! 
+    REAL(r_std)                                               :: leftover_bm        !! excess biomass that we need to kill 
+    REAL(r_std)                                               :: living_biomass      !! summed biomass
+    REAL(r_std)                                               :: living_trees       !! summed biomass
+    INTEGER                                                   :: icir
+
+!_ ================================================================================================================================
+
+    IF(ncirc == 1)THEN
+
+       ! This is the easy case.  All of our biomass will be taken from the only
+       ! circumference class that we have.
+       circ_class_kill_temp(1)=circ_class_kill_temp(1)+&
+            bm_difference/SUM(circ_class_biomass_temp(1,:))
+
+       RETURN
+    ENDIF
+
+    ! Here we assume an exponential distribution, arranged so that
+    ! ddf_temp times more biomass is taken from the largest circ class
+    ! compared to the smallest.
+    biomass_desired(:)=zero
+    death_distribution(:)=un
+    scale_factor=ddf_temp**(un/REAL(ncirc-1))
+    DO icir=2,ncirc
+       death_distribution(icir)=death_distribution(icir-1)*scale_factor
+    ENDDO
+    ! Normalize it
+    ! added by yitong yao Feb 24 2020 15:33  
+    ! only kill circ meet the condition 
+    DO icir=1,ncirc
+        IF (circ_class_mor_temp(icir) ==  0) THEN 
+            death_distribution(icir)=0
+        ENDIF
+    ENDDO 
+    ! added by yitong yao Feb 24 2020 15:40 
+
+    sum_total=SUM(death_distribution(:))
+    death_distribution(:)=death_distribution(:)/sum_total
+
+    ! Ideally, how much is killed from each class?  Be careful to include
+    ! what was killed in self-thinning here!  If we don't, we may try to kill
+    ! more biomass than is available in the loop below.
+    DO icir=1,ncirc
+       biomass_desired(icir)=death_distribution(icir)*bm_difference !+&
+    !        circ_class_kill_temp(icir)*SUM(circ_class_biomass_temp(icir,:))
+    ENDDO
+
+    ! Right now, we know how much biomass we want to kill in each
+    ! class (biomass_desired).  What we will do now is to loop through
+    ! all the circ_classes and see if we have this much biomass
+    ! in each class still alive.  The total amount of vegetation still
+    ! alive is circ_class_n_temp(icir)-circ_class_kill_temp(icir).  If
+    ! this number of individuals cannot give us the total biomass that
+    ! we need, we keep track of a residual quantity, leftover_bm, which
+    ! we try to take from other circ_classes.  It's possible that we
+    ! will have to loop several times, which makes things more complicated.
+
+    ldone=.FALSE.
+    leftover_bm=zero
+    DO
+       DO icir=ncirc,1,-1
+
+          living_trees=circ_class_n_temp(icir)-circ_class_kill_temp(icir)
+          living_biomass=&
+               SUM(circ_class_biomass_temp(icir,:))*living_trees
+          biomass_desired(icir)=biomass_desired(icir)+leftover_bm
+
+          IF(living_biomass .LE. biomass_desired(icir))THEN
+
+             ! We can't get everything from this class, so we kill whatever is left.
+             leftover_bm=biomass_desired(icir)-living_biomass
+             biomass_desired(icir)=zero
+             circ_class_kill_temp(icir)=circ_class_kill_temp(icir)+&
+                  living_trees
+
+          ELSE
+
+             ! We have enough in this class.
+             circ_class_kill_temp(icir)=circ_class_kill_temp(icir)+&
+                  biomass_desired(icir)/SUM(circ_class_biomass_temp(icir,:))
+             biomass_desired(icir)=zero
+             leftover_bm=zero
+
+          ENDIF ! living_biomass .LE. biomass_desired(icir)
+
+       ENDDO ! loop over circ classes
+
+       IF(leftover_bm .LE. min_stomate) EXIT
+
+       ! it's possible that we don't have enough biomass left to kill what needs to be
+       ! killed, so everything just dies.  I cannot think of a case where this
+       ! would happen, though, since mortality should always be a percentage of the
+       ! total biomass.
+       ldone=.TRUE.
+       DO icir=1,ncirc
+
+          IF( circ_class_kill_temp(icir) .LT. circ_class_n_temp(icir) ) &
+               ldone=.FALSE.  
+
+       ENDDO
+
+       IF(ldone)EXIT ! All our biomass is dead, and we still want to kill more!
+
+    ENDDO
+
+    
+
+  END SUBROUTINE distribute_mortality_biomass_yyt
+  
+
+  
+
+  ! added by yitong yao March 18 2020 20:42 
+  ! new distribute routine 
+
+  SUBROUTINE distribute_mortality_biomass_new ( bm_difference, ddf_temp, circ_class_n_temp, &
+       circ_class_biomass_temp, circ_class_kill_temp, circ_class_mor_temp )
+
+ !! 0. Variable and parameter description
+
+    !! 0.1 Input variables
+    REAL(r_std),INTENT(in)                                    :: bm_difference !! the biomass to distribute
+    REAL(r_std),INTENT(in)                                    :: ddf_temp !! the death_distribution_factor for this pft
+    REAL(r_std),DIMENSION(:),INTENT(in)                       :: circ_class_n_temp !! circ_class_n for this point/PFT
+    REAL(r_std),DIMENSION(:,:),INTENT(in)                     :: circ_class_biomass_temp !! circ_class_biomass for 
+                                                                          !! this point/PFT
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+    REAL(r_std),DIMENSION(:),INTENT(inout)                    :: circ_class_kill_temp !! circ_class_kill for 
+                                                                                      !! this point/PFT/pool
+    REAL(r_std),DIMENSION(:),INTENT(in)                       :: circ_class_mor_temp 
+    !! 0.4 Local variables
+    REAL(r_std), DIMENSION(ncirc)                             :: biomass_desired    !! The biomass that dies naturally
+    REAL(r_std), DIMENSION(ncirc)                             :: death_distribution !! The fraction of biomass taken from
+                                                                                    !! each circ class for mortality.
+    LOGICAL                                                   :: ldone              !! Flag to exit a loop
+    REAL(r_std)                                               :: scale_factor       !! 
+    REAL(r_std)                                               :: sum_total          !! 
+    REAL(r_std)                                               :: leftover_bm        !! excess biomass that we need to kill 
+    REAL(r_std)                                               :: living_biomass      !! summed biomass
+    REAL(r_std)                                               :: living_trees       !! summed biomass
+    INTEGER                                                   :: icir
+
+!_ ================================================================================================================================
+
+    IF(ncirc == 1)THEN
+
+       ! This is the easy case.  All of our biomass will be taken from the only
+       ! circumference class that we have.
+       circ_class_kill_temp(1)=circ_class_kill_temp(1)+&
+            bm_difference/SUM(circ_class_biomass_temp(1,:))
+
+       RETURN
+    ENDIF
+
+    ! Here we assume an exponential distribution, arranged so that
+    ! ddf_temp times more biomass is taken from the largest circ class
+    ! compared to the smallest.
+    biomass_desired(:)=zero
+    death_distribution(:)=un
+    scale_factor=ddf_temp**(un/REAL(ncirc-1))
+    DO icir=2,ncirc
+       death_distribution(icir)=death_distribution(icir-1)*scale_factor
+    ENDDO
+    ! Normalize it
+    ! added by yitong yao Feb 24 2020 15:33  
+    ! only kill circ meet the condition 
+    DO icir=1,ncirc
+        IF (circ_class_mor_temp(icir) ==  0) THEN 
+            death_distribution(icir)=0
+        ENDIF
+    ENDDO 
+    ! added by yitong yao Feb 24 2020 15:40 
+
+    sum_total=SUM(death_distribution(:))
+    death_distribution(:)=death_distribution(:)/sum_total
+
+    ! Ideally, how much is killed from each class?  Be careful to include
+    ! what was killed in self-thinning here!  If we don't, we may try to kill
+    ! more biomass than is available in the loop below.
+    DO icir=1,ncirc
+       biomass_desired(icir)=death_distribution(icir)*bm_difference !+&
+    !        circ_class_kill_temp(icir)*SUM(circ_class_biomass_temp(icir,:))
+    ENDDO
+
+    ! Right now, we know how much biomass we want to kill in each
+    ! class (biomass_desired).  What we will do now is to loop through
+    ! all the circ_classes and see if we have this much biomass
+    ! in each class still alive.  The total amount of vegetation still
+    ! alive is circ_class_n_temp(icir)-circ_class_kill_temp(icir).  If
+    ! this number of individuals cannot give us the total biomass that
+    ! we need, we keep track of a residual quantity, leftover_bm, which
+    ! we try to take from other circ_classes.  It's possible that we
+    ! will have to loop several times, which makes things more complicated.
+
+    ldone=.FALSE.
+    leftover_bm=zero
+    DO
+       DO icir=ncirc,1,-1
+
+          living_trees=circ_class_n_temp(icir)-circ_class_kill_temp(icir)
+          living_biomass=&
+               SUM(circ_class_biomass_temp(icir,:))*living_trees
+          biomass_desired(icir)=biomass_desired(icir)+leftover_bm
+
+          IF(living_biomass .LE. biomass_desired(icir))THEN
+
+             ! We can't get everything from this class, so we kill whatever is left.
+             leftover_bm=biomass_desired(icir)-living_biomass
+             biomass_desired(icir)=zero
+             circ_class_kill_temp(icir)=circ_class_kill_temp(icir)+&
+                  living_trees
+
+          ELSE
+
+             ! We have enough in this class.
+             circ_class_kill_temp(icir)=circ_class_kill_temp(icir)+&
+                  biomass_desired(icir)/SUM(circ_class_biomass_temp(icir,:))
+             biomass_desired(icir)=zero
+             leftover_bm=zero
+
+          ENDIF ! living_biomass .LE. biomass_desired(icir)
+
+       ENDDO ! loop over circ classes
+
+       IF(leftover_bm .LE. min_stomate) EXIT
+
+       ! it's possible that we don't have enough biomass left to kill what needs to be
+       ! killed, so everything just dies.  I cannot think of a case where this
+       ! would happen, though, since mortality should always be a percentage of the
+       ! total biomass.
+       ldone=.TRUE.
+       DO icir=1,ncirc
+
+          IF( circ_class_kill_temp(icir) .LT. circ_class_n_temp(icir) ) &
+               ldone=.FALSE.  
+
+       ENDDO
+
+       IF(ldone)EXIT ! All our biomass is dead, and we still want to kill more!
+
+    ENDDO
+
+    
+
+  END SUBROUTINE distribute_mortality_biomass_new
+  
+
+
+
+  ! added by yitong yao March 18 2020 20:42 
+
+
+
+
+  ! added by yitong yao Feb 24 2020 15:47 
+
+
+
+  
+  SUBROUTINE P50_vary_class (circ_class_dia_temp,circ_class_P50_temp)
+  !! 0. variable and parameter description 
+  REAL(r_std),DIMENSION(ncirc),INTENT(out)       :: circ_class_P50_temp
+  REAL(r_std),DIMENSION(ncirc),INTENT(in)        :: circ_class_dia_temp
+  INTEGER                                       :: icir
+  
+  DO icir=1,ncirc 
+     IF (circ_class_dia_temp(icir) .GT. 0.50) THEN 
+        circ_class_P50_temp(icir)= -1.0 / circ_class_dia_temp(icir)
+     ELSE
+        circ_class_P50_temp(icir)=circ_class_dia_temp(icir) * 3.125 - 3.5625
+     ENDIF
+  ENDDO
+ ! dia * 4.75 - 3.675
+  END SUBROUtINE P50_vary_class
+  !! 
+  ! added by yitong yao 07 Jan 10:06 above line 
+
+!! ================================================================================================================================
+!! SUBROUTINE  : check_biomass_sync
+!!
+!>\BRIEF       
+!!
+!! DESCRIPTION : 
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+  SUBROUTINE check_biomass_sync ( check_point, npts, biomass, &
+       circ_class_biomass, circ_class_n , ind, &
+       lsync, bm_sync)
+
+ !! 0. Variable and parameter description
+
+    !! 0.1 Input variables
+    INTEGER(i_std), INTENT(in)                                 :: npts                 !! Domain size (unitless)
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(in)              :: circ_class_biomass   !! Biomass of the componets of the model  
+                                                                                       !! tree within a circumference
+                                                                                       !! class @tex $(gC ind^{-1})$ @endtex  
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)                  :: circ_class_n         !! Number of individuals in each circ class
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(in)                :: biomass              !! Stand level biomass 
+                                                                                       !! @tex $(gC m^{-2})$ @endtex
+    CHARACTER(*),INTENT(in)                                    :: check_point          !! A flag to indicate at which
+                                                                                       !! point in the code we're doing
+                                                                                       !! this check
+    REAL(r_std), DIMENSION(:,:), INTENT(in)                    :: ind                  !! Density of individuals 
+                                                                                       !! @tex $(m^{-2})$ @endtex 
+
+    !! 0.2 Output variables
+    LOGICAL,INTENT(out)                                        :: lsync
+    REAL(r_std), DIMENSION(:,:,:), INTENT(out)                 :: bm_sync              !! The difference betweeen the
+                                                                                       !! biomass in the circ_classes and
+                                                                                       !! the total biomass 
+                                                                                       !! @tex $(gC m^{-2})$ @endtex
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER                                                    :: iele,ipts,ivm,ipar,icir
+    REAL(r_std)                                                :: total_circ_class_biomass
+    REAL(r_std),DIMENSION(ncirc)                               :: tree_size
+    LOGICAL                                                    :: lnegative
+    
+!_ ================================================================================================================================
+
+    lsync=.TRUE.
+    lnegative=.FALSE.
+
+    bm_sync(:,:,:)=zero
+
+    !++++++ TEMP ++++++
+    ! We gain 5-10% speed by skipping this routine
+       
+    !++++++++++++
+
+    ! Check to see if the biomass is not equal to the total biomass
+    ! in circ_class_biomass anywhere.
+    DO ipts=1,npts
+
+       DO ivm=1,nvm
+
+          ! Only woody PFTs have circumference classes therefore
+          ! only woody PFTs need to be syncronized
+          IF(.NOT. lbypass_cc)THEN
+             IF(is_tree(ivm)) THEN
+                tree_size(:)=zero
+                DO icir=1,ncirc
+                   tree_size(icir)=SUM(circ_class_biomass(ipts,ivm,icir,:,1))
+                ENDDO
+                DO icir=2,ncirc
+                   IF(tree_size(icir) .LT. tree_size(icir-1)-min_stomate)THEN
+                      WRITE(numout,*) 'ERROR: stopping in sync'
+                      WRITE(numout,*) check_point
+                      WRITE(numout,*) 'ipts,ivm: ',ipts,ivm
+                      WRITE(numout,*) 'tree_size(icir), tree_size(icir-1), ',&
+                           tree_size(icir), tree_size(icir-1), tree_size(icir) - tree_size(icir-1)  
+                      WRITE(numout,'(A,10F20.10)') 'icir, tree_size: ',icir, tree_size(:)
+                      CALL ipslerr_p (3,'check_biomass_sync', &
+                           'The size of the trees in the circ class are not monotonically increasing!',&
+                           'Look in the output file for more details.',&
+                           '')
+                   ENDIF
+                ENDDO
+             ENDIF
+          ENDIF
+          
+          DO iele=1,icarbon
+                
+             DO ipar=1,nparts
+                
+                total_circ_class_biomass=zero
+                DO icir=1,ncirc
+                   
+                   total_circ_class_biomass=total_circ_class_biomass+&
+                        circ_class_biomass(ipts,ivm,icir,ipar,iele)*circ_class_n(ipts,ivm,icir)
+
+                   ! Check as well to see if our biomass is ever negative.
+                   ! It really should not be.
+                   IF(circ_class_biomass(ipts,ivm,icir,ipar,iele) .LT. -min_stomate)THEN
+
+                      lnegative=.TRUE.
+                      WRITE(numout,*) '!***********************************'
+                      WRITE(numout,*) 'Error: Negative biomass component!'
+                      WRITE(numout,*) 'Check point: ',TRIM(check_point)
+                      WRITE(numout,*) 'circ_class_biomass(ipts,ivm,icir,ipar,iele) ',&
+                           circ_class_biomass(ipts,ivm,icir,ipar,iele)
+                      WRITE(numout,'(A,5I5)') 'ipts,ivm,icir,ipar,iele',ipts,ivm,icir,ipar,iele
+                      WRITE(numout,*) '!***********************************'
+
+                   ENDIF
+                ENDDO
+
+                IF(ABS(biomass(ipts,ivm,ipar,iele) -  &
+                     total_circ_class_biomass) .GT. sync_threshold)THEN
+
+                   WRITE(numout,*) '!***********************************'
+                   WRITE(numout,*) 'Biomass and circ_class_biomass are not equal!'
+                   WRITE(numout,*) 'Check point: ',TRIM(check_point)
+                   WRITE(numout,100) 'biomass(ipts,ivm,ipar,iele) ',&
+                        biomass(ipts,ivm,ipar,iele)
+                   WRITE(numout,100) 'total_circ_class_biomass ',&
+                        total_circ_class_biomass
+                   WRITE(numout,100) 'Difference: ',&
+                        ABS(biomass(ipts,ivm,ipar,iele) - total_circ_class_biomass)
+                   WRITE(numout,*) 'ipts,ivm,ipar,iele',ipts,ivm,ipar,iele
+                   WRITE(numout,*) '!***********************************'
+100                FORMAT(A,E20.10)
+                   lsync=.FALSE.
+
+                ENDIF
+
+             ENDDO
+
+             ! we are not going to save the biomass for every component right now,
+             ! just the total
+             bm_sync(ipts,ivm,iele)=zero
+
+             DO ipar=1,nparts
+                   
+
+                DO icir=1,ncirc
+
+                   bm_sync(ipts,ivm,iele)=bm_sync(ipts,ivm,iele)+&
+                        circ_class_biomass(ipts,ivm,icir,ipar,iele)*circ_class_n(ipts,ivm,icir)
+                ENDDO ! ncirc
+
+             ENDDO ! nparts
+
+             bm_sync(ipts,ivm,iele)=ABS(bm_sync(ipts,ivm,iele)-&
+                  SUM(biomass(ipts,ivm,:,iele)))
+
+          ENDDO ! nelements
+
+
+
+       ENDDO ! loop over PFTs
+
+    ENDDO ! loop over points
+ 
+    !---TEMP---
+    IF(ld_biomass)THEN
+       WRITE(numout,*) 'Check point: ',TRIM(check_point)
+       WRITE(numout,*) 'test_pft, test_grid: ',test_pft,test_grid
+       WRITE(numout,*) 'biomass (ileaf), ', biomass(test_grid,test_pft,ileaf,icarbon)
+       WRITE(numout,*) 'biomass (iwood), ', biomass(test_grid,test_pft,isapabove,icarbon) + &
+           biomass(test_grid,test_pft,isapbelow,icarbon) + biomass(test_grid,test_pft,iheartabove,icarbon) + &
+           biomass(test_grid,test_pft,iheartbelow,icarbon)
+       WRITE(numout,*) 'biomass (iroot), ', biomass(test_grid,test_pft,iroot,icarbon)
+       WRITE(numout,'(A,20F14.6)') 'biomassHHH, ',biomass(test_grid,test_pft,:,icarbon)
+       DO icir=1,ncirc
+          WRITE(numout,'(A,I1,20F14.6)') 'ccbiomass',icir,circ_class_biomass(test_grid,test_pft,icir,:,icarbon)
+       ENDDO
+       WRITE(numout,*) 'circ_class_biomass, ',&
+            SUM (SUM(circ_class_biomass(test_grid,test_pft,:,:,icarbon),2) * &
+            circ_class_n(test_grid,test_pft,:))
+       WRITE(numout,*) 'circ_class_n, ', SUM(circ_class_n(test_grid,test_pft,:))
+       WRITE(numout,*) 'circ_class_n(:), ', circ_class_n(test_grid,test_pft,:)
+       WRITE(numout,*) 'ind, ', ind(test_grid,test_pft)
+    ENDIF
+
+!!$    !----------
+
+    IF(.NOT. lsync) THEN
+       WRITE(numout,*) 'ERROR: stopping in sync #2'
+       WRITE(numout,*) 'Stopping'
+       CALL ipslerr_p (3,'check_biomass_sync', &
+            'circ_class_biomass*circ_class_n is not equal to the total biomass',&
+            'Look in the output file for more details.',&
+            '')
+
+    ENDIF
+    IF(lnegative) THEN
+       WRITE(numout,*) 'ERROR: negative biomass'
+       WRITE(numout,*) 'Stopping'
+       CALL ipslerr_p (3,'check_biomass_sync', &
+            'One of the biomass pools is negative!',&
+            'Look in the output file for more details.',&
+            '')
+    ENDIF
+
+  END SUBROUTINE check_biomass_sync
+
+END MODULE function_library
+
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parameters/pft_parameters.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parameters/pft_parameters.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parameters/pft_parameters.f90	(revision 7236)
@@ -0,0 +1,5501 @@
+! =================================================================================================================================
+! MODULE       : pft_parameters
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2011)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        This module initializes all the pft parameters in function of the
+!!              number of vegetation types and of the values chosen by the user.
+!!
+!!\n DESCRIPTION:  This module allocates and initializes the pft parameters in function of the number of pfts
+!!                 and the values of the parameters. \n
+!!                 The number of PFTs is read in intersurf.f90 (subroutine intsurf_config). \n
+!!                 Then we can initialize the parameters. \n
+!!                 This module is the result of the merge of constantes_co2, constantes_veg, stomate_constants.\n
+!!
+!! RECENT CHANGE(S): Josefine Ghattas 2013 : The declaration part has been extracted and moved to module pft_parameters_var
+!!
+!! REFERENCE(S)	: None
+!!
+!! SVN          :
+!! $HeadURL: $
+!! $Date: 2015-02-22 16:18:16 +0100 (Sun, 22 Feb 2015) $
+!! $Revision: 2555 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE pft_parameters
+
+  USE pft_parameters_var
+  USE constantes_mtc
+  USE constantes
+  USE ioipsl
+  USE ioipsl_para 
+  USE defprec
+! tzjwb
+  USE vertical_soil_var
+  
+  IMPLICIT NONE
+
+CONTAINS
+ !
+
+!! ================================================================================================================================
+!! SUBROUTINE   : pft_parameters_main
+!!
+!>\BRIEF          This subroutine initializes all the pft parameters in function of the
+!! number of vegetation types chosen by the user.
+!!
+!! DESCRIPTION  : This subroutine is called after the reading of the number of PFTS and the options 
+!!                activated by the user in the configuration files. (structure active_flags) \n
+!!                The allocation is done just before reading the correspondence table  between PFTs and MTCs
+!!                defined by the user in the configuration file.\n
+!!                With the correspondence table, the subroutine can initialize the pft parameters in function
+!!                of the flags activated (ok_sechiba, ok_stomate, ok_co2, routing, new_hydrol...) in order to
+!!                optimize the memory allocation. \n
+!!                If the number of PFTs and pft_to_mtc are not found, the standard configuration will be used
+!!                (13 PFTs, PFT = MTC). \n 
+!!                Some restrictions : the pft 1 can only be the bare soil and it is unique. \n
+!!                Algorithm : Build new PFT from 13 generic-PFT or meta-classes.
+!!                1. Read the number of PFTs in "run.def". If nothing is found, it is assumed that the user intend to use 
+!!                   the standard of PFTs (13).
+!!                2. Read the index vector in "run.def". The index vector associates one PFT to one meta-classe (or generic PFT).
+!!                   When the association is done, the PFT defined by the user inherited the default values from the meta classe.
+!!                   If nothing is found, it is assumed to use the standard index vector (PFT = MTC).
+!!                3. Check consistency
+!!                4. Memory allocation and initialization.
+!!                5. The parameters are read in the configuration file in intsurf_config (intersurf module).
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+ SUBROUTINE pft_parameters_main(active_flags)
+
+   IMPLICIT NONE
+
+   !! 0. Variables and parameters declaration
+
+   !! 0.1 Input variables 
+
+   TYPE(control_type),INTENT(in) :: active_flags   !! What parts of the code are activated ? (true/false)
+   
+   !! 0.4 Local variables  
+
+   INTEGER(i_std) :: j                             !! Index (unitless)
+
+!_ ================================================================================================================================ 
+   
+   !
+   ! PFT global
+   !
+
+   IF(l_first_pft_parameters) THEN
+
+      !! 1. First time step
+      IF(long_print) THEN
+         WRITE(numout,*) 'l_first_pft_parameters :we read the parameters from the def files'
+      ENDIF
+! tzjwb active sinon plante
+    !  IF ( active_flags%hydrol_cwrr ) THEN
+         
+         !! 2.1 Read the flag ok_throughfall_by_pft to know if 
+         !!      we have to use the parameter throughfall_by_pft
+
+         !Config Key   = OK_THROUGHFALL_PFT
+         !Config Desc  = Activate use of PERCENT_THROUGHFALL_PFT
+         !Config If    = HYDROL_CWRR
+         !Config Def   = FALSE
+         !Config Help  = If NOT OFF_LINE_MODE it is always TRUE (coupled with a GCM)
+         !Config Units = [FLAG]
+    !     IF ( .NOT. OFF_LINE_MODE ) ok_throughfall_by_pft = .TRUE.
+         ok_throughfall_by_pft = .TRUE.
+         CALL getin_p('OK_THROUGHFALL_PFT',ok_throughfall_by_pft)   
+
+    !  END IF
+   
+      !! 2.2 Memory allocation for the pfts-parameters
+      CALL pft_parameters_alloc(active_flags)
+
+      !! 3. Correspondance table 
+      
+      !! 3.1 Initialisation of the correspondance table
+      !! Initialisation of the correspondance table
+      IF (nvm == nvmc) THEN
+         WRITE(numout,*) 'Message to the user : we will use ORCHIDEE to its standard configuration' 
+         pft_to_mtc = (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13 /)
+      ELSE
+         pft_to_mtc(:) = undef_int
+      ENDIF !(nvm  == nvmc)
+      
+      !! 3.2 Reading of the conrrespondance table in the .def file
+      !
+      !Config Key   = PFT_TO_MTC
+      !Config Desc  = correspondance array linking a PFT to MTC
+      !Config if    = OK_SECHIBA or OK_STOMATE
+      !Config Def   = 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('PFT_TO_MTC',pft_to_mtc)
+      
+      !! 3.3 If the user want to use the standard configuration, he needn't to fill the correspondance array
+      !!     If the configuration is wrong, send a error message to the user.
+      IF(nvm /= nvmc ) THEN
+         !
+         IF(pft_to_mtc(1) == undef_int) THEN
+            CALL ipslerr_p (3,'pft_parameters', &
+                 'The array PFT_TO_MTC is empty','','')
+         ENDIF !(pft_to_mtc(1) == undef_int)
+         !
+      ENDIF !(nvm /= nvmc )
+
+      !! 3.4 Some error messages
+
+      !! 3.4.1 What happened if pft_to_mtc(j) > nvmc or pft_to_mtc(j) <=0 (if the mtc doesn't exist)?
+       DO j = 1, nvm ! Loop over # PFTs  
+          !
+          IF( (pft_to_mtc(j) > nvmc) .OR. (pft_to_mtc(j) <= 0) ) THEN
+             WRITE(numout,*) 'pft_to_mtc(j),j,nvmc: ',pft_to_mtc(j),j,nvmc,nvm
+             CALL ipslerr_p (3,'pft_parameters', &
+                  'the metaclass chosen does not exist','','')
+          ENDIF !( (pft_to_mtc(j) > nvmc) .OR. (pft_to_mtc(j) <= 0) )
+          !
+       ENDDO  ! Loop over # PFTs  
+
+
+       !! 3.4.2 Check if pft_to_mtc(1) = 1 
+       IF(pft_to_mtc(1) /= 1) THEN
+          !
+          CALL ipslerr_p (3,'pft_parameters', &
+               'the first pft has to be the bare soil','','')
+          !
+       ELSE
+          !
+          DO j = 2,nvm ! Loop over # PFTs different from bare soil
+             !
+             IF(pft_to_mtc(j) == 1) THEN
+                 CALL ipslerr_p (3,'pft_parameters', &
+                      'only pft_to_mtc(1) has to be the bare soil','','')
+             ENDIF ! (pft_to_mtc(j) == 1)
+             !
+          ENDDO ! Loop over # PFTs different from bare soil
+          !
+       ENDIF !(pft_to_mtc(1) /= 1)
+      
+
+      !! 4.Initialisation of the pfts-parameters
+      CALL pft_parameters_init(active_flags)
+
+      !! 5. Useful data
+
+      !! 5.1 Read the name of the PFTs given by the user
+      !
+      !Config Key   = PFT_NAME
+      !Config Desc  = Name of a PFT
+      !Config if    = OK_SECHIBA or OK_STOMATE
+      !Config Def   = bare ground, tropical broad-leaved evergreen, tropical broad-leaved raingreen, 
+      !Config         temperate needleleaf evergreen, temperate broad-leaved evergreen temperate broad-leaved summergreen,
+      !Config         boreal needleleaf evergreen, boreal broad-leaved summergreen, boreal needleleaf summergreen,
+      !Config         C3 grass, C4 grass, C3 agriculture, C4 agriculture    
+      !Config Help  = the user can name the new PFTs he/she introducing for new species
+      !Config Units = [-]
+      CALL getin_p('PFT_NAME',pft_name)
+
+      !! 5.2 A useful message to the user: correspondance between the number of the pft
+      !! and the name of the associated mtc 
+      DO j = 1,nvm ! Loop over # PFTs
+         !
+         WRITE(numout,*) 'the PFT',j, 'called  ', PFT_name(j),'corresponds to the MTC : ',MTC_name(pft_to_mtc(j))
+         !
+      ENDDO ! Loop over # PFTs
+
+
+      !! 6. End message
+      IF(long_print) THEN
+         WRITE(numout,*) 'pft_parameters_done'
+      ENDIF
+
+      !! 8. Reset flag
+      l_first_pft_parameters = .FALSE.
+
+   ELSE 
+
+      RETURN
+
+   ENDIF !(l_first_pft_parameters)
+
+ END SUBROUTINE pft_parameters_main
+ !
+ !=
+ !
+
+!! ================================================================================================================================
+!! SUBROUTINE   : pft_parameters_init 
+!!
+!>\BRIEF          This subroutine initializes all the pft parameters by the default values
+!! of the corresponding metaclasse. 
+!!
+!! DESCRIPTION  : This subroutine is called after the reading of the number of PFTS and the correspondence
+!!                table defined by the user in the configuration files. \n
+!!                With the correspondence table, the subroutine can search the default values for the parameter
+!!                even if the PFTs are classified in a random order (except bare soil). \n
+!!                With the correspondence table, the subroutine can initialize the pft parameters in function
+!!                of the flags activated (ok_sechiba, ok_stomate, ok_co2, routing, new_hydrol...).\n
+!!
+!! RECENT CHANGE(S): Didier Solyga : Simplified PFT loops : use vector notation. 
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+ SUBROUTINE pft_parameters_init(active_flags)
+  
+   IMPLICIT NONE
+   
+   !! 0. Variables and parameters declaration
+
+   !! 0.1 Input variables
+   
+   TYPE(control_type),INTENT(in) :: active_flags  !! What parts of the code are activated ? (true/false)
+
+   !! 0.4 Local variables
+
+   INTEGER(i_std)                :: jv            !! Index (unitless) 
+!_ ================================================================================================================================ 
+
+   !
+   ! 1. Correspondance between the PFTs values and thes MTCs values 
+   !
+ 
+
+   ! 1.1 For parameters used anytime
+   
+   PFT_name(:) = MTC_name(pft_to_mtc(:))
+   !
+   ! Vegetation structure 
+   !
+   veget_ori_fixed_test_1(:) = veget_ori_fixed_mtc(pft_to_mtc(:))
+   llaimax(:) = llaimax_mtc(pft_to_mtc(:))
+   llaimin(:) = llaimin_mtc(pft_to_mtc(:))
+   height_presc(:) = height_presc_mtc(pft_to_mtc(:))
+   type_of_lai(:) = type_of_lai_mtc(pft_to_mtc(:))
+   natural(:) = natural_mtc(pft_to_mtc(:))
+   !
+   ! Water - sechiba
+   !
+   If (active_flags%hydrol_cwrr ) THEN
+      humcste(:) = humcste_cwrr(pft_to_mtc(:)) ! values for 2m soil depth
+   ELSE
+      humcste(:) = humcste_mtc(pft_to_mtc(:))  ! values for 4m soil depth 
+   END IF
+   !
+   ! Soil - vegetation
+   !
+   pref_soil_veg(:) = pref_soil_veg_mtc(pft_to_mtc(:))
+   !
+   ! Vegetation - age classes
+   !
+   agec_group(:) = agec_group_mtc(pft_to_mtc(:))
+   !
+   ! Photosynthesis
+   !
+   is_c4(:) = is_c4_mtc(pft_to_mtc(:))
+   vcmax_fix(:) = vcmax_fix_mtc(pft_to_mtc(:))
+   downregulation_co2_coeff(:) = downregulation_co2_coeff_mtc(pft_to_mtc(:))
+   E_KmC(:)      = E_KmC_mtc(pft_to_mtc(:))
+   E_KmO(:)      = E_KmO_mtc(pft_to_mtc(:))
+   E_gamma_star(:) = E_gamma_star_mtc(pft_to_mtc(:))
+   E_Vcmax(:)    = E_Vcmax_mtc(pft_to_mtc(:))
+   E_Jmax(:)     = E_Jmax_mtc(pft_to_mtc(:))
+   aSV(:)        = aSV_mtc(pft_to_mtc(:))
+   bSV(:)        = bSV_mtc(pft_to_mtc(:))
+   tphoto_min(:) = tphoto_min_mtc(pft_to_mtc(:))
+   tphoto_max(:) = tphoto_max_mtc(pft_to_mtc(:))
+   aSJ(:)        = aSJ_mtc(pft_to_mtc(:))
+   bSJ(:)        = bSJ_mtc(pft_to_mtc(:))
+   D_Vcmax(:)     = D_Vcmax_mtc(pft_to_mtc(:))
+   D_Jmax(:)     = D_Jmax_mtc(pft_to_mtc(:))
+   E_Rd(:)       = E_Rd_mtc(pft_to_mtc(:))
+   Vcmax25(:)    = Vcmax25_mtc(pft_to_mtc(:))
+   arJV(:)       = arJV_mtc(pft_to_mtc(:))
+   brJV(:)       = brJV_mtc(pft_to_mtc(:))
+   KmC25(:)      = KmC25_mtc(pft_to_mtc(:))
+   KmO25(:)      = KmO25_mtc(pft_to_mtc(:))
+   gamma_star25(:)  = gamma_star25_mtc(pft_to_mtc(:))
+   a1(:)         = a1_mtc(pft_to_mtc(:))
+   b1(:)         = b1_mtc(pft_to_mtc(:))
+   g0(:)         = g0_mtc(pft_to_mtc(:))
+   h_protons(:)  = h_protons_mtc(pft_to_mtc(:))
+   fpsir(:)      = fpsir_mtc(pft_to_mtc(:))
+   fQ(:)         = fQ_mtc(pft_to_mtc(:))     
+   fpseudo(:)    = fpseudo_mtc(pft_to_mtc(:))    
+   kp(:)         = kp_mtc(pft_to_mtc(:))
+   alpha(:)      = alpha_mtc(pft_to_mtc(:))
+   gbs(:)        = gbs_mtc(pft_to_mtc(:))
+   theta(:)      = theta_mtc(pft_to_mtc(:))        
+   alpha_LL(:)   = alpha_LL_mtc(pft_to_mtc(:))
+   ext_coeff(:) = ext_coeff_mtc(pft_to_mtc(:))
+   !
+   !! Define labels from physiologic characteristics 
+   !
+   leaf_tab(:) = leaf_tab_mtc(pft_to_mtc(:)) 
+   pheno_model(:) = pheno_model_mtc(pft_to_mtc(:))   
+   !
+   is_tree(:) = .FALSE.
+   DO jv = 1,nvm
+      IF ( leaf_tab(jv) <= 2 ) is_tree(jv) = .TRUE.
+   END DO
+      !
+   is_deciduous(:) = .FALSE.
+   DO jv = 1,nvm
+      IF ( is_tree(jv) .AND. (pheno_model(jv) /= "none") ) is_deciduous(jv) = .TRUE.
+   END DO
+   !
+   is_evergreen(:) = .FALSE.
+   DO jv = 1,nvm
+      IF ( is_tree(jv) .AND. (pheno_model(jv) == "none") ) is_evergreen(jv) = .TRUE.
+   END DO
+   !
+   is_needleleaf(:) = .FALSE.
+   DO jv = 1,nvm
+      IF ( leaf_tab(jv) == 2 ) is_needleleaf(jv) = .TRUE.
+   END DO
+   !
+   is_tropical(:) = is_tropical_mtc(pft_to_mtc(:))
+   is_temperate(:) = is_temperate_mtc(pft_to_mtc(:))
+   is_boreal(:) = is_boreal_mtc(pft_to_mtc(:))
+
+   ! 1.2 For sechiba parameters
+
+   IF (active_flags%ok_sechiba) THEN
+      !
+      ! Vegetation structure - sechiba
+      !
+      rveg_pft(:) = rveg_mtc(pft_to_mtc(:))
+      !
+      ! Evapotranspiration -  sechiba
+      !
+      rstruct_const(:) = rstruct_const_mtc(pft_to_mtc(:))
+      kzero(:) = kzero_mtc(pft_to_mtc(:))
+      !
+      ! Water - sechiba
+      !
+      wmax_veg(:) = wmax_veg_mtc(pft_to_mtc(:))
+      IF ( .NOT.(active_flags%hydrol_cwrr) .OR.  (active_flags%hydrol_cwrr .AND. ok_throughfall_by_pft) ) THEN
+         throughfall_by_pft(:) = throughfall_by_mtc(pft_to_mtc(:))
+      ENDIF
+      !
+      ! Albedo - sechiba
+      !
+      snowa_aged(:) = snowa_aged_mtc(pft_to_mtc(:))
+      snowa_dec(:) = snowa_dec_mtc(pft_to_mtc(:)) 
+      alb_leaf_vis(:) = alb_leaf_vis_mtc(pft_to_mtc(:))  
+      alb_leaf_nir(:) = alb_leaf_nir_mtc(pft_to_mtc(:))
+      leaf_ssa(:,ivis) = leaf_ssa_vis_mtc(pft_to_mtc(:))
+      leaf_ssa(:,inir) = leaf_ssa_nir_mtc(pft_to_mtc(:))
+      leaf_psd(:,ivis) = leaf_psd_vis_mtc(pft_to_mtc(:))
+      leaf_psd(:,inir) = leaf_psd_nir_mtc(pft_to_mtc(:))
+      bgd_reflectance(:,ivis) = bgd_reflectance_vis_mtc(pft_to_mtc(:))
+      bgd_reflectance(:,inir) = bgd_reflectance_nir_mtc(pft_to_mtc(:))
+      tune_coupled (:) = tune_coupled_mtc(pft_to_mtc(:))  
+      leaf_to_shoot_clumping(:) = leaf_to_shoot_clumping_mtc(pft_to_mtc(:))
+      lai_correction_factor(:) = lai_correction_factor_mtc(pft_to_mtc(:))
+      min_level_sep(:) = min_level_sep_mtc(pft_to_mtc(:))
+      !
+      ! Diffuco and hydrol_arch
+      !
+      lai_top(:) = lai_top_mtc(pft_to_mtc(:))
+
+   ENDIF !(active_flags%ok_sechiba)
+
+   ! 1.3 For BVOC parameters
+   
+   IF (active_flags%ok_inca) THEN
+      !
+      ! Biogenic Volatile Organic Compounds
+      !
+      em_factor_isoprene(:) = em_factor_isoprene_mtc(pft_to_mtc(:))
+      em_factor_monoterpene(:) = em_factor_monoterpene_mtc(pft_to_mtc(:))
+      em_factor_ORVOC(:) = em_factor_ORVOC_mtc(pft_to_mtc(:)) 
+      em_factor_OVOC(:) = em_factor_OVOC_mtc(pft_to_mtc(:))
+      em_factor_MBO(:) = em_factor_MBO_mtc(pft_to_mtc(:))
+      em_factor_methanol(:) = em_factor_methanol_mtc(pft_to_mtc(:))
+      em_factor_acetone(:) = em_factor_acetone_mtc(pft_to_mtc(:)) 
+      em_factor_acetal(:) = em_factor_acetal_mtc(pft_to_mtc(:))
+      em_factor_formal(:) = em_factor_formal_mtc(pft_to_mtc(:))
+      em_factor_acetic(:) = em_factor_acetic_mtc(pft_to_mtc(:))
+      em_factor_formic(:) = em_factor_formic_mtc(pft_to_mtc(:))
+      em_factor_no_wet(:) = em_factor_no_wet_mtc(pft_to_mtc(:))
+      em_factor_no_dry(:) = em_factor_no_dry_mtc(pft_to_mtc(:))
+      Larch(:) = Larch_mtc(pft_to_mtc(:)) 
+      !-
+   ENDIF !(active_flags%ok_inca)
+
+   ! 1.4 For stomate parameters
+
+   IF (active_flags%ok_stomate) THEN
+      !
+      ! Vegetation structure - stomate
+      !
+      sla(:) = sla_mtc(pft_to_mtc(:))
+      lai_happy(:) = lai_happy_mtc(pft_to_mtc(:))
+      !
+      ! Allocation - stomate
+      !
+      S0(:) = S0_mtc(pft_to_mtc(:)) 
+      !
+      ! Respiration - stomate
+      !
+      maint_resp_slope_c(:) = maint_resp_slope_c_mtc(pft_to_mtc(:))               
+      maint_resp_slope_b(:) = maint_resp_slope_b_mtc(pft_to_mtc(:))
+      maint_resp_slope_a(:) = maint_resp_slope_a_mtc(pft_to_mtc(:))
+      cm_zero_leaf(:) = cm_zero_leaf_mtc(pft_to_mtc(:))
+      cm_zero_sapabove(:) = cm_zero_sapabove_mtc(pft_to_mtc(:))
+      cm_zero_sapbelow(:) = cm_zero_sapbelow_mtc(pft_to_mtc(:)) 
+      cm_zero_heartabove(:) = cm_zero_heartabove_mtc(pft_to_mtc(:)) 
+      cm_zero_heartbelow(:) = cm_zero_heartbelow_mtc(pft_to_mtc(:))
+      cm_zero_root(:) = cm_zero_root_mtc(pft_to_mtc(:))
+      cm_zero_fruit(:) = cm_zero_fruit_mtc(pft_to_mtc(:))   
+      coeff_maint_init(:) = coeff_maint_init_mtc(pft_to_mtc(:))
+      IF (active_flags%ok_functional_allocation) THEN 
+         ! Respiration (functional allocation stomate)
+         frac_growthresp(:) = frac_growthresp_fun_all_mtc(pft_to_mtc(:)) 
+         cm_zero_carbres(:) = cm_zero_carbres_fun_all_mtc(pft_to_mtc(:))
+         cm_zero_labile(:) = cm_zero_labile_fun_all_mtc(pft_to_mtc(:))   
+      ELSE
+         ! Respiration (resource limitation stomate) 
+         frac_growthresp(:) = frac_growthresp_res_lim_mtc(pft_to_mtc(:))
+         cm_zero_carbres(:) = cm_zero_carbres_res_lim_mtc(pft_to_mtc(:))
+         cm_zero_labile(:) = cm_zero_labile_res_lim_mtc(pft_to_mtc(:))
+      ENDIF
+      gpp_to_labile(:) = gpp_to_labile_mtc(pft_to_mtc(:))
+
+      !
+      ! Stand structure
+      !
+      pipe_density(:) = pipe_density_mtc(pft_to_mtc(:))
+      pipe_tune1(:) = pipe_tune1_mtc(pft_to_mtc(:)) 
+      pipe_tune2(:) = pipe_tune2_mtc(pft_to_mtc(:))  
+      pipe_tune3(:) = pipe_tune3_mtc(pft_to_mtc(:)) 
+      pipe_tune4(:) = pipe_tune4_mtc(pft_to_mtc(:))
+      tree_ff(:) = tree_ff_mtc(pft_to_mtc(:))
+      pipe_k1(:) = pipe_k1_mtc(pft_to_mtc(:)) 
+      pipe_tune_exp_coeff(:) = pipe_tune_exp_coeff_mtc(pft_to_mtc(:))
+      mass_ratio_heart_sap(:) = mass_ratio_heart_sap_mtc(pft_to_mtc(:))
+      lai_to_height(:) = lai_to_height_mtc(pft_to_mtc(:)) 
+      canopy_cover = canopy_cover_mtc(pft_to_mtc(:))
+      nmaxtrees(:) = nmaxtrees_mtc(pft_to_mtc(:))
+      height_init_min(:) = height_init_min_mtc(pft_to_mtc(:))
+      height_init_max(:) = height_init_max_mtc(pft_to_mtc(:))
+      alpha_self_thinning(:) = alpha_self_thinning_mtc(pft_to_mtc(:))
+      beta_self_thinning(:) = beta_self_thinning_mtc(pft_to_mtc(:))
+      fuelwood_diameter(:) = fuelwood_diameter_mtc(pft_to_mtc(:))
+      coppice_kill_be_wood(:) = coppice_kill_be_wood_mtc(pft_to_mtc(:))
+
+      !
+      ! Growth - stomate
+      !
+      cn_leaf_prescribed(:) = cn_leaf_prescribed_mtc(pft_to_mtc(:))
+      fcn_wood(:) = fcn_wood_mtc(pft_to_mtc(:))
+      fcn_root(:) = fcn_root_mtc(pft_to_mtc(:))
+      k_latosa_max(:) = k_latosa_max_mtc(pft_to_mtc(:))
+      k_latosa_min(:) = k_latosa_min_mtc(pft_to_mtc(:))
+      fruit_alloc(:) = fruit_alloc_mtc(pft_to_mtc(:))
+      m_dv(:) = m_dv_mtc(pft_to_mtc(:))
+      lai_max_to_happy(:) = lai_max_to_happy_mtc(pft_to_mtc(:))
+
+      !
+      ! Hydraulic architecture - sechiba?
+      !
+      k_root(:) = k_root_mtc(pft_to_mtc(:))
+      k_sap(:) = k_sap_mtc(pft_to_mtc(:))
+      k_leaf(:) = k_leaf_mtc(pft_to_mtc(:))
+      phi_leaf(:) = phi_leaf_mtc(pft_to_mtc(:))
+      phi_50(:) = phi_50_mtc(pft_to_mtc(:))
+      c_cavitation(:) = c_cavitation_mtc(pft_to_mtc(:))
+      phi_soil_tune(:) = phi_soil_tune_mtc(pft_to_mtc(:))
+
+      !---------------------------------------------------------------------------------------
+      ! Hydraulic architecture - tzjh
+      
+      gpsi(:)=gpsi_mtc(pft_to_mtc(:))
+      gpsi_50(:)=gpsi_50_mtc(pft_to_mtc(:))
+      gmax(:)=gmax_mtc(pft_to_mtc(:))
+      gmin(:)=gmin_mtc(pft_to_mtc(:))
+
+      kmax_leaf(:)=kmax_leaf_mtc(pft_to_mtc(:))
+      kmax_stem(:)=kmax_stem_mtc(pft_to_mtc(:))
+      kmax_root(:)=kmax_root_mtc(pft_to_mtc(:))
+      a_leaf(:)=a_leaf_mtc(pft_to_mtc(:))
+      a_stem(:)=a_stem_mtc(pft_to_mtc(:))
+      a_root(:)=a_root_mtc(pft_to_mtc(:)) 
+      P50_leaf(:)=P50_leaf_mtc(pft_to_mtc(:))
+      P50_stem(:)=P50_stem_mtc(pft_to_mtc(:))
+      P50_root(:)=P50_root_mtc(pft_to_mtc(:))
+      
+      wood_density(:)=wood_density_mtc(pft_to_mtc(:))
+      w_density_stem(:)=w_density_stem_mtc(pft_to_mtc(:))
+      root_shoot_ratio(:)=root_shoot_ratio_mtc(pft_to_mtc(:))
+      rwc_root(:)=rwc_root_mtc(pft_to_mtc(:))
+      root_density(:)=root_density_mtc(pft_to_mtc(:))
+      LDMC(:)=LDMC_mtc(pft_to_mtc(:))
+      sla_hydro(:)=sla_hydro_mtc(pft_to_mtc(:))
+
+      cxyl(:)=cxyl_mtc(pft_to_mtc(:))
+      cr(:)=cr_mtc(pft_to_mtc(:))
+      cl(:)=cl_mtc(pft_to_mtc(:))
+      !---------------------------------------------------------------------------------------
+
+      !
+      ! Mortality - stomate_kill
+      !
+      death_distribution_factor(:) = death_distribution_factor_mtc(pft_to_mtc(:))
+      npp_reset_value(:) = npp_reset_value_mtc(pft_to_mtc(:))
+      
+      !
+      ! Fire - stomate
+      !
+      flam(:) = flam_mtc(pft_to_mtc(:))
+      resist(:) = resist_mtc(pft_to_mtc(:))
+      !
+      ! Flux - LUC
+      !
+      coeff_lcchange_s(:) = coeff_lcchange_s_mtc(pft_to_mtc(:))
+      coeff_lcchange_m(:) = coeff_lcchange_m_mtc(pft_to_mtc(:))
+      coeff_lcchange_l(:) = coeff_lcchange_l_mtc(pft_to_mtc(:))
+      !
+      ! Phenology
+      !
+      !
+      ! 1. Stomate
+      !
+      lai_max(:) = lai_max_mtc(pft_to_mtc(:))
+      pheno_type(:) = pheno_type_mtc(pft_to_mtc(:))
+      !
+      ! 2. Leaf Onset
+      !
+      pheno_gdd_crit_c(:) = pheno_gdd_crit_c_mtc(pft_to_mtc(:))
+      pheno_gdd_crit_b(:) = pheno_gdd_crit_b_mtc(pft_to_mtc(:))         
+      pheno_gdd_crit_a(:) = pheno_gdd_crit_a_mtc(pft_to_mtc(:))
+      ngd_crit(:) =  ngd_crit_mtc(pft_to_mtc(:))
+      opti_kpheno_crit(:) = opti_kpheno_crit_mtc(pft_to_mtc(:))
+      ncdgdd_temp(:) = ncdgdd_temp_mtc(pft_to_mtc(:)) 
+      hum_frac(:) = hum_frac_mtc(pft_to_mtc(:))
+      hum_min_time(:) = hum_min_time_mtc(pft_to_mtc(:))
+      tau_sap(:) = tau_sap_mtc(pft_to_mtc(:))
+      tau_fruit(:) = tau_fruit_mtc(pft_to_mtc(:))
+      tau_root(:) = tau_root_mtc(pft_to_mtc(:))
+      tau_leaf(:) = tau_leaf_mtc(pft_to_mtc(:))
+      ecureuil(:) = ecureuil_mtc(pft_to_mtc(:))
+      alloc_min(:) = alloc_min_mtc(pft_to_mtc(:))
+      alloc_max(:) = alloc_max_mtc(pft_to_mtc(:))
+      demi_alloc(:) = demi_alloc_mtc(pft_to_mtc(:))
+      !
+      ! 3. Senescence
+      !
+      leaffall(:) = leaffall_mtc(pft_to_mtc(:))
+      senescence_type(:) = senescence_type_mtc(pft_to_mtc(:)) 
+      senescence_hum(:) = senescence_hum_mtc(pft_to_mtc(:)) 
+      nosenescence_hum(:) = nosenescence_hum_mtc(pft_to_mtc(:)) 
+      max_turnover_time(:) = max_turnover_time_mtc(pft_to_mtc(:))
+      min_turnover_time(:) = min_turnover_time_mtc(pft_to_mtc(:))
+      min_leaf_age_for_senescence(:) = min_leaf_age_for_senescence_mtc(pft_to_mtc(:))
+      senescence_temp_c(:) = senescence_temp_c_mtc(pft_to_mtc(:))
+      senescence_temp_b(:) = senescence_temp_b_mtc(pft_to_mtc(:))
+      senescence_temp_a(:) = senescence_temp_a_mtc(pft_to_mtc(:))
+      gdd_senescence(:) = gdd_senescence_mtc(pft_to_mtc(:))
+      !
+      ! DGVM
+      !
+      residence_time(:) = residence_time_mtc(pft_to_mtc(:))
+      tmin_crit(:) = tmin_crit_mtc(pft_to_mtc(:))
+      tcm_crit(:) = tcm_crit_mtc(pft_to_mtc(:))
+      mortality_min(:) = mortality_min_mtc(pft_to_mtc(:))
+      mortality_max(:) = mortality_max_mtc(pft_to_mtc(:))
+      ref_mortality(:) = ref_mortality_mtc(pft_to_mtc(:))
+
+      ! added by yitong yao in 07 Jan 2020 08:17
+
+      plc_kill_frac(:)=plc_kill_frac_mtc(pft_to_mtc(:))
+      ! added by yitong yao in 07 Jan 2020 08:17 
+      
+      ! added by yitong yao in 09 Feb 2020 22:56
+      mor_kill_frac(:) = mor_kill_frac_mtc(pft_to_mtc(:))
+      ! added by yitong yao in 09 Feb 2020 22:56 above line 
+
+      ! Season average
+      !
+      ! Only an effect on the roots has been implemented for the
+      ! GPP-based waterstress. We use tau_sap rather than tau_roots
+      ! because we only want to implement the long term change in
+      ! allocation owing to height-induced drought stress. Short
+      ! term adaptation to drought is not accounted for (except
+      ! for stomatal closure).
+      tau_hum_growingseason(:) = tau_sap_mtc(pft_to_mtc(:))
+      DO jv = 2,nvm
+         IF(.NOT. is_tree(jv)) THEN
+            ! Grasses have no sapwood so use a constant instead of tau_sap
+            tau_hum_growingseason(jv) = tau_hum_growingseason_grass
+         ENDIF
+      END DO
+
+      ! Originally, dens_target was just used in the FM routines.
+      ! Now, however, it is used for all forests.
+      dens_target(:) = dens_target_mtc(pft_to_mtc(:))
+
+      !
+      ! FOREST MANAGEMENT
+      !
+      IF (active_flags%forest_management &
+           .OR. active_flags%ok_functional_allocation) THEN
+!!$         plantation(:) = plantation_mtc(pft_to_mtc(:))
+!!$         fm_allo_a(:) = fm_allo_a_mtc(pft_to_mtc(:))
+!!$         fm_allo_c(:) = fm_allo_c_mtc(pft_to_mtc(:))
+!!$         fm_allo_d(:) = fm_allo_d_mtc(pft_to_mtc(:))
+!!$         fm_allo_p(:) = fm_allo_p_mtc(pft_to_mtc(:))
+!!$         fm_allo_q(:) = fm_allo_q_mtc(pft_to_mtc(:))
+!!$         allo_crown_a0(:) = allo_crown_a0_mtc(pft_to_mtc(:))
+!!$         allo_crown_a1(:) = allo_crown_a1_mtc(pft_to_mtc(:))
+!!$         allo_crown_a2(:) = allo_crown_a2_mtc(pft_to_mtc(:))
+!!$         decl_factor(:) = decl_factor_mtc(pft_to_mtc(:))
+!!$         opt_factor(:) = opt_factor_mtc(pft_to_mtc(:))
+         h_first(:) = h_first_mtc(pft_to_mtc(:))
+         largest_tree_dia(:) = largest_tree_dia_mtc(pft_to_mtc(:))
+         thinstrat(:) = thinstrat_mtc(pft_to_mtc(:))
+         taumin(:) = taumin_mtc(pft_to_mtc(:))
+         taumax(:) = taumax_mtc(pft_to_mtc(:))
+         alpha_rdi_upper(:) =  alpha_rdi_upper_mtc(pft_to_mtc(:))
+         beta_rdi_upper(:) =  beta_rdi_upper_mtc(pft_to_mtc(:))
+         alpha_rdi_lower(:) =  alpha_rdi_lower_mtc(pft_to_mtc(:))
+         beta_rdi_lower(:) =  beta_rdi_lower_mtc(pft_to_mtc(:))  
+         branch_ratio(:) = branch_ratio_mtc(pft_to_mtc(:))
+         branch_harvest(:) = branch_harvest_mtc(pft_to_mtc(:))
+         coppice_diameter(:) = coppice_diameter_mtc(pft_to_mtc(:))
+         shoots_per_stool(:) = shoots_per_stool_mtc(pft_to_mtc(:))
+         src_rot_length(:) = src_rot_length_mtc(pft_to_mtc(:))
+         src_nrots(:) = src_nrots_mtc(pft_to_mtc(:))
+         deleuze_a(:) = deleuze_a_mtc(pft_to_mtc(:))
+         deleuze_b(:) = deleuze_b_mtc(pft_to_mtc(:))
+         deleuze_p_all(:) = deleuze_p_all_mtc(pft_to_mtc(:))
+         deleuze_p_coppice(:) = deleuze_p_coppice_mtc(pft_to_mtc(:))
+         recruitment_light_threshold(:) = recruitment_light_threshold_mtc(pft_to_mtc(:))
+         dia_recr(:) = dia_recr_mtc(pft_to_mtc(:))
+         hei_recr(:) = hei_recr_mtc(pft_to_mtc(:)) 
+      END IF
+
+      !
+      ! CROPLAND MANAGEMENT
+      !
+      harvest_ratio(:) = harvest_ratio_mtc(pft_to_mtc(:))
+      
+   ENDIF !(active_flags%ok_stomate)
+
+
+
+ END SUBROUTINE pft_parameters_init
+ !
+ !
+ !
+
+!! ================================================================================================================================
+!! SUBROUTINE   : pft_parameters_alloc
+!!
+!>\BRIEF         This subroutine allocates memory needed for the PFT parameters 
+!! in function  of the flags activated.  
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+ SUBROUTINE pft_parameters_alloc(active_flags)
+
+   IMPLICIT NONE
+
+   !! 0. Variables and parameters declaration
+
+   !! 0.1 Input variables 
+   
+   TYPE(control_type),INTENT(in) :: active_flags  !! What parts of the code are activated ? (true/false)
+
+   !! 0.4 Local variables
+   
+   LOGICAL :: l_error                             !! Diagnostic boolean for error allocation (true/false) 
+   INTEGER :: ier                                 !! Return value for memory allocation (0-N, unitless)
+!_ ================================================================================================================================
+
+
+   !
+   ! 1. Parameters used anytime
+   !
+
+   l_error = .FALSE.
+
+   ALLOCATE(pft_to_mtc(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for pft_to_mtc. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(PFT_name(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for PFT_name. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(height_presc(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for height_presc. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(is_tree(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for is_tree. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(natural(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for natural. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(is_c4(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for is_c4. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(humcste(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for humcste. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(downregulation_co2_coeff(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for downregulation_co2_coeff. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(E_KmC(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for E_KmC. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(E_KmO(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for E_KmO. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(E_gamma_star(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for E_gamma_star. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(E_vcmax(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for E_Vcmax. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(E_Jmax(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for E_Jmax. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(aSV(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for aSV. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(bSV(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for bSV. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(tphoto_min(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for tphoto_min. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(tphoto_max(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for tphoto_max. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(aSJ(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for aSJ. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(bSJ(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for bSJ. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(D_Vcmax(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for D_Vcmax. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(D_Jmax(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for D_Jmax. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(E_Rd(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for E_Rd. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(Vcmax25(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for Vcmax25. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(arJV(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for arJV. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(brJV(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for brJV. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(KmC25(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for KmC25. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(KmO25(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for KmO25. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(gamma_star25(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for gamma_star25. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(a1(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for a1. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(b1(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for b1. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(g0(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for g0. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(h_protons(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for h_protons. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(fpsir(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for fpsir. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(fQ(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for fQ. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(fpseudo(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for fpseudo. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(kp(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for kp. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(alpha(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for alpha. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(gbs(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for gbs. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(theta(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for theta. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(alpha_LL(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for alpha_LL. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(ext_coeff(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for ext_coeff. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(veget_ori_fixed_test_1(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for veget_ori_fixed_test_1. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(llaimax(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for llaimax. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(llaimin(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for llaimin. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(type_of_lai(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for type_of_lai. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(vcmax_fix(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for vcmax_fix. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(pref_soil_veg(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for pref_soil_veg. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(agec_group(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for agec_group. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(start_index(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for start_index. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(nagec_pft(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for nagec_pft. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(leaf_tab(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for leaf_tab. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(pheno_model(nvm),stat=ier)
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for pheno_model. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+      
+   ALLOCATE(is_deciduous(nvm),stat=ier) 
+   l_error = l_error .OR. (ier /= 0) 
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for is_deciduous. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(is_temperate(nvm),stat=ier) 
+   l_error = l_error .OR. (ier /= 0) 
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for is_temperate. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(is_boreal(nvm),stat=ier) 
+   l_error = l_error .OR. (ier /= 0) 
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for is_boreal. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(is_evergreen(nvm),stat=ier) 
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for is_evergreen. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(is_needleleaf(nvm),stat=ier)  
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for is_needleleaf. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+   ALLOCATE(is_tropical(nvm),stat=ier)   
+   l_error = l_error .OR. (ier /= 0)
+   IF (l_error) THEN
+      WRITE(numout,*) ' Memory allocation error for is_tropical. We stop. We need nvm words = ',nvm
+      CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+   END IF
+
+
+   !
+   ! 2. Parameters used if ok_sechiba only
+   !
+   IF ( active_flags%ok_sechiba ) THEN
+
+      l_error = .FALSE.
+
+      ALLOCATE(rstruct_const(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for rstruct_const. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(kzero(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for kzero. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(rveg_pft(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for rveg_pft. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(wmax_veg(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for wmax_veg. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      IF ( .NOT.(active_flags%hydrol_cwrr) .OR. (active_flags%hydrol_cwrr .AND. ok_throughfall_by_pft) ) THEN
+         ALLOCATE(throughfall_by_pft(nvm),stat=ier)
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for throughfall_by_pft. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+      END IF
+
+      ALLOCATE(snowa_aged(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for snowa_aged. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(snowa_dec(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for snowa_dec. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(alb_leaf_vis(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for alb_leaf_vis. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(alb_leaf_nir(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for alb_leaf_nir. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(leaf_ssa(nvm,n_spectralbands),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for leaf_ssa. We stop. We need nvm*n_spectralbands words = ',&
+              nvm*n_spectralbands
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(leaf_psd(nvm,n_spectralbands),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for leaf_psd. We stop. We need nvm*n_spectralbands words = ',&
+              nvm*n_spectralbands
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(bgd_reflectance(nvm,n_spectralbands),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for bgd_reflectance. We need nvm*n_spectralbands words = ',&
+              nvm*n_spectralbands
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(leaf_to_shoot_clumping(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for leaf_to_shoot_clumping. We need nvm words = ',&
+              nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+
+      ALLOCATE(tune_coupled(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for tune_coupled. We need nvm words = ',&
+              nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+
+      ALLOCATE(lai_correction_factor(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for lai_correction_factor. We need nvm words = ',&
+              nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(min_level_sep(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for min_level_sep. We need nvm words = ',&
+              nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(lai_top(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for lai_top. We need nvm words = ',&
+              nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+
+      IF( active_flags%ok_inca ) THEN
+         
+         l_error = .FALSE.
+         
+         ALLOCATE(em_factor_isoprene(nvm),stat=ier)
+         l_error = l_error .OR. (ier /= 0) 
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for em_factor_isoprene. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(em_factor_monoterpene(nvm),stat=ier)
+         l_error = l_error .OR. (ier /= 0) 
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for em_factor_monoterpene. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(em_factor_ORVOC(nvm),stat=ier)
+         l_error = l_error .OR. (ier /= 0) 
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for em_factor_ORVOC. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(em_factor_OVOC(nvm),stat=ier)
+         l_error = l_error .OR. (ier /= 0)       
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for em_factor_OVOC. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(em_factor_MBO(nvm),stat=ier)
+         l_error = l_error .OR. (ier /= 0) 
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for em_factor_MBO. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(em_factor_methanol(nvm),stat=ier)
+         l_error = l_error .OR. (ier /= 0) 
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for em_factor_methanol. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(em_factor_acetone(nvm),stat=ier)
+         l_error = l_error .OR. (ier /= 0) 
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for em_factor_acetone. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(em_factor_acetal(nvm),stat=ier)
+         l_error = l_error .OR. (ier /= 0) 
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for em_factor_acetal. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(em_factor_formal(nvm),stat=ier)
+         l_error = l_error .OR. (ier /= 0) 
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for em_factor_formal. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(em_factor_acetic(nvm),stat=ier)
+         l_error = l_error .OR. (ier /= 0)       
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for em_factor_acetic. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(em_factor_formic(nvm),stat=ier)
+         l_error = l_error .OR. (ier /= 0) 
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for em_factor_formic. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(em_factor_no_wet(nvm),stat=ier)
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for em_factor_no_wet. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(em_factor_no_dry(nvm),stat=ier)
+         l_error = l_error .OR. (ier /= 0)       
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for em_factor_no_dry. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(Larch(nvm),stat=ier)
+         l_error = l_error .OR. (ier /= 0) 
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for Larch. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+      ENDIF ! (active_flags%ok_inca) 
+
+   ENDIF !(active_flags%ok_sechiba)
+
+   !
+   ! 3. Parameters used if ok_stomate only
+   !
+   IF ( active_flags%ok_stomate ) THEN
+
+      l_error = .FALSE.
+      
+      !
+      ! PHOTOSYNTHESIS
+      !
+      ALLOCATE(sla(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for sla. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+!!$      ALLOCATE(tphoto_min_a(nvm),stat=ier)
+!!$      l_error = l_error .OR. (ier /= 0)
+!!$      IF (l_error) THEN
+!!$         WRITE(numout,*) ' Memory allocation error for tphoto_min_a. We stop. We need nvm words = ',nvm
+!!$         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+!!$      END IF
+!!$
+!!$      ALLOCATE(tphoto_min_b(nvm),stat=ier)
+!!$      l_error = l_error .OR. (ier /= 0)
+!!$      IF (l_error) THEN
+!!$         WRITE(numout,*) ' Memory allocation error for tphoto_min_b. We stop. We need nvm words = ',nvm
+!!$         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+!!$      END IF
+!!$
+!!$      ALLOCATE(tphoto_min_c(nvm),stat=ier)
+!!$      l_error = l_error .OR. (ier /= 0)
+!!$      IF (l_error) THEN
+!!$         WRITE(numout,*) ' Memory allocation error for tphoto_min_c. We stop. We need nvm words = ',nvm
+!!$         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+!!$      END IF
+!!$
+!!$      ALLOCATE(tphoto_opt_a(nvm),stat=ier)
+!!$      l_error = l_error .OR. (ier /= 0)
+!!$      IF (l_error) THEN
+!!$         WRITE(numout,*) ' Memory allocation error for tphoto_opt_a. We stop. We need nvm words = ',nvm
+!!$         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+!!$      END IF
+!!$
+!!$      ALLOCATE(tphoto_opt_b(nvm),stat=ier)
+!!$      l_error = l_error .OR. (ier /= 0)
+!!$      IF (l_error) THEN
+!!$         WRITE(numout,*) ' Memory allocation error for tphoto_opt_b. We stop. We need nvm words = ',nvm
+!!$         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+!!$      END IF
+!!$
+!!$      ALLOCATE(tphoto_opt_c(nvm),stat=ier)
+!!$      l_error = l_error .OR. (ier /= 0)
+!!$      IF (l_error) THEN
+!!$         WRITE(numout,*) ' Memory allocation error for tphoto_opt_c. We stop. We need nvm words = ',nvm
+!!$         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+!!$      END IF
+!!$
+!!$      ALLOCATE(tphoto_max_a(nvm),stat=ier)
+!!$      l_error = l_error .OR. (ier /= 0)
+!!$      IF (l_error) THEN
+!!$         WRITE(numout,*) ' Memory allocation error for tphoto_max_a. We stop. We need nvm words = ',nvm
+!!$         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+!!$      END IF
+!!$
+!!$      ALLOCATE(tphoto_max_b(nvm),stat=ier)
+!!$      l_error = l_error .OR. (ier /= 0)
+!!$      IF (l_error) THEN
+!!$         WRITE(numout,*) ' Memory allocation error for tphoto_max_b. We stop. We need nvm words = ',nvm
+!!$         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+!!$      END IF
+!!$
+!!$      ALLOCATE(tphoto_max_c(nvm),stat=ier)
+!!$      l_error = l_error .OR. (ier /= 0)
+!!$      IF (l_error) THEN
+!!$         WRITE(numout,*) ' Memory allocation error for tphoto_max_c. We stop. We need nvm words = ',nvm
+!!$         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+!!$      END IF
+ 
+
+      !
+      ! RESPIRATION
+      !
+      ALLOCATE(S0(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for S0. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(L0(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for L0. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(maint_resp_slope(nvm,3),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for maint_resp_slope. We stop. We need nvm*3 words = ',nvm*3
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      maint_resp_slope(:,:) = zero
+
+      ALLOCATE(maint_resp_slope_c(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for maint_resp_slope_c. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(maint_resp_slope_b(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for maint_resp_slope_b. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(maint_resp_slope_a(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for maint_resp_slope_a. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(coeff_maint_zero(nvm,nparts),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for coeff_maint_zero. We stop. We need nvm*nparts words = ',nvm*nparts
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      coeff_maint_zero(:,:) = zero
+
+      ALLOCATE(cm_zero_leaf(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for cm_zero_leaf. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(cm_zero_sapabove(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for cm_zero_sapabove. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(cm_zero_sapbelow(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for cm_zero_sapbelow. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(cm_zero_heartabove(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for cm_zero_heartabove. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(cm_zero_heartbelow(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for cm_zero_heartbelow. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(cm_zero_root(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for cm_zero_root. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(cm_zero_fruit(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for cm_zero_fruit. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(cm_zero_carbres(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for cm_zero_carbres. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      
+      ALLOCATE(cm_zero_labile(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for cm_zero_labile. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      
+      ALLOCATE(coeff_maint_init(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for coeff_maint_init. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      
+      ALLOCATE(frac_growthresp(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for frac_growthresp. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(gpp_to_labile(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for gpp_to_labile. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      !
+      ! STAND STRUCTURE
+      !
+
+      ALLOCATE(pipe_density(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for pipe_density. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      
+      ALLOCATE(pipe_tune1(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for pipe_tune1. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(pipe_tune2(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for pipe_tune2. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(pipe_tune3(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for pipe_tune3. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(pipe_tune4(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for pipe_tune4. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(tree_ff(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for tree_ff. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(pipe_k1(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for pipe_k1. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(pipe_tune_exp_coeff(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for pipe_tune_exp_coeff. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(mass_ratio_heart_sap(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for mass_ratio_heart_sap. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(lai_to_height(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for lai_to_height. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(canopy_cover(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for canopy_cover. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(nmaxtrees(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for nmaxtrees. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(height_init_min(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for height_init_min. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      
+      ALLOCATE(height_init_max(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for height_init_max. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      
+      ALLOCATE(alpha_self_thinning(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for alpha_self_thinning. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      
+      ALLOCATE(beta_self_thinning(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for beta_self_thinning. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+         
+      ALLOCATE(fuelwood_diameter(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for fuelwood_diameter. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+         
+      ALLOCATE(coppice_kill_be_wood(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for coppice_kill_be_wood. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      !
+      ! GROWTH
+      !
+      ALLOCATE(cn_leaf_prescribed(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for cn_leaf_prescribed. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(fcn_wood(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for fcn_wood. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(fcn_root(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for fcn_root. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(k_latosa_max(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for k_latosa_max. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(k_latosa_min(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for k_latosa_min. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(fruit_alloc(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for fruit_alloc. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(m_dv(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for m_dv. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      
+      ALLOCATE(recruitment_light_threshold(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for recruitment_light_threshold. We stop. We need nvm words = ',nvm
+         STOP 'pft_parameters_alloc'
+      END IF
+      
+      ALLOCATE(dia_recr(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for dia_recr. We stop. We need nvm words = ',nvm
+         STOP 'pft_parameters_alloc'
+      END IF
+      
+      ALLOCATE(hei_recr(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for hei_recr. We stop. We need nvm words = ',nvm
+         STOP 'pft_parameters_alloc'
+      END IF
+
+      ALLOCATE(lai_max_to_happy(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for lai_max_to_happy. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(k_root(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for k_root. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(k_sap(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for k_sap. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(k_leaf(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for k_leaf. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(phi_leaf(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for phi_leaf. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(phi_50(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for phi_50. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(c_cavitation(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for c_cavitation. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(phi_soil_tune(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for phi_soil_tune. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(lai_happy(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for lai_happy. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+ 
+    !---------------------------------------------------------------------------------------
+    ! tzjh hydraulic architecture
+ 
+      ALLOCATE(gpsi(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for gpsi. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(gpsi_50(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for gpsi_50. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(gmax(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for gmax. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(gmin(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for gmin. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(kmax_leaf(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for kmax_leaf. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(kmax_stem(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for kmax_stem. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(kmax_root(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for kmax_root. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(a_leaf(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for a_leaf. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(a_stem(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for a_stem. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(a_root(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for a_root. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(P50_leaf(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for P50_leaf. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(P50_stem(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for P50_stem. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(P50_root(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for P50_root. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(wood_density(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for wood_density. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(w_density_stem(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for w_density_stem. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(root_shoot_ratio(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for root_shoot_ration. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      
+      ALLOCATE(rwc_root(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for rwc_root. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      
+      ALLOCATE(root_density(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for root_density. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(LDMC(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for LDMC. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(sla_hydro(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for sla_hydro. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(cxyl(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for cxyl. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(cr(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for cr. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(cl(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for cl. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      !
+      ! PRESCRIBE
+      !
+
+      ALLOCATE(tune_reserves_in_sapling(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for tune_reserves_in_sapling. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      ! This prevents a crash in getin_p with NAG, though I'm not sure why.
+      tune_reserves_in_sapling(:)=zero
+
+
+      !
+      ! MORTALITY
+      !
+
+      ALLOCATE(death_distribution_factor(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for death_distribution_factor. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(npp_reset_value(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for npp_reset_value. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      !
+      ! FIRE
+      !
+      ALLOCATE(flam(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for . We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(resist(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for resist. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      !
+      ! LUC
+      !
+      ALLOCATE(coeff_lcchange_s(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for coeff_lcchange_s. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(coeff_lcchange_m(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for coeff_lcchange_m. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(coeff_lcchange_l(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for coeff_lcchange_l. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      !
+      ! PHENOLOGY
+      !
+      ! 1. stomate
+      !
+      ALLOCATE(lai_max(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for lai_max. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(pheno_type(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for pheno_type. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+     
+      !
+      ! 2. Leaf Onset
+      !
+      ALLOCATE(pheno_gdd_crit_c(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for pheno_gdd_crit_c. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(pheno_gdd_crit_b(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for pheno_gdd_crit_b. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(pheno_gdd_crit_a(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for pheno_gdd_crit_a. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(pheno_gdd_crit(nvm,3),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for pheno_gdd_crit. We stop. We need nvm words = ',nvm*3
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      pheno_gdd_crit(:,:) = zero
+
+      ALLOCATE(ngd_crit(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for ngd_crit. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(opti_kpheno_crit(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for opti_kpheno_crit. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(ncdgdd_temp(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for ncdgdd_temp. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(hum_frac(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for hum_frac. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(hum_min_time(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for hum_min_time. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+   
+      ALLOCATE(tau_sap(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for tau_sap. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(tau_fruit(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for tau_fruit. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(tau_root(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for tau_root. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(tau_leaf(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for tau_leaf. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(ecureuil(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for ecureuil. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(alloc_min(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for alloc_min. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(alloc_max(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for alloc_max. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(demi_alloc(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for . We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      !
+      ! 3. Senescence
+      !
+      ALLOCATE(leaffall(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for leaffall. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(senescence_type(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for . We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(senescence_hum(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for senescence_hum. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(nosenescence_hum(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for nosenescence_hum. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(max_turnover_time(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for max_turnover_time. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(min_turnover_time(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for min_turnover_time. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(min_leaf_age_for_senescence(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for min_leaf_age_for_senescence. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(senescence_temp_c(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for senescence_temp_c. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(senescence_temp_b(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for senescence_temp_b. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(senescence_temp_a(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for senescence_temp_a. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(senescence_temp(nvm,3),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for senescence_temp. We stop. We need nvm*3 words = ',nvm*3
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      senescence_temp(:,:) = zero
+
+      ALLOCATE(gdd_senescence(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for gdd_senescence. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(residence_time(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for residence_time. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+      
+      ! added by yitong yao 07 Jan 2020 08:24
+       
+      ALLOCATE(plc_kill_frac(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for plc_kill_frac. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ! added by yitong yao 07 Jan 2020 08:24      
+
+
+      ! added by yitong yao 09 Feb 2020 22:58
+
+      ALLOCATE(mor_kill_frac(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for mor_kill_frac. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ! added by yitong yao 09 Feb 2020 22:58
+
+
+      ALLOCATE(tmin_crit(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for tmin_crit. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(tcm_crit(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for tcm_crit. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(mortality_min(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for mortality_min. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(mortality_max(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for mortality_max. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(ref_mortality(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for ref_mortality. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(tau_hum_growingseason(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for tau_hum_growingseason. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(lai_initmin(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for . We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+
+      !
+      ! DGVM
+      !
+   
+      !
+      ! KILL
+      !
+
+      ALLOCATE(dens_target(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for dens_target. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+
+      !
+      ! BVOC
+      !
+
+      
+      
+
+    
+
+      
+      !
+      ! FOREST MANAGEMENT
+      !
+      IF (active_flags%forest_management .OR. &
+           active_flags%ok_functional_allocation) THEN
+
+         ALLOCATE(plantation(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for plantation. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(fm_allo_a(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for fm_allo_a. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+         ! To prevent a crash in getin_p with NAG.
+         fm_allo_a(:)=zero
+
+         ALLOCATE(fm_allo_c(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for fm_allo_c. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+         ! To prevent a crash in getin_p with NAG.
+         fm_allo_c(:)=zero
+
+         ALLOCATE(fm_allo_d(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for fm_allo_d. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+         ! To prevent a crash in getin_p with NAG.
+         fm_allo_d(:)=zero
+
+         ALLOCATE(fm_allo_p(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for fm_allo_p. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+         ! To prevent a crash in getin_p with NAG.
+         fm_allo_p(:)=zero
+
+         ALLOCATE(fm_allo_q(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for fm_allo_q. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+         ! To prevent a crash in getin_p with NAG.
+         fm_allo_q(:)=zero
+
+         ALLOCATE(allo_crown_a0(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for allo_crown_a0. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(allo_crown_a1(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for allo_crown_a1. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(allo_crown_a2(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for allo_crown_a2. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(h_first(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for h_first. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(thinstrat(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for thinstrat. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(taumin(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for taumin. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(taumax(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for taumax. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(alpha_rdi_upper(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for alpha_rdi_upper. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(beta_rdi_upper(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for beta_rdi_upper. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(alpha_rdi_lower(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for alpha_rdi_lower. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(beta_rdi_lower(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for beta_rdi_lower. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(largest_tree_dia(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for largest_tree_dia. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(branch_ratio(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for branch_ratio. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(branch_harvest(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for branch_harvest. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(decl_factor(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for decl_factor. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+        ! ALLOCATE(opt_factor(nvm),stat=ier)   
+        ! l_error = l_error .OR. (ier /= 0)
+        ! IF (l_error) THEN
+        !    WRITE(numout,*) ' Memory allocation error for opt_factor. We stop. We need nvm words = ',nvm
+        !    CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+        ! END IF
+
+         ALLOCATE(coppice_diameter(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for coppice_diameter. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(shoots_per_stool(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for shoots_per_stool. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(src_rot_length(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for src_rot_length. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(src_nrots(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for src_nrots. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(deleuze_a(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for deleuze_a. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(deleuze_b(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for deleuze_b. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(deleuze_p_all(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for deleuze_p_all. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+
+         ALLOCATE(deleuze_p_coppice(nvm),stat=ier)   
+         l_error = l_error .OR. (ier /= 0)
+         IF (l_error) THEN
+            WRITE(numout,*) ' Memory allocation error for deleuze_p_coppice. We stop. We need nvm words = ',nvm
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         END IF
+      END IF
+
+
+
+      !
+      ! CROPLAND MANAGEMENT
+      !
+      ALLOCATE(harvest_ratio(nvm),stat=ier)   
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for harvest_ratio. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      !
+      ! OTHER
+      !
+      ALLOCATE(bm_sapl_old(nvm,nparts,nelements),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for bm_sapl_old. We stop. We need nvm*nparts*nelements words = ',& 
+              &  nvm*nparts*nelements
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(migrate(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for migrate. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(maxdia(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for maxdia. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(cn_sapl(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for cn_sapl. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+      ALLOCATE(leaf_timecst(nvm),stat=ier)
+      l_error = l_error .OR. (ier /= 0)
+      IF (l_error) THEN
+         WRITE(numout,*) ' Memory allocation error for leaf_timecst. We stop. We need nvm words = ',nvm
+         CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+      END IF
+
+   ENDIF ! (active_flags%ok_stomate)
+
+ END SUBROUTINE pft_parameters_alloc
+!
+!=
+!
+
+!! ================================================================================================================================
+!! SUBROUTINE   : config_pft_parameters 
+!!
+!>\BRIEF          This subroutine will read the imposed values for the global pft
+!! parameters (sechiba + stomate). It is not called if IMPOSE_PARAM is set to NO.
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+ SUBROUTINE config_pft_parameters
+   
+   IMPLICIT NONE
+
+   !! 0. Variables and parameters declaration
+  
+   !! 0.4 Local variable
+
+   LOGICAL, SAVE  :: first_call = .TRUE.  !! To keep first call trace (true/false)
+!$OMP THREADPRIVATE(first_call)
+   INTEGER(i_std) :: jv,ivm               !! Index (untiless)
+
+!_ ================================================================================================================================ 
+
+   IF (first_call) THEN
+
+      !
+      ! Vegetation structure
+      !
+
+      !Config Key   = LEAF_TAB
+      !Config Desc  = leaf type : 1=broad leaved tree, 2=needle leaved tree, 3=grass 4=bare ground
+      !Config if    = OK_STOMATE
+      !Config Def   = 4, 1, 1, 2, 1, 1, 2, 1, 2, 3, 3, 3, 3 
+      !Config Help  = 
+      !Config Units = [-] 
+      CALL getin_p('LEAF_TAB',leaf_tab)
+      
+      !Config Key   = PHENO_MODEL
+      !Config Desc  = which phenology model is used? (tabulated) 
+      !Config if    = OK_STOMATE
+      !Config Def   = none, none, moi, none, none, ncdgdd, none, ncdgdd, ngd, moigdd, moigdd, moigdd, moigdd
+      !Config Help  =
+      !Config Units = [-] 
+      CALL getin_p('PHENO_MODEL',pheno_model)
+      
+      !! Redefine the values for is_tree, is_deciduous, is_needleleaf, is_evergreen if values have been modified
+      !! in run.def
+
+      is_tree(:) = .FALSE.
+      DO jv = 1,nvm
+         IF ( leaf_tab(jv) <= 2 ) is_tree(jv) = .TRUE.
+      END DO
+      !
+      is_deciduous(:) = .FALSE.
+      DO jv = 1,nvm
+         IF ( is_tree(jv) .AND. (pheno_model(jv) /= "none") ) is_deciduous(jv) = .TRUE.
+      END DO
+      !
+      is_evergreen(:) = .FALSE.
+      DO jv = 1,nvm
+         IF ( is_tree(jv) .AND. (pheno_model(jv) == "none") ) is_evergreen(jv) = .TRUE.
+      END DO
+      !
+      is_needleleaf(:) = .FALSE.
+      DO jv = 1,nvm
+         IF ( leaf_tab(jv) == 2 ) is_needleleaf(jv) = .TRUE.
+      END DO
+
+
+      !Config Key   = SECHIBA_LAI
+      !Config Desc  = laimax for maximum lai(see also type of lai interpolation)
+      !Config if    = OK_SECHIBA or IMPOSE_VEG
+      !Config Def   = 0., 8., 8., 4., 4.5, 4.5, 4., 4.5, 4., 2., 2., 2., 2.
+      !Config Help  = Maximum values of lai used for interpolation of the lai map
+      !Config Units = [m^2/m^2]
+      CALL getin_p('SECHIBA_LAI',llaimax)
+
+      !Config Key   = LLAIMIN
+      !Config Desc  = laimin for minimum lai(see also type of lai interpolation)
+      !Config if    = OK_SECHIBA or IMPOSE_VEG
+      !Config Def   = 0., 8., 0., 4., 4.5, 0., 4., 0., 0., 0., 0., 0., 0.
+      !Config Help  = Minimum values of lai used for interpolation of the lai map
+      !Config Units = [m^2/m^2]
+      CALL getin_p('LLAIMIN',llaimin)
+
+      !Config Key   = SLOWPROC_HEIGHT
+      !Config Desc  = prescribed height of vegetation 
+      !Config if    = OK_SECHIBA
+      !Config Def   = 0., 30., 30., 20., 20., 20., 15., 15., 15., .5, .6, 1., 1.
+      !Config Help  =
+      !Config Units = [m] 
+      CALL getin_p('SLOWPROC_HEIGHT',height_presc)
+
+      !Config Key   = TYPE_OF_LAI
+      !Config Desc  = Type of behaviour of the LAI evolution algorithm 
+      !Config if    = OK_SECHIBA
+      !Config Def   = inter, inter, inter, inter, inter, inter, inter, inter, inter, inter, inter, inter, inter
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('TYPE_OF_LAI',type_of_lai)
+
+      !Config Key   = NATURAL
+      !Config Desc  = natural? 
+      !Config if    = OK_SECHIBA, OK_STOMATE
+      !Config Def   = y, y, y, y, y, y, y, y, y, y, y, n, n 
+      !Config Help  =
+      !Config Units = [BOOLEAN]
+      CALL getin_p('NATURAL',natural)
+
+      
+      !
+      ! Photosynthesis
+      !
+
+      !Config Key   = IS_C4
+      !Config Desc  = flag for C4 vegetation types
+      !Config if    = OK_SECHIBA or OK_STOMATE
+      !Config Def   = n, n, n, n, n, n, n, n, n, n, n, y, n, y
+      !Config Help  =
+      !Config Units = [BOOLEAN]
+      CALL getin_p('IS_C4',is_c4)
+
+      !Config Key   = VCMAX_FIX
+      !Config Desc  = values used for vcmax when STOMATE is not activated
+      !Config if    = OK_SECHIBA and NOT(OK_STOMATE)
+      !Config Def   = 0., 40., 50., 30., 35., 40.,30., 40., 35., 60., 60., 70., 70.
+      !Config Help  =
+      !Config Units = [micromol/m^2/s] 
+      CALL getin_p('VCMAX_FIX',vcmax_fix)
+
+      !Config Key   = E_KmC
+      !Config Desc  = Energy of activation for KmC
+      !Config if    = OK_CO2
+      !Config Def   = undef,  79430., 79430., 79430., 79430., 79430., 79430., 79430., 79430., 79430., 79430., 79430., 79430.
+      !Config Help  = See Medlyn et al. (2002) 
+      !Config Units = [J mol-1]
+      CALL getin_p('E_KMC',E_KmC)
+
+      !Config Key   = E_KmO
+      !Config Desc  = Energy of activation for KmO
+      !Config if    = OK_CO2
+      !Config Def   = undef, 36380.,  36380.,  36380.,  36380.,  36380., 36380., 36380., 36380., 36380., 36380., 36380., 36380.
+      !Config Help  = See Medlyn et al. (2002) 
+      !Config Units = [J mol-1]
+      CALL getin_p('E_KMO',E_KmO)
+
+      !Config Key   = E_gamma_star
+      !Config Desc  = Energy of activation for gamma_star
+      !Config if    = OK_CO2
+      !Config Def   = undef, 37830.,  37830.,  37830.,  37830.,  37830., 37830., 37830., 37830., 37830., 37830., 37830., 37830.
+      !Config Help  = See Medlyn et al. (2002) from Bernacchi al. (2001) 
+      !Config Units = [J mol-1]
+      CALL getin_p('E_GAMMA_STAR',E_gamma_star)
+
+      !Config Key   = E_Vcmax
+      !Config Desc  = Energy of activation for Vcmax
+      !Config if    = OK_CO2
+      !Config Def   = undef, 71513., 71513., 71513., 71513., 71513., 71513., 71513., 71513., 71513., 67300., 71513., 67300.
+      !Config Help  = See Table 2 of Yin et al. (2009) for C4 plants and Kattge & Knorr (2007) for C3 plants (table 3)
+      !Config Units = [J mol-1]
+      CALL getin_p('E_VCMAX',E_Vcmax)
+
+      !Config Key   = E_Jmax
+      !Config Desc  = Energy of activation for Jmax
+      !Config if    = OK_CO2
+      !Config Def   = undef, 49884., 49884., 49884., 49884., 49884., 49884., 49884., 49884., 49884., 77900., 49884., 77900. 
+      !Config Help  = See Table 2 of Yin et al. (2009) for C4 plants and Kattge & Knorr (2007) for C3 plants (table 3)
+      !Config Units = [J mol-1]
+      CALL getin_p('E_JMAX',E_Jmax)
+
+      !Config Key   = aSV
+      !Config Desc  = a coefficient of the linear regression (a+bT) defining the Entropy term for Vcmax
+      !Config if    = OK_CO2
+      !Config Def   = undef, 668.39, 668.39, 668.39, 668.39, 668.39, 668.39, 668.39, 668.39, 668.39, 641.64, 668.39, 641.64 
+      !Config Help  = See Table 3 of Kattge & Knorr (2007) - For C4 plants, we assume that there is no acclimation and that at for a temperature of 25Â°C, aSV is the same for both C4 and C3 plants (no strong jusitification - need further parametrization)
+      !Config Units = [J K-1 mol-1]
+      CALL getin_p('ASV',aSV)
+
+      !Config Key   = bSV
+      !Config Desc  = b coefficient of the linear regression (a+bT) defining the Entropy term for Vcmax
+      !Config if    = OK_CO2
+      !Config Def   = undef, -1.07, -1.07, -1.07, -1.07, -1.07, -1.07, -1.07, -1.07, -1.07, 0., -1.07, 0. 
+      !Config Help  = See Table 3 of Kattge & Knorr (2007) - For C4 plants, we assume that there is no acclimation
+      !Config Units = [J K-1 mol-1 Â°C-1]
+      CALL getin_p('BSV',bSV)
+
+      !Config Key   = TPHOTO_MIN
+      !Config Desc  = minimum photosynthesis temperature (deg C)
+      !Config if    = OK_STOMATE
+      !Config Def   = undef,  -4., -4., -4., -4.,-4.,-4., -4., -4., -4., -4., -4., -4.
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('TPHOTO_MIN',tphoto_min)
+
+      !Config Key   = TPHOTO_MAX
+      !Config Desc  = maximum photosynthesis temperature (deg C)
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 55., 55., 55., 55., 55., 55., 55., 55., 55., 55., 55., 55.
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('TPHOTO_MAX',tphoto_max)
+
+      !Config Key   = aSJ
+      !Config Desc  = a coefficient of the linear regression (a+bT) defining the Entropy term for Jmax
+      !Config if    = OK_CO2
+      !Config Def   = undef, 659.70, 659.70, 659.70, 659.70, 659.70, 659.70, 659.70, 659.70, 659.70, 630., 659.70, 630. 
+      !Config Help  = See Table 3 of Kattge & Knorr (2007) - and Table 2 of Yin et al. (2009) for C4 plants
+      !Config Units = [J K-1 mol-1]
+      CALL getin_p('ASJ',aSJ)
+
+      !Config Key   = bSJ
+      !Config Desc  = b coefficient of the linear regression (a+bT) defining the Entropy term for Jmax
+      !Config if    = OK_CO2
+      !Config Def   = undef, -0.75, -0.75, -0.75, -0.75, -0.75, -0.75, -0.75, -0.75, -0.75, 0., -0.75, 0. 
+      !Config Help  = See Table 3 of Kattge & Knorr (2007) - For C4 plants, we assume that there is no acclimation
+      !Config Units = [J K-1 mol-1 Â°C-1]
+      CALL getin_p('BSJ',bSJ)
+
+      !Config Key   = D_Vcmax
+      !Config Desc  = Energy of deactivation for Vcmax
+      !Config if    = OK_CO2
+      !Config Def   = undef, 200000., 200000., 200000., 200000., 200000., 200000., 200000., 200000., 200000., 192000., 200000., 192000.
+      !Config Help  = Medlyn et al. (2002) also uses 200000. for C3 plants (same value than D_Jmax). 'Consequently', we use the value of D_Jmax for C4 plants.
+      !Config Units = [J mol-1]
+      CALL getin_p('D_VCMAX',D_Vcmax)
+
+      !Config Key   = D_Jmax
+      !Config Desc  = Energy of deactivation for Jmax
+      !Config if    = OK_CO2
+      !Config Def   = undef, 200000., 200000., 200000., 200000., 200000., 200000., 200000., 200000., 200000., 192000., 200000., 192000.
+      !Config Help  = See Table 2 of Yin et al. (2009)
+      !Config Units = [J mol-1]
+      CALL getin_p('D_JMAX',D_Jmax)
+
+      !Config Key   = E_Rd
+      !Config Desc  = Energy of activation for Rd
+      !Config if    = OK_CO2
+      !Config Def   = undef, 46390., 46390., 46390., 46390., 46390., 46390., 46390., 46390., 46390., 46390., 46390., 46390.
+      !Config Help  = See Table 2 of Yin et al. (2009)
+      !Config Units = [J mol-1]
+      CALL getin_p('E_RD',E_Rd)
+
+      !Config Key   = VCMAX25
+      !Config Desc  = Maximum rate of Rubisco activity-limited carboxylation at 25Â°C
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 65., 65., 35., 45., 55., 35., 45., 35., 70., 70., 70., 70.
+      !Config Help  =
+      !Config Units = [micromol/m^2/s]
+      CALL getin_p('VCMAX25',Vcmax25)
+
+      !Config Key   = ARJV
+      !Config Desc  = a coefficient of the linear regression (a+bT) defining the Jmax25/Vcmax25 ratio 
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 2.59, 2.59, 2.59, 2.59, 2.59, 2.59, 2.59, 2.59, 2.59, 1.715, 2.59, 1.715
+      !Config Help  = See Table 3 of Kattge & Knorr (2007) - For C4 plants, we assume that there is no acclimation and that for a temperature of 25Â°C, aSV is the same for both C4 and C3 plants (no strong jusitification - need further parametrization)
+      !Config Units = [mu mol e- (mu mol CO2)-1]
+      CALL getin_p('ARJV',arJV)
+
+      !Config Key   = BRJV
+      !Config Desc  = b coefficient of the linear regression (a+bT) defining the Jmax25/Vcmax25 ratio 
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, -0.035, -0.035, -0.035, -0.035, -0.035, -0.035, -0.035, -0.035, -0.035, 0., -0.035, 0.
+      !Config Help  = See Table 3 of Kattge & Knorr (2007) -  We assume No acclimation term for C4 plants
+      !Config Units = [(mu mol e- (mu mol CO2)-1) (Â°C)-1]
+      CALL getin_p('BRJV',brJV)
+
+      !Config Key   = KmC25
+      !Config Desc  = MichaelisâMenten constant of Rubisco for CO2 at 25Â°C
+      !Config if    = OK_CO2
+      !Config Def   = undef, 404.9, 404.9, 404.9, 404.9, 404.9, 404.9, 404.9, 404.9, 404.9, 650., 404.9, 650.
+      !Config Help  = See Table 2 of Yin et al. (2009) for C4 plants and Medlyn et al. (2002) for C3 plants
+      !Config Units = [ubar]
+      CALL getin_p('KMC25',KmC25)
+
+      !Config Key   = KmO25
+      !Config Desc  = MichaelisâMenten constant of Rubisco for O2 at 25Â°C
+      !Config if    = OK_CO2
+      !Config Def   = undef, 278400., 278400., 278400., 278400., 278400., 278400., 278400., 278400., 278400., 450000., 278400., 450000.
+      !Config Help  = See Table 2 of Yin et al. (2009) for C4 plants and Medlyn et al. (2002) for C3 plants
+      !Config Units = [ubar]
+      CALL getin_p('KMO25',KmO25)
+
+      !Config Key   = gamma_star25
+      !Config Desc  = Ci-based CO2 compensation point in the absence of Rd at 25Â°C (ubar)
+      !Config if    = OK_CO2
+      !Config Def   = undef, 42.75, 42.75, 42.75, 42.75, 42.75, 42.75, 42.75, 42.75, 42.75, 42.75, 42.75, 42.75
+      !Config Help  = See Medlyn et al. (2002) for C3 plants - For C4 plants, we use the same value (probably uncorrect)
+      !Config Units = [ubar]
+      CALL getin_p('gamma_star25',gamma_star25)
+
+      !Config Key   = a1
+      !Config Desc  = Empirical factor involved in the calculation of fvpd
+      !Config if    = OK_CO2
+      !Config Def   = undef, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85
+      !Config Help  = See Table 2 of Yin et al. (2009)
+      !Config Units = [-]
+      CALL getin_p('A1',a1)
+
+      !Config Key   = b1
+      !Config Desc  = Empirical factor involved in the calculation of fvpd
+      !Config if    = OK_CO2
+      !Config Def   = undef, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.20, 0.14, 0.20
+      !Config Help  = See Table 2 of Yin et al. (2009)
+      !Config Units = [-]
+      CALL getin_p('B1',b1)
+
+      !Config Key   = g0
+      !Config Desc  = Residual stomatal conductance when irradiance approaches zero 
+      !Config if    = OK_CO2
+      !Config Def   = undef, 0.00625, 0.00625, 0.00625, 0.00625, 0.00625, 0.00625, 0.00625, 0.00625, 0.00625, 0.01875, 0.00625, 0.01875 
+      !Config Help  = Value from ORCHIDEE - No other reference.
+      !Config Units = [mol mâ2 sâ1 barâ1]
+      CALL getin_p('G0',g0)
+
+      !Config Key   = h_protons
+      !Config Desc  = Number of protons required to produce one ATP
+      !Config if    = OK_CO2
+      !Config Def   = undef, 4., 4., 4., 4., 4., 4., 4., 4., 4., 4., 4., 4. 
+      !Config Help  = See Table 2 of Yin et al. (2009) - h parameter
+      !Config Units = [mol mol-1]
+      CALL getin_p('H_PROTONS',h_protons)
+
+      !Config Key   = fpsir
+      !Config Desc  = Fraction of PSII eâ transport rate partitioned to the C4 cycle
+      !Config if    = OK_CO2
+      !Config Def   = undef, undef, undef, undef, undef, undef, undef, undef, undef, undef, 0.4, undef, 0.4 
+      !Config Help  = See Table 2 of Yin et al. (2009)
+      !Config Units = [-]
+      CALL getin_p('FPSIR',fpsir)
+
+      !Config Key   = fQ
+      !Config Desc  = Fraction of electrons at reduced plastoquinone that follow the Q-cycle
+      !Config if    = OK_CO2
+      !Config Def   = undef, undef, undef, undef, undef, undef, undef, undef, undef, undef, 1., undef, 1.
+      !Config Help  = See Table 2 of Yin et al. (2009) - Values for C3 plants are not used
+      !Config Units = [-]
+      CALL getin_p('FQ',fQ)
+
+      !Config Key   = fpseudo
+      !Config Desc  = Fraction of electrons at PSI that follow pseudocyclic transport 
+      !Config if    = OK_CO2
+      !Config Def   = undef, undef, undef, undef, undef, undef, undef, undef, undef, undef, 0.1, undef, 0.1
+      !Config Help  = See Table 2 of Yin et al. (2009) - Values for C3 plants are not used
+      !Config Units = [-]
+      CALL getin_p('FPSEUDO',fpseudo)
+
+      !Config Key   = kp
+      !Config Desc  = Initial carboxylation efficiency of the PEP carboxylase
+      !Config if    = OK_CO2
+      !Config Def   = undef, undef, undef, undef, undef, undef, undef, undef, undef, undef, 0.7, undef, 0.7
+      !Config Help  = See Table 2 of Yin et al. (2009) 
+      !Config Units = [mol mâ2 sâ1 barâ1]
+      CALL getin_p('KP',kp)
+
+      !Config Key   = alpha
+      !Config Desc  = Fraction of PSII activity in the bundle sheath
+      !Config if    = OK_CO2
+      !Config Def   = undef, undef, undef, undef, undef, undef, undef, undef, undef, undef, 0.1, undef, 0.1
+      !Config Help  = See legend of Figure 6 of Yin et al. (2009)
+      !Config Units = [-]
+      CALL getin_p('ALPHA',alpha)
+
+      !Config Key   = gbs
+      !Config Desc  = Bundle-sheath conductance
+      !Config if    = OK_CO2
+      !Config Def   = undef, undef, undef, undef, undef, undef, undef, undef, undef, undef, 0.003, undef, 0.003
+      !Config Help  = See legend of Figure 6 of Yin et al. (2009)
+      !Config Units = [mol mâ2 sâ1 barâ1]
+      CALL getin_p('GBS',gbs)
+
+      !Config Key   = theta
+      !Config Desc  = Convexity factor for response of J to irradiance
+      !Config if    = OK_CO2
+      !Config Def   = undef, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7
+      !Config Help  = See Table 2 of Yin et al. (2009)   
+      !Config Units = [â]
+      CALL getin_p('THETA',theta)
+
+      !Config Key   = alpha_LL
+      !Config Desc  = Conversion efficiency of absorbed light into J at strictly limiting light
+      !Config if    = OK_CO2
+      !Config Def   = undef, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3
+      !Config Help  = See comment from Yin et al. (2009) after eq. 4
+      !Config Units = [mol eâ (mol photon)â1]
+      CALL getin_p('ALPHA_LL',alpha_LL)
+
+      !Config Key   = DOWNREGULATION_CO2_COEFF
+      !Config Desc  = coefficient for CO2 downregulation (unitless)
+      !Config if    = OK_CO2
+      !Config Def   = 0., 0.38, 0.38, 0.28, 0.28, 0.28, 0.22, 0.22, 0.22, 0.26, 0.26, 0.26, 0.26
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('DOWNREGULATION_CO2_COEFF',downregulation_co2_coeff)
+
+      !Config Key   = EXT_COEFF
+      !Config Desc  = extinction coefficient of the Monsi&Seaki relationship (1953)
+      !Config if    = OK_SECHIBA or OK_STOMATE
+      !Config Def   = .5, .5, .5, .5, .5, .5, .5, .5, .5, .5, .5, .5, .5
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('EXT_COEFF',ext_coeff)
+     
+      !
+      ! Water-hydrology - sechiba
+      !
+
+      !Config Key   = HYDROL_HUMCSTE
+      !Config Desc  = Root profile
+      !Config Def   = 5., .4, .4, 1., .8, .8, 1., 1., .8, 4., 1., 4., 1. 
+      !Config if    = OK_SECHIBA
+      !Config Help  = Default values were defined for 4 meters soil depth.
+      !Config         For 2 meters soil depth, you may use those ones :
+      !Config         5., .8, .8, 1., .8, .8, 1., 1., .8, 4., 4., 4., 4.
+      !Config Units = [m]
+      CALL getin_p('HYDROL_HUMCSTE',humcste)
+
+      !
+      ! Soil - vegetation
+      !
+
+      !Config Key   = PREF_SOIL_VEG
+      !Config Desc  = The soil tile number for each vegetation
+      !Config if    = OK_SECHIBA or OK_STOMATE
+      !Config Def   = 1, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3
+      !Config Help  = Gives the number of the soil tile on which we will
+      !Config         put each vegetation. This allows to divide the hydrological column
+      !Config Units = [-]        
+      CALL getin_p('PREF_SOIL_VEG',pref_soil_veg)
+
+      !
+      ! Vegetation - Age classes
+      !
+      !Config Key   = NVMAP
+      !Config Desc  = The number of PFTs if we ignore age classes.  If nagec = 1, this is just nvm.
+      !Config if    = OK_SECHIBA or OK_STOMATE
+      !Config Def   = nvm
+      !Config Help  = Gives the total number of PFTs ignoring age classes.
+      !Config Units = [-]  
+      nvmap=nvm
+      CALL getin_p('NVMAP',nvmap)
+      IF(nagec > 1 .AND. nvmap == nvm)THEN
+         WRITE(numout,*) 'WARNING: The number of age classes is greater than one, but'
+         WRITE(numout,*) '         the input file indicates that none of the PFTs have age classes.'
+         WRITE(numout,*) '         You should change either nagec or nvmap.'
+      ENDIF
+
+      !Config Key   = AGEC_GROUP
+      !Config Desc  = The group that each PFT belongs to.  
+      !Config if    = OK_SECHIBA or OK_STOMATE
+      !Config Def   = 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13
+      !Config Help  = The group that each PFT belongs to.  If you are not using age classes, this
+      !Config         is just equal to the number of the PFT.
+      !Config Units = [-]   
+      DO ivm=1,nvm
+         agec_group(ivm)=ivm
+      ENDDO
+      CALL getin_p('AGEC_GROUP',agec_group)
+
+      first_call = .FALSE.
+
+   ENDIF !(first_call)
+
+ END SUBROUTINE config_pft_parameters
+!
+!=
+!
+
+!! ================================================================================================================================
+!! SUBROUTINE   : config_sechiba_pft_parameters
+!!
+!>\BRIEF        This subroutine will read the imposed values for the sechiba pft
+!! parameters. It is not called if IMPOSE_PARAM is set to NO. 
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+ SUBROUTINE config_sechiba_pft_parameters(active_flags)
+
+   IMPLICIT NONE
+  
+   !! 0. Variables and parameters declaration
+
+   !! 0.1 Input variables
+
+   TYPE(control_type), INTENT(in) :: active_flags     !! What parts of the code are activated ?
+
+   !! 0.4 Local variable
+
+   LOGICAL, SAVE ::  first_call = .TRUE.   !! To keep first call trace (true/false)
+!$OMP THREADPRIVATE(first_call)
+
+!_ ================================================================================================================================ 
+
+   IF (first_call) THEN
+
+      !
+      ! Evapotranspiration -  sechiba
+      !
+      
+      !Config Key   = RSTRUCT_CONST
+      !Config Desc  = Structural resistance 
+      !Config if    = OK_SECHIBA
+      !Config Def   = 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
+      !Config Help  =
+      !Config Units = [s/m]
+      CALL getin_p('RSTRUCT_CONST',rstruct_const)
+      
+      !Config Key   = KZERO
+      !Config Desc  = A vegetation dependent constant used in the calculation of the surface resistance.
+      !Config if    = OK_SECHIBA
+      !Config Def   = 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 
+      !Config Help  =
+      !Config Units = [kg/m^2/s]
+      CALL getin_p('KZERO',kzero)
+      
+      !Config Key   = RVEG_PFT
+      !Config Desc  = Artificial parameter to increase or decrease canopy resistance.
+      !Config if    = OK_SECHIBA
+      !Config Def   = 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1.
+      !Config Help  = This parameter is set by PFT.
+      !Config Units = [-]
+      CALL getin_p('RVEG_PFT',rveg_pft)    
+      
+      !
+      ! Water-hydrology - sechiba
+      !
+
+      !Config Key   = WMAX_VEG
+      !Config Desc  = Maximum field capacity for each of the vegetations (Temporary): max quantity of water
+      !Config if    = OK_SECHIBA
+      !Config Def   = 150., 150., 150., 150., 150., 150., 150.,150., 150., 150., 150., 150., 150.
+      !Config Help  =
+      !Config Units = [kg/m^3]
+      CALL getin_p('WMAX_VEG',wmax_veg)
+      !
+      IF ( .NOT.(active_flags%hydrol_cwrr) .OR. (active_flags%hydrol_cwrr .AND. ok_throughfall_by_pft) ) THEN
+         !Config Key   = PERCENT_THROUGHFALL_PFT
+         !Config Desc  = Percent by PFT of precip that is not intercepted by the canopy
+         !Config if    = OK_SECHIBA OR HYDROL_CWRR
+         !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.
+         !Config Units = [%]
+         CALL getin_p('PERCENT_THROUGHFALL_PFT',throughfall_by_pft)
+         throughfall_by_pft(:) = throughfall_by_pft(:) / 100. 
+      END IF
+      
+      !
+      ! Albedo - sechiba
+      !
+
+      !Config Key   = SNOWA_AGED
+      !Config Desc  = Minimum snow albedo value for each vegetation type after aging (dirty old snow)
+      !Config if    = OK_SECHIBA
+      !Config Def   = 0.35, 0., 0., 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.18, 0.18, 0.18, 0.18
+      !Config Help  = Values are from the Thesis of S. Chalita (1992)
+      !Config Units = [-]
+      CALL getin_p('SNOWA_AGED',snowa_aged)
+
+      !Config Key   = SNOWA_DEC
+      !Config Desc  = Decay rate of snow albedo value for each vegetation type as it will be used in condveg_snow
+      !Config if    = OK_SECHIBA
+      !Config Def   = 0.45, 0.,  0., 0.06, 0.06, 0.11, 0.06, 0.11, 0.11, 0.52,0.52, 0.52, 0.52
+      !Config Help  = Values are from the Thesis of S. Chalita (1992)
+      !Config Units = [-]
+      CALL getin_p('SNOWA_DEC',snowa_dec)
+
+      !Config Key   = ALB_LEAF_VIS
+      !Config Desc  = leaf albedo of vegetation type, visible albedo
+      !Config if    = OK_SECHIBA
+      !Config Def   = .00, .04, .06, .06, .06,.06, .06, .06, .06, .10, .10, .10, .10
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('ALB_LEAF_VIS',alb_leaf_vis)
+
+      !Config Key   = ALB_LEAF_NIR
+      !Config Desc  = leaf albedo of vegetation type, near infrared albedo
+      !Config if    = OK_SECHIBA
+      !Config Def   = .00, .20, .22, .22, .22,.22, .22, .22, .22, .30, .30, .30, .30 
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('ALB_LEAF_NIR',alb_leaf_nir)
+      !
+      !Config Key  = LEAF_SSA_VIS
+      !Config Desc = Leaf_single_scattering_albedo_vis values
+      !Config If   = ALBEDO_TYPE == Pinty
+      !Config Def  = 0.17192, 0.12560, 0.16230, 0.13838, 0.13202, 0.14720,  
+      !              0.14680, 0.14415, 0.15485, 0.17544, 0.17384, 0.17302, 0.17116 
+      !Config Help  =
+      !Config Units = [-]
+      !
+      CALL getin_p('LEAF_SSA_VIS',leaf_ssa(:,ivis))
+      WRITE(numout,*) 'Single scattering albedo values for the leaves in the VIS spectrum: ',leaf_ssa(:,ivis)
+      !
+      !Config Key  = LEAF_SSA_NIR
+      !Config Desc = Leaf_single_scattering_albedo_nir values
+      !Config If   = ALBEDO_TYPE == Pinty
+      !Config Def  = 0.70253, 0.68189, 0.69684, 0.68778, 0.68356, 0.69533, &
+      !              0.69520, 0.69195, 0.69180, 0.71236, 0.71904, 0.71220, 0.71190
+      !Config Help  =
+      !Config Units = [-]
+      !
+      CALL getin_p('LEAF_SSA_NIR',leaf_ssa(:,inir))
+      WRITE(numout,*) 'Single scattering albedo values for the leaves in the NIR spectrum: ',leaf_ssa(:,inir)
+      !
+      !Config Key  = LEAF_PSD_VIS
+      !Config Desc = Preferred scattering direction values in the visibile spectra
+      !Config If   = ALBEDO_TYPE == Pinty
+      !Config Def  = 1.00170, 0.96776, 0.99250, 0.97170, 0.97119, 0.98077, &
+      !              0.97672, 0.97810, 0.98605, 1.00490, 1.00360, 1.00320, 1.00130
+      !Config Help  =
+      !Config Units = [-]
+      !
+      CALL getin_p('LEAF_PSD_VIS',leaf_psd(:,ivis))
+      WRITE(numout,*) 'Preferred scattering direction values for the leaves in the VIS spectrum: ',leaf_psd(:,ivis)
+      !
+      !Config Key  = LEAF_PSD_NIR
+      !Config Desc =  Preferred scattering direction values in the near infrared spectra
+      !Config If   = ALBEDO_TYPE == Pinty
+      !Config Def  = 2.00520, 1.95120, 1.98990, 1.97020, 1.95900, 1.98190, &
+      !              1.98890, 1.97400, 1.97780, 2.02430, 2.03350, 2.02070, 2.02150
+      !Config Help  =
+      !Config Units = [-]
+      !
+      CALL getin_p('LEAF_PSD_NIR',leaf_psd(:,inir)) 
+      WRITE(numout,*) 'Preferred scattering direction values for the leaves in the NIR spectrum: ',leaf_psd(:,inir)
+      !
+      !
+      !Config Key  = BGRD_REF_VIS
+      !Config Desc = Background reflectance values in the visibile spectra
+      !Config If   = ALBEDO_TYPE == Pinty
+      !Config Def   = 0.2300000,   0.0866667,   0.0800000,   0.0533333,   0.0700000,   0.0933333,   0.0533333,    
+      !               0.0833333,   0.0633333,   0.1033330,   0.1566670,   0.1166670,   0.1200000
+      !Config Help  =
+      !Config Units = [-]
+      !
+      CALL getin_p('BGRD_REF_VIS',bgd_reflectance(:,ivis)) 
+      WRITE(numout,*) 'Background (soil) reflectance values in the VIS spectrum: ',bgd_reflectance(:,ivis)
+      !
+      !Config Key  = BGRD_REF_NIR
+      !Config Desc = Background reflectance values in the near infrared spectra
+      !Config If   = ALBEDO_TYPE == Pinty
+      !Config Def   = 0.4200000,   0.1500000,   0.1300000,   0.0916667,   0.1066670,   0.1650000,   0.0900000,    
+      !               0.1483330,   0.1066670,   0.1900000,   0.3183330,   0.2200000,   0.2183330
+      !Config Help  =
+      !Config Units = [-]
+      !
+      CALL getin_p('BGRD_REF_NIR',bgd_reflectance(:,inir)) 
+      WRITE(numout,*) 'Background (soil) reflectance values in the NIR spectrum: ',bgd_reflectance(:,inir)
+
+      !
+      !Config Key  = LEAF_TO_SHOOT_CLUMPING
+      !Config Desc = The leaf-to-shoot clumping factor
+      !Config If   = ALBEDO_TYPE == Pinty
+      !Config Def   = un,   un,   un,   un,   un,   un,   un,   
+      !               un,   un,   un,   un,   un,   un
+      !Config Help  =
+      !Config Units = [-]
+      !
+      CALL getin_p('LEAF_TO_SHOOT_CLUMPING',leaf_to_shoot_clumping(:)) 
+      WRITE(numout,*) 'Leaf-to-shoot clumping factors: ',leaf_to_shoot_clumping(:)
+      !
+      !Config Key  = LAI_CORRECTION_FACTOR
+      !Config Desc = The correction factor for the LAI for grasslands and crops (see note in pft_parameters)
+      !Config If   = ALBEDO_TYPE == Pinty
+      !Config Def   = un,   un,   un,   un,   un,   un,   un,   
+      !               un,   un,   un,   un,   un,   un
+      !Config Help  =
+      !Config Units = [-]   
+      
+      CALL getin_p('TUNE_COUPLED',tune_coupled(:)) 
+      WRITE(numout,*) 'Tunning the propotion of LAI contributed to transpiration: ', tune_coupled(:)
+      !
+      !Config Key  = TUNE_COUPLED
+      !Config Desc = The correction factor for the LAI which is coupled with atmosphere
+      !Config If   = 
+      !Config Def   = un,   un,   un,   un,   un,   un,   un,   
+      !               un,   un,   un,   un,   un,   un
+      !Config Help  =
+      !Config Units = [-]
+      
+      !
+      CALL getin_p('LAI_CORRECTION_FACTOR',lai_correction_factor(:)) 
+      WRITE(numout,*) 'LAI correction factors: ',lai_correction_factor(:)
+
+      !Config Key  = MIN_LEVEL_SEP
+      !Config Desc = The minimum level thickness we use for photosynthesis 
+      !Config If   = ALBEDO_TYPE == Pinty
+      !Config Def   = un,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   
+      !               0.1,   0.1,   0.1,   0.1,   0.1,   0.1
+      !Config Help  =
+      !Config Units = [m]
+      !
+      CALL getin_p('MIN_LEVEL_SEP',min_level_sep(:)) 
+      WRITE(numout,*) 'Minimum level separation: ',min_level_sep(:)
+
+      !Config Key  = LAI_TOP
+      !Config Desc = Definition, in terms of LAI of the top layer 
+      !              (used to calculate one of the resistences of 
+      !              vbeta3) to calculate transpiration 
+      !Config If   = 
+      !Config Def  = un,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   
+      !              0.1,   0.1,   0.1,   0.1,   0.1,   0.1
+      !Config Help  =
+      !Config Units = [m2 m2]
+      !
+      CALL getin_p('LAI_TOP',lai_top(:)) 
+      WRITE(numout,*) 'Defining the "top layer" for transpiration in terms of LAI: ',lai_top(:)
+      
+      
+      !Config Key  = TUNE_COUPLED
+      !Config Desc = Definition, in terms of LAI of the top layer which is contributed to the transpiration 
+      !              (used to calculate one of the resistences of vbeta3) to calculate transpiration 
+      !Config If   = 
+      !Config Def  = un,   un,   un,   un,   un,   un,   un,   
+      !              un,   un,   un,   un,   un,   un
+      !Config Help  =
+      !Config Units = [-]
+      !
+      CALL getin_p('TUNE_COUPLED',tune_coupled(:)) 
+      WRITE(numout,*) 'tunning the "the porpotion of the coupled layer" for transpiration : ',tune_coupled(:)
+
+
+      IF ( active_flags%ok_inca ) THEN
+         !
+         ! BVOC
+         !
+
+         !Config Key   = ISO_ACTIVITY
+         !Config Desc  = Biogenic activity for each age class : isoprene
+         !Config if    = DIFFUCO_OK_INCA
+         !Config Def   = 0.5, 1.5, 1.5, 0.5
+         !Config Help  =
+         !Config Units = [-]
+         CALL getin_p('ISO_ACTIVITY',iso_activity)
+
+         !Config Key   = METHANOL_ACTIVITY
+         !Config Desc  = Isoprene emission factor for each age class : methanol
+         !Config if    = DIFFUCO_OK_INCA
+         !Config Def   = 1., 1., 0.5, 0.5
+         !Config Help  =
+         !Config Units = [-]
+         CALL getin_p('METHANOL_ACTIVITY',methanol_activity)
+
+         !Config Key   = EM_FACTOR_ISOPRENE
+         !Config Desc  = Isoprene emission factor
+         !Config if    = DIFFUCO_OK_INCA
+         !Config Def   = 0., 24., 24., 8., 16., 45., 8., 8., 8., 16., 24., 5., 5.
+         !Config Help  =
+         !Config Units = [ugC/g/h] 
+         CALL getin_p('EM_FACTOR_ISOPRENE',em_factor_isoprene)
+
+         !Config Key   = EM_FACTOR_MONOTERPENE
+         !Config Desc  = Monoterpene emission factor 
+         !Config if    = DIFFUCO_OK_INCA 
+         !Config Def   = 0., 0.8, 0.8, 2.4, 1.2, 0.8, 2.4, 2.4, 2.4, 0.8, 1.2, 0.2, 0.2
+         !Config Help  =
+         !Config Units = [ugC/g/h] 
+         CALL getin_p('EM_FACTOR_MONOTERPENE',em_factor_monoterpene)
+
+         !Config Key   = EM_FACTOR_ORVOC
+         !Config Desc  = ORVOC emissions factor 
+         !Config if    = DIFFUCO_OK_INCA 
+         !Config Def   = 0., 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5
+         !Config Help  =
+         !Config Units = [ugC/g/h]  
+         CALL getin_p('EM_FACTOR_ORVOC',em_factor_ORVOC)
+
+         !Config Key   = EM_FACTOR_OVOC
+         !Config Desc  = OVOC emissions factor
+         !Config if    = DIFFUCO_OK_INCA
+         !Config Def   = 0., 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5
+         !Config Help  =
+         !Config Units = [ugC/g/h]        
+         CALL getin_p('EM_FACTOR_OVOC',em_factor_OVOC)
+
+         !Config Key   = EM_FACTOR_MBO
+         !Config Desc  = MBO emissions factor 
+         !Config if    = DIFFUCO_OK_INCA 
+         !Config Def   = 0., 0., 0., 20.0, 0., 0., 0., 0., 0., 0., 0., 0., 0.
+         !Config Help  =
+         !Config Units = [ugC/g/h]  
+         CALL getin_p('EM_FACTOR_MBO',em_factor_MBO)
+
+         !Config Key   = EM_FACTOR_METHANOL
+         !Config Desc  = Methanol emissions factor 
+         !Config if    = DIFFUCO_OK_INCA 
+         !Config Def   = 0., 0.6, 0.6, 1.8, 0.9, 0.6, 1.8, 1.8, 1.8, 0.6, 0.9, 2., 2.
+         !Config Help  =
+         !Config Units = [ugC/g/h]  
+         CALL getin_p('EM_FACTOR_METHANOL',em_factor_methanol)
+
+         !Config Key   = EM_FACTOR_ACETONE
+         !Config Desc  = Acetone emissions factor
+         !Config if    = DIFFUCO_OK_INCA 
+         !Config Def   = 0., 0.29, 0.29, 0.87, 0.43, 0.29, 0.87, 0.87, 0.87, 0.29, 0.43, 0.07, 0.07 
+         !Config Help  =
+         !Config Units = [ugC/g/h]     
+         CALL getin_p('EM_FACTOR_ACETONE',em_factor_acetone)
+
+         !Config Key   = EM_FACTOR_ACETAL
+         !Config Desc  = Acetaldehyde emissions factor 
+         !Config if    = DIFFUCO_OK_INCA
+         !Config Def   = 0., 0.1, 0.1, 0.3, 0.15, 0.1, 0.3, 0.3, 0.3, 0.1, 0.15, 0.025, 0.025
+         !Config Help  =
+         !Config Units = [ugC/g/h]  
+         CALL getin_p('EM_FACTOR_ACETAL',em_factor_acetal)
+
+         !Config Key   = EM_FACTOR_FORMAL
+         !Config Desc  = Formaldehyde emissions factor
+         !Config if    = DIFFUCO_OK_INCA 
+         !Config Def   = 0., 0.07, 0.07, 0.2, 0.1, 0.07, 0.2, 0.2, 0.2, 0.07, 0.1, 0.017, 0.017
+         !Config Help  = 
+         !Config Units = [ugC/g/h]  
+         CALL getin_p('EM_FACTOR_FORMAL',em_factor_formal)
+
+         !Config Key   = EM_FACTOR_ACETIC
+         !Config Desc  = Acetic Acid emissions factor
+         !Config if    = DIFFUCO_OK_INCA 
+         !Config Def   = 0., 0.002, 0.002, 0.006, 0.003, 0.002, 0.006, 0.006, 0.006, 0.002, 0.003, 0.0005, 0.0005
+         !Config Help  =
+         !Config Units = [ugC/g/h]  
+         CALL getin_p('EM_FACTOR_ACETIC',em_factor_acetic)
+
+         !Config Key   = EM_FACTOR_FORMIC
+         !Config Desc  = Formic Acid emissions factor
+         !Config if    = DIFFUCO_OK_INCA
+         !Config Def   = 0., 0.01, 0.01, 0.03, 0.015, 0.01, 0.03, 0.03, 0.03, 0.01, 0.015, 0.0025, 0.0025 
+         !Config Help  =
+         !Config Units = [ugC/g/h]  
+         CALL getin_p('EM_FACTOR_FORMIC',em_factor_formic)
+
+         !Config Key   = EM_FACTOR_NO_WET
+         !Config Desc  = NOx emissions factor wet soil emissions and exponential dependancy factor 
+         !Config if    = DIFFUCO_OK_INCA
+         !Config Def   = 0., 2.6, 0.06, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.36, 0.36, 0.36, 0.36
+         !Config Help  =
+         !Config Units = [ngN/m^2/s]
+         CALL getin_p('EM_FACTOR_NO_WET',em_factor_no_wet)
+
+         !Config Key   = EM_FACTOR_NO_DRY
+         !Config Desc  = NOx emissions factor dry soil emissions and exponential dependancy factor 
+         !Config if    = DIFFUCO_OK_INCA
+         !Config Def   = 0., 8.60, 0.40, 0.22, 0.22, 0.22, 0.22, 0.22, 0.22, 2.65, 2.65, 2.65, 2.65
+         !Config Help  =
+         !Config Units = [ngN/m^2/s] 
+         CALL getin_p('EM_FACTOR_NO_DRY',em_factor_no_dry)
+
+         !Config Key   = LARCH
+         !Config Desc  = Larcher 1991 SAI/LAI ratio
+         !Config if    = DIFFUCO_OK_INCA 
+         !Config Def   = 0., 0.015, 0.015, 0.003, 0.005, 0.005, 0.003, 0.005, 0.003, 0.005, 0.005, 0.008, 0.008
+         !Config Help  =
+         !Config Units = [-]  
+         CALL getin_p('LARCH',Larch)
+         
+      ENDIF ! (active_flags%ok_inca)
+
+      first_call = .FALSE.
+
+   ENDIF !(first_call)
+
+ END SUBROUTINE config_sechiba_pft_parameters
+!
+!=
+!
+
+!! ================================================================================================================================
+!! SUBROUTINE   : config_stomate_pft_parameters 
+!!
+!>\BRIEF         This subroutine will read the imposed values for the stomate pft
+!! parameters. It is not called if IMPOSE_PARAM is set to NO.
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+ SUBROUTINE config_stomate_pft_parameters
+
+   IMPLICIT NONE
+   
+   !! 0. Variables and parameters declaration
+
+   !! 0.4 Local variable
+
+   LOGICAL, SAVE ::  first_call = .TRUE.   !! To keep first call trace (true/false)
+!$OMP THREADPRIVATE(first_call)
+   INTEGER(i_std)               :: ivma,ivm!! index
+
+!_ ================================================================================================================================
+
+   IF (first_call) THEN
+      
+      !
+      ! Vegetation structure
+      !
+
+      !Config Key   = SLA
+      !Config Desc  = specif leaf area 
+      !Config if    = OK_STOMATE
+      !Config Def   = 1.5E-2, 1.53E-2, 2.6E-2, 9.26E-3, 2E-2, 2.6E-2, 9.26E-3, 2.6E-2, 1.9E-2, 2.6E-2, 2.6E-2, 2.6E-2, 2.6E-2
+      !Config Help  =
+      !Config Units = [m^2/gC]
+      CALL getin_p('SLA',sla)
+
+      !Config Key   = IS_TROPICAL
+      !Config Desc  = PFT IS TROPICAL 
+      !Config if    = OK_STOMATE
+      !Config Def   = FALSE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('IS_TROPICAL',is_tropical)
+
+      !Config Key   = IS_TEMPERATE
+      !Config Desc  = PFT IS TEMPERATE 
+      !Config if    = OK_STOMATE
+      !Config Def   = FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE 
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('IS_TEMPERATE',is_temperate)
+
+      !Config Key   = IS_BOREAL
+      !Config Desc  = PFT IS BOREAL 
+      !Config if    = OK_STOMATE
+      !Config Def   = FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE 
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('IS_BOREAL',is_boreal)
+
+      !
+      ! Photosynthesis
+      !
+
+!!$      !Config Key   = TPHOTO_MIN_A
+!!$      !Config Desc  = minimum photosynthesis temperature, constant a of ax^2+bx+c (deg C), tabulated
+!!$      !Config if    = OK_STOMATE
+!!$      !Config Def   = undef,  0., 0., 0., 0., 0., 0.,  0., 0.,  0.0025, 0., 0., 0. 
+!!$      !Config Help  = a coefficient of the quadratic relationship that determines the minimal temperature 
+!!$      !Config         below which there is no more photosynthesis 
+!!$      !Config Units = [-]
+!!$      CALL getin_p('TPHOTO_MIN_A',tphoto_min_a)
+!!$
+!!$      !Config Key   = TPHOTO_MIN_B
+!!$      !Config Desc  = minimum photosynthesis temperature, constant b of ax^2+bx+c (deg C), tabulated
+!!$      !Config if    = OK_STOMATE
+!!$      !Config Def   = undef,  0.,  0., 0., 0., 0., 0., 0., 0., 0.1, 0.,0.,0.
+!!$      !Config Help  = b coefficient of the quadratic relationship that determines the minimal temperature 
+!!$      !Config         below which there is no more photosynthesis 
+!!$      !Config Units = [-]
+!!$      CALL getin_p('TPHOTO_MIN_B',tphoto_min_b)
+!!$
+!!$      !Config Key   = TPHOTO_MIN_C
+!!$      !Config Desc  = minimum photosynthesis temperature, constant c of ax^2+bx+c (deg C), tabulated
+!!$      !Config if    = OK_STOMATE
+!!$      !Config Def   = undef,  2., 2., -4., -3.,-2.,-4., -4., -4., -3.25, 13.,-5.,13.
+!!$      !Config Help  = Offset the quadratic relationship that determines the minimal temperature 
+!!$      !Config         below which there is no more photosynthesis  
+!!$      !Config Units = [-]
+!!$      CALL getin_p('TPHOTO_MIN_C',tphoto_min_c)
+!!$
+!!$      !Config Key   = TPHOTO_OPT_A
+!!$      !Config Desc  = optimum photosynthesis temperature, constant a of ax^2+bx+c (deg C), tabulated
+!!$      !Config if    = OK_STOMATE
+!!$      !Config Def   = undef, 0., 0., 0., 0., 0., 0., 0., 0., 0.0025, 0., 0., 0. 
+!!$      !Config Help  = a coefficient of the quadratic relationship that determines the optimal temperature 
+!!$      !Config         controling Vcmax/Vjmax = f(T)
+!!$      !Config Units = [-]
+!!$      CALL getin_p('TPHOTO_OPT_A',tphoto_opt_a)
+!!$
+!!$      !Config Key   = TPHOTO_OPT_B
+!!$      !Config Desc  = optimum photosynthesis temperature, constant b of ax^2+bx+c (deg C), tabulated
+!!$      !Config if    = OK_STOMATE
+!!$      !Config Def   = undef, 0., 0., 0., 0., 0., 0., 0., 0., 0.25, 0., 0., 0.  
+!!$      !Config Help  = b coefficient of the quadratic relationship that determines the optimal temperature 
+!!$      !Config         controling Vcmax/Vjmax = f(T)
+!!$      !Config Units = [-]
+!!$      CALL getin_p('TPHOTO_OPT_B',tphoto_opt_b)
+!!$
+!!$      !Config Key   = TPHOTO_OPT_C
+!!$      !Config Desc  = optimum photosynthesis temperature, constant c of ax^2+bx+c (deg C), tabulated
+!!$      !Config if    = OK_STOMATE
+!!$      !Config Def   = undef, 37., 37., 25., 32., 26., 25., 25., 25., 27.25, 36., 30., 36.
+!!$      !Config Help  = Offset the quadratic relationship that determines the optimal temperature 
+!!$      !Config         controling Vcmax/Vjmax = f(T)
+!!$      !Config Units = [-]
+!!$      CALL getin_p('TPHOTO_OPT_C',tphoto_opt_c)
+!!$
+!!$      !Config Key   = TPHOTO_MAX_A
+!!$      !Config Desc  = maximum photosynthesis temperature, constant a of ax^2+bx+c (deg C), tabulated
+!!$      !Config if    = OK_STOMATE
+!!$      !Config Def   = undef,  0., 0., 0., 0., 0., 0., 0., 0., 0.00375, 0., 0., 0.
+!!$      !Config Help  = a coefficient of the quadratic relationship that determines the maximal temperature
+!!$      !Config         beyond which there is no more photosynthesis
+!!$      !Config Units = [-]
+!!$      CALL getin_p('TPHOTO_MAX_A',tphoto_max_a)
+!!$
+!!$      !Config Key   = TPHOTO_MAX_B
+!!$      !Config Desc  = maximum photosynthesis temperature, constant b of ax^2+bx+c (deg C), tabulated
+!!$      !Config if    = OK_STOMATE
+!!$      !Config Def   = undef, 0., 0., 0., 0., 0., 0., 0., 0.,0.35, 0., 0., 0.   
+!!$      !Config Help  = b coefficient of the quadratic relationship that determines the maximal temperature
+!!$      !Config         beyond which there is no more photosynthesis
+!!$      !Config Units = [-]
+!!$      CALL getin_p('TPHOTO_MAX_B',tphoto_max_b)
+!!$
+!!$      !Config Key   = TPHOTO_MAX_C
+!!$      !Config Desc  = maximum photosynthesis temperature, constant c of ax^2+bx+c (deg C), tabulated 
+!!$      !Config if    = OK_STOMATE
+!!$      !Config Def   = undef, 55., 55.,38., 48.,38.,38., 38., 38., 41.125, 55., 45., 55.  
+!!$      !Config Help  = Offset the quadratic relationship that determines the maximal temperature
+!!$      !Config         beyond which there is no more photosynthesis
+!!$      !Config Units = [-]
+!!$      CALL getin_p('TPHOTO_MAX_C',tphoto_max_c)
+
+      !
+      ! Allocation - stomate
+      !
+      !
+      !Config Key   = S0 
+      !Config Desc  = Standard sapwood allocation 
+      !Config If    = OK_STOMATE 
+      !Config Def   = undef, .25, .25, .30, .30, .30, .30, .30, .30, .30, .30, .30, .30
+      !Config Help  = 
+      !Config Units = [-]    
+      CALL getin_p('S0',S0)
+
+      !
+      ! Respiration - stomate
+      !
+
+      !Config Key   = MAINT_RESP_SLOPE_C
+      !Config Desc  = slope of maintenance respiration coefficient (1/K), constant c of aT^2+bT+c , tabulated
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, .20, .20, .16, .16, .16, .16, .16, .16, .16, .12, .16, .12 
+      !Config Help  = Offset of the temperature quadratic function that determines the 
+      !Config         slope of the function between temperature and maintenance respiration.
+      !Config Units = [-]
+      CALL getin_p('MAINT_RESP_SLOPE_C',maint_resp_slope_c) 
+
+      !Config Key   = MAINT_RESP_SLOPE_B
+      !Config Desc  = slope of maintenance respiration coefficient (1/K), constant b of aT^2+bT+c , tabulated
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, .0, .0, .0, .0, .0, .0, .0, .0, -.00133, .0, -.00133, .0 
+      !Config Help  = b coefficient of the temperature quadratic function that determines the 
+      !Config         slope of the function between temperature and maintenance respiration.
+      !Config Units = [-]
+      CALL getin_p('MAINT_RESP_SLOPE_B',maint_resp_slope_b)
+
+      !Config Key   = MAINT_RESP_SLOPE_A
+      !Config Desc  = slope of maintenance respiration coefficient (1/K), constant a of aT^2+bT+c , tabulated
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, .0, .0, .0, .0, .0, .0, .0, .0, .0, .0, .0, .0    
+      !Config Help  = a coefficient of the temperature quadratic function that determines the 
+      !Config         slope of the function between temperature and maintenance respiration.
+      !Config Units = [-]
+      CALL getin_p('MAINT_RESP_SLOPE_A',maint_resp_slope_a)
+
+      !Config Key   = CM_ZERO_LEAF
+      !Config Desc  = maintenance respiration coefficient at 0 deg C, for leaves, tabulated
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 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
+      !Config Help  =
+      !Config Units = [g/g/day]
+      CALL getin_p('CM_ZERO_LEAF',cm_zero_leaf)
+
+      !Config Key   = CM_ZERO_SAPABOVE
+      !Config Desc  = maintenance respiration coefficient at 0 deg C,for sapwood above, tabulated
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 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
+      !Config Help  =
+      !Config Units = [g/g/day]
+      CALL getin_p('CM_ZERO_SAPABOVE',cm_zero_sapabove)
+
+      !Config Key   = CM_ZERO_SAPBELOW
+      !Config Desc  = maintenance respiration coefficient at 0 deg C, for sapwood below, tabulated
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 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 
+      !Config Help  =
+      !Config Units = [g/g/day]
+      CALL getin_p('CM_ZERO_SAPBELOW',cm_zero_sapbelow)
+
+      !Config Key   = CM_ZERO_HEARTABOVE
+      !Config Desc  = maintenance respiration coefficient at 0 deg C, for heartwood above, tabulated
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0. 
+      !Config Help  =
+      !Config Units = [g/g/day]
+      CALL getin_p('CM_ZERO_HEARTABOVE',cm_zero_heartabove)
+
+      !Config Key   = CM_ZERO_HEARTBELOW
+      !Config Desc  = maintenance respiration coefficient at 0 deg C,for heartwood below, tabulated
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0. 
+      !Config Help  =
+      !Config Units = [g/g/day] 
+      CALL getin_p('CM_ZERO_HEARTBELOW',cm_zero_heartbelow)
+
+      !Config Key   = CM_ZERO_ROOT
+      !Config Desc  = maintenance respiration coefficient at 0 deg C, for roots, tabulated
+      !Config if    = OK_STOMATE
+      !Config Def   = undef,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
+      !Config Help  =
+      !Config Units = [g/g/day] 
+      CALL getin_p('CM_ZERO_ROOT',cm_zero_root)
+
+      !Config Key   = CM_ZERO_FRUIT
+      !Config Desc  = maintenance respiration coefficient at 0 deg C, for fruits, tabulated
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 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    
+      !Config Help  =
+      !Config Units = [g/g/day] 
+      CALL getin_p('CM_ZERO_FRUIT',cm_zero_fruit)
+
+      !+++CHECK+++
+      ! Default values depend on the growth routine
+      !Config Key   = CM_ZERO_CARBRES
+      !Config Desc  = maintenance respiration coefficient at 0 deg C, for carbohydrate reserve, tabulated
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 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
+      !Config Help  =
+      !Config Units = [g/g/day] 
+      CALL getin_p('CM_ZERO_CARBRES',cm_zero_carbres)
+
+      !Config Key   = CM_ZERO_LABILE
+      !Config Desc  = Caution, depends on the allocation scheme. Maintenance respiration coefficient at 0 deg C, for the labile pool, tabulated
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 3.36E-2, 3.36E-2, 3.36E-2, 3.36E-2, 3.36E-2, 3.36E-2, 3.36E-2, 3.36E-2, 3.36E-2, 3.36E-2, 3.36E-2, 3.36E-2 
+      !Config Help  =
+      !Config Units = [g/g/day] 
+      CALL getin_p('CM_ZERO_LABILE',cm_zero_labile)
+      
+      !Config Key   = COEFF_MAINT_INIT
+      !Config Desc  = initial values for maintenance respiration coefficient, used in functional allocation at 0 deg C
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 0.022, 0.022, 0.021, 0.033, 0.033, 0.033, 0.033, 0.033, 0.033, 0.011, 0.011, 0.011
+      !Config Help  =
+      !Config Units = [g/g/day] 
+      CALL getin_p('COEFF_MAINT_INIT',coeff_maint_init)
+
+      !Config Key   = FRAC_GROWTHRESP 
+      !Config Desc  = Depends on the allocation scheme 
+      !Config if    = 
+      !Config Def   = 0.28, 0.28, 0.28, 0.28, 0.28, 0.28, 0.28, 0.28, 0.28, 0.28, 0.28, 0.28, 0.28 
+      !Config Help  = 
+      !Config Units = 
+      CALL getin_p("FRAC_GROWTHRESP",frac_growthresp)
+
+      !Config Key   = GPP_TO_LABILE 
+      !Config Desc  = Depends on the allocation scheme 
+      !Config if    = 
+      !Config Def   = 1., 3., 1., 1., 3., 1., 3., 3., 3., 3., 3., 3. 
+      !Config Help  = 
+      !Config Units = 
+      CALL getin_p("GPP_TO_LABILE",gpp_to_labile)
+
+      !
+      ! Stand structure - stomate
+      !
+
+      !Config Key   = PIPE_DENSITY 
+      !Config Desc  = 
+      !Config if    = 
+      !Config Def   = undef, 3.e5, 3.e5, 2.e5, 3.e5, 3.e5, 2.e5, 3.e5, 2.e5, 2.e5, 2.e5, 2.e5, 2.e5
+      !Config Help  = 
+      !Config Units = 
+      CALL getin_p("PIPE_DENSITY",pipe_density)
+
+      !Config Key   = PIPE_TUNE1
+      !Config Desc  = crown area = pipe_tune1. stem diameter**pipe_tune_exp_coeff (Reinicke's theory)
+      !Config If    = OK_STOMATE 
+      !Config Def   = undef, 100., 100., 100., 100., 100., 100., 100., 100., 0., 0., 0., 0. 
+      !Config Help  = 
+      !Config Units = [-]    
+      CALL getin_p('PIPE_TUNE1',pipe_tune1)
+      
+      !Config Key   = PIPE_TUNE2
+      !Config Desc  = height=pipe_tune2 * diameter**pipe_tune3
+      !Config If    = OK_STOMATE 
+      !Config Def   = undef, 40., 40., 40., 40., 40., 40., 40., 40., 0., 0., 0., 0.  
+      !Config Help  = 
+      !Config Units = [-]      
+      CALL getin_p('PIPE_TUNE2',pipe_tune2) 
+      
+      !Config Key   = PIPE_TUNE3
+      !Config Desc  = height=pipe_tune2 * diameter**pipe_tune3
+      !Config If    = OK_STOMATE 
+      !Config Def   = undef, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0., 0., 0., 0.   
+      !Config Help  = 
+      !Config Units = [-]    
+      CALL getin_p('PIPE_TUNE3',pipe_tune3)
+      
+      !Config Key   = PIPE_TUNE4
+      !Config Desc  = needed for stem diameter
+      !Config If    = OK_STOMATE 
+      !Config Def   = undef, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0., 0., 0., 0.
+      !Config Help  = 
+      !Config Units = [-]  
+      CALL getin_p('PIPE_TUNE4',pipe_tune4)
+
+      !Config Key   = TREE_FF
+      !Config Desc  = Tree form factor reducing the volume of a cylinder
+      !               to the real volume of the tree shape (including the 
+      !               branches)
+      !Config If    = OK_STOMATE 
+      !Config Def   = undef, 0.6, 0.6, 0.6, 0.6, 0.6, 0.8, 0.8, 0.8, 0., 0., 0., 0.
+      !Config Help  = 
+      !Config Units = [-]  
+      CALL getin_p('TREE_FF',tree_ff)
+      
+      !Config Key   = PIPE_K1 
+      !Config Desc  = 
+      !Config If    = OK_STOMATE 
+      !Config Def   = undef, 8.e3, 8.e3, 8.e3, 8.e3, 8.e3, 8.e3, 8.e3, 8.e3, 0., 0., 0., 0. 
+      !Config Help  = 
+      !Config Units = [-]   
+      CALL getin_p('PIPE_K1',pipe_k1)
+       
+      !Config Key   = PIPE_TUNE_EXP_COEFF 
+      !Config Desc  = pipe tune exponential coeff 
+      !Config If    = OK_STOMATE 
+      !Config Def   = undef, 1.6, 1.6, 1.6, 1.6, 1.6, 1.6, 1.6, 1.6, 0., 0., 0., 0.  
+      !Config Help  = 
+      !Config Units = [-]   
+      CALL getin_p('PIPE_TUNE_EXP_COEFF',pipe_tune_exp_coeff)
+      
+      !Config Key   = MASS_RATIO_HEART_SAP 
+      !Config Desc  = mass ratio (heartwood+sapwood)/heartwood 
+      !Config If    = OK_STOMATE 
+      !Config Def   = undef, 3., 3., 3., 3., 3., 3., 3., 3., 0., 0., 0., 0.  
+      !Config Help  = 
+      !Config Units = [-]   
+      CALL getin_p('MASS_RATIO_HEART_SAP',mass_ratio_heart_sap)
+
+      !Config Key   = LAI_TO_HEIGHT
+      !Config Desc  = Convertion factor from lai to vegetation height for grasses and crops
+      !Config if    = OK_STOMATE, OK_FUNCTIONAL_ALLOCATION
+      !Config Def   = undef, 
+      !Config Help  = undef, undef, undef, undef, undef, undef, undef, undef, undef, 0.2, 0.5, 0.2, 0.5
+      !Config Units = [m m2 m-2] 
+      CALL getin_p('LAI_TO_HEIGHT',lai_to_height)
+
+
+      !Config Key   = CANOPY_COVER
+      !Config Desc  = Test values for canopy cover
+      !Config if    = OK_STOMATE, OK_FUNCTIONAL_ALLOCATION
+      !Config Def   = undef, 0.9, 0.9, 0.7, 0.7, 0.7, 0.6, 0.5, 0.5, 0.9, 0.9, 0.9, 0.9
+      !Config Help  =
+      !Config Units = [-] 
+      CALL getin_p('CANOPY_COVER',canopy_cover)
+      
+      !
+      ! Growth - Resource limitation stomate
+      !
+      
+      !
+      ! Growth - Functional allocation stomate 
+      !
+
+      !Config Key   = CN_LEAF_PRESCRIBED
+      !Config Desc  = 
+      !Config if    = 
+      !Config Def   = undef, 29., 29., 29., 29., 29., 29., 29., 29., 29., 29., 29., 29.
+      !Config Help  = 
+      !Config Units = 
+      CALL getin_p("CN_LEAF_PRESCRIBED",cn_leaf_prescribed)
+
+      !Config Key   = FCN_WOOD
+      !Config Desc  = CN of wood for allocation, relative to leaf CN according to stich et al 2003
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, .087, .087, .087, .087, .087, .087, .087, .087, 1., 1., 1.
+      !Config Help  =
+      !Config Units = [-] 
+      CALL getin_p('FCN_WOOD',fcn_wood)  
+   
+      !Config Key   = FCN_ROOT
+      !Config Desc  = CN roots for allocation, relative to leaf CN according to stich et al 2003
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1.
+      !Config Help  =
+      !Config Units = [-] 
+      CALL getin_p('FCN_ROOT',fcn_root) 
+
+      !Config Key   = K_LATOSA_MAX
+      !Config Desc  = Maximum leaf-to-sapwood area ratio
+      !Config if    = OK_STOMATE
+      !Config Def   = (undef, 5., 5., 5., 3., 5., 5., 5., 5., undef, undef, undef, undef)*1.e3
+      !Config Help  =
+      !Config Units = [-] 
+      CALL getin_p('K_LATOSA_MAX',k_latosa_max)
+
+      !Config Key   = K_LATOSA_MIN
+      !Config Desc  = Minimum leaf-to-sapwood area ratio
+      !Config if    = OK_STOMATE
+      !Config Def   = (undef, 5., 5., 5., 3., 5., 5., 5., 5., undef, undef, undef, undef)*1.e3
+      !Config Help  =
+      !Config Units = [-] 
+      CALL getin_p('K_LATOSA_MIN',k_latosa_min) 
+
+      !Config Key   = FRUIT_ALLOC
+      !Config Desc  = Guestimates - should be confirmed
+      !Config if    = OK_STOMATE
+      !Config Def   = (undef, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0., 0., 0., 0.)
+      !Config Help  =
+      !Config Units = [-] 
+      CALL getin_p('FRUIT_ALLOC',fruit_alloc)
+
+      !Config Key   = LAI_MAX_TO_HAPPY
+      !Config Desc  = 
+      !Config If    = OK_STOMATE 
+      !Config Def   = undef, 0.5, 0.5, 0.5, 0.5, 0.4, 0.5, 0.36, 0.35, 0.35, 0.5, 0.5, 0.5 
+      !Config Help  = Multiplicative factor of lai_max that determines
+      !Config         the threshold value of LAI below which the carbohydrate
+      !Config         reserve is used.
+      !Config Units = [-]  
+      CALL getin_p('LAI_MAX_TO_HAPPY',lai_max_to_happy)
+       !
+
+
+      !Config Key   = NMAXTREES
+      !Config Desc  = number of seedlings planted at the start of a rotation
+      !Config if    = FOREST_MANAGEMENT 
+      !Config Def   = (undef, 10., 10., 10., 10., 10., 2., 2., 2., 10., 10., 10., 10.)*1.e3
+      !Config Help  = 
+      !Config Units = [trees ha-1]
+      CALL getin_p("NMAXTREES",nmaxtrees)
+
+      !Config Key   = HEIGHT_INIT_MIN
+      !Config Desc  = 
+      !Config if    = FUNCTIONAL ALLOCATION 
+      !Config Def   = undef, 2, 2, 2, 2, 2, 3, 3, 3, 3, 0.1, 0.1, 0.1, 0.1
+      !Config Help  = 
+      !Config Units = [m]
+      CALL getin_p("HEIGHT_INIT_MIN",height_init_min)
+
+      !Config Key   = HEIGHT_INIT_MAX
+      !Config Desc  = 
+      !Config if    = FUNCTIONAL ALLOCATION 
+      !Config Def   = undef, 3, 3, 3, 3, 3, 4, 4, 4, 4, 0.2, 0.2, 0.2, 0.2
+      !Config Help  = 
+      !Config Units = [m]
+      CALL getin_p("HEIGHT_INIT_MAX",height_init_max)
+
+      !Config Key   = ALPHA_SELF_THINNING
+      !Config Desc  = 
+      !Config if    = FUNCTION NMAX 
+      !Config Def   = undef, 3000, 3000, 1462, 2262, 1900, 960, 939, 1046, undef, undef, undef, undef
+      !Config Help  = 
+      !Config Units = [-]
+      CALL getin_p("ALPHA_SELF_THINNING",alpha_self_thinning)
+
+      !Config Key   = BETA_SELF_THINNING
+      !Config Desc  = 
+      !Config if    = FUNCTION NMAX 
+      !Config Def   = undef, -0.57, -0.57, -0.55, -0.61, -0.58, -0.55, -0.56, -0.56, undef, undef, undef, undef
+      !Config Help  = 
+      !Config Units = [-]
+      CALL getin_p("BETA_SELF_THINNING",beta_self_thinning)
+
+      !Config Key   = FUELWOOD_DIAMETER
+      !Config Desc  = Diameter below which harvest will be used as fuelwood
+      !Config if    = 
+      !Config Def   = undef, 0.3, 0.3, 0.2, 0.3, 0.3, 0.2, 0.2, 0.2, undef, undef, undef, undef
+      !Config Help  = 
+      !Config Units = [m]
+      CALL getin_p("FUELWOOD_DIAMETER",fuelwood_diameter)
+      
+      !Config Key   = COPPICE_KILL_BE_WOOD
+      !Config Desc  = The fraction of belowground wood killed during coppicing
+      !Config if    = 
+      !Config Def   = undef, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, undef, undef, undef, undef
+      !Config Help  = 
+      !Config Units = [m]
+      CALL getin_p("COPPICE_KBEW",coppice_kill_be_wood)
+      !
+      ! Hydraulic architecture - sechiba?
+      !
+
+      !Config Key   = K_ROOT
+      !Config Desc  = Fine root specific conductivity
+      !Config if    = OK_STOMATE
+      !Config Def   = (undef, 4., 4., 4., 4., 4., 4., 4., 4., 50., 50., 50., 50.)*1.e-7 
+      !Config Help  =
+      !Config Units = [m^{3} kg^{-1} s^{-1} MPa^{-1}] 
+      CALL getin_p('K_ROOT',k_root) 
+    
+      !Config Key   = K_SAP
+      !Config Desc  = Sapwood specific conductivity
+      !Config if    = OK_STOMATE
+      !Config Def   = (undef, 50., 10., 8., 5., 30., 8., 20., 8., undef, undef, undef, undef)*1.e-4
+      !Config Help  =
+      !Config Units = [m^{2} s^{-1} MPa^{-1}] 
+      CALL getin_p('K_SAP',k_sap)
+
+      !Config Key   = K_LEAF
+      !Config Desc  = Leaf conductivity
+      !Config if    = OK_STOMATE
+      !Config Def   = (undef, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5)*1.e-7
+      !Config Help  =
+      !Config Units = [m s^{-1} MPa^{-1})] 
+      CALL getin_p('K_LEAF',k_leaf)
+
+      !Config Key   = PHI_LEAF
+      !Config Desc  = Minimal leaf potential
+      !Config if    = OK_STOMATE, 11-LAYERS, FUNCTIONAL ALLOCATION
+      !Config Def   = undef, -2.2, -2.2, -2.2, -3.5, -2.2, -2.2, -2.2, -2.2, -2.2, -2.2, -2.2, -2.2
+      !Config Help  =
+      !Config Units = [MPa] 
+      CALL getin_p('PHI_LEAF',phi_leaf)
+
+      !Config Key   = PHI_50
+      !Config Desc  = Sapwood leaf water potential that causes 50% loss of xylem conductivity through cavitation
+      !Config if    = OK_STOMATE, 11-LAYERS, FUNCTIONAL ALLOCATION
+      !Config Def   = undef, -0.3, -1.3, -2.0, -1.7, -1.0, -2.0, -1.0, -2.0, undef, undef, undef, undef
+      !Config Help  =
+      !Config Units = [m s^{-1} MPa^{-1})] 
+      CALL getin_p('PHI_50',phi_50)      
+      
+      !Config Key   = C_CAVITATION
+      !Config Desc  = Shape parameter for loss of conductance
+      !Config if    = OK_STOMATE, 11-LAYERS, FUNCTIONAL ALLOCATION
+      !Config Def   = undef, 5., 3., 3., 3., 3., 3., 3., 3., undef, undef, undef, undef  
+      !Config Help  =
+      !Config Units = [-] 
+      CALL getin_p('C_CAVITATION',c_cavitation)
+
+      !Config Key   = PHI_SOIL_TUNE
+      !Config Desc  = Additive tuning parameter to account for soil-root interactions
+      !Config if    = OK_STOMATE, 11-LAYERS, FUNCTIONAL ALLOCATION, HYDRAOL_ARCHITECTURE
+      !Config Def   = undef, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0. 
+      !Config Help  =
+      !Config Units = [MPa] 
+      CALL getin_p('PHI_SOIL_TUNE',phi_soil_tune)
+
+      !Config Key   = LAI_HAPPY
+      !Config Desc  = The value of LAI below which carbohydrate reserves will be used. Shape parameter for loss of conductance
+      !Config if    = OK_STOMATE, FUNCTIONAL ALLOCATION
+      !Config Def   = undef, 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1.  
+      !Config Help  =
+      !Config Units = [m^{2} m^{-2}] 
+      CALL getin_p('LAI_HAPPY',lai_happy) 
+
+!--------------------------------------------------------------------------------------------------------------------------------
+      ! tzjh hydraulic architecture
+
+      !Config Key   = GPSI
+      !Config Desc  = gs vs psi_leaf curve parameter 
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, -1.2, -1.2, -1.2,-1.2, -1.2,-1.2,-1.2, -1.2,-1.2,-1.2,-1.2,-1.2   
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('GPSI',gpsi) 
+
+      !Config Key   = GPSI_50
+      !Config Desc  = psi_leaf at 50% stomatal closure 
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 2.5, 2.5, 2.5,2.5, 2.5,2.5,2.5, 2.5,2.5,2.5,2.5,2.5   
+      !Config Help  =
+      !Config Units = [-Mpa]
+      CALL getin_p('GPSI_50',gpsi_50) 
+
+      !Config Key   = GMAX
+      !Config Desc  = maximum stomatal conductance 
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 1000., 1000., 1000.,1000., 1000.,1000.,1000., 1000.,1000.,1000.,1000.,1000.   
+      !Config Help  =
+      !Config Units = [mmol m^{-2}s^{-1}]
+      CALL getin_p('GMAX',gmax) 
+      
+      !Config Key   = GMIN
+      !Config Desc  = minimum stomatal conductance 
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 10., 10., 10.,10., 10.,10.,10., 10.,10.,10.,10.,10.   
+      !Config Help  =
+      !Config Units = [mmol m^{-2}s^{-1}]
+      CALL getin_p('GMIN',gmin) 
+
+      !Config Key   = KMAX_LEAF
+      !Config Desc  = maximum hydraulic conductivity of leaf    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 10., 10., 10.,10., 10.,10.,10., 10.,10.,10.,10.,10.   
+      !Config Help  =
+      !Config Units = [mmol m^{-2}s^{-1} MPa^{-1}]
+      CALL getin_p('KMAX_LEAF',kmax_leaf) 
+
+      !Config Key   = KMAX_STEM
+      !Config Desc  = maximum hydraulic conductivity of stem
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 10., 10., 10.,10., 10.,10.,10., 10.,10.,10.,10.,10.   
+      !Config Help  =
+      !Config Units = [mmol m^{-2}s^{-1} MPa^{-1}]
+      CALL getin_p('KMAX_stem',kmax_stem) 
+
+      !Config Key   = KMAX_ROOT
+      !Config Desc  = maximum hydraulic conductivity of root    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 10., 10., 10.,10., 10.,10.,10., 10.,10.,10.,10.,10.   
+      !Config Help  =
+      !Config Units = [mmol m^{-2}s^{-1} MPa^{-1}]
+      CALL getin_p('KMAX_ROOT',kmax_root) 
+
+      !Config Key   = A_LEAF
+      !Config Desc  = kleaf vs. psi_leaf curve parameter    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, -1.2, -1.2, -1.2,-1.2, -1.2,-1.2,-1.2, -1.2,-1.2,-1.2,-1.2,-1.2   
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('A_LEAF',a_leaf) 
+
+      !Config Key   = A_STEM
+      !Config Desc  = kstem vs. psi_stem curve parameter    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, -1.2, -1.2, -1.2,-1.2, -1.2,-1.2,-1.2, -1.2,-1.2,-1.2,-1.2,-1.2   
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('A_STEM',a_stem) 
+
+      !Config Key   = A_ROOT
+      !Config Desc  = kroot vs. psi_root curve parameter    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, -1.2, -1.2, -1.2,-1.2, -1.2,-1.2,-1.2, -1.2,-1.2,-1.2,-1.2,-1.2   
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('A_ROOT',a_root) 
+
+      !Config Key   = P50_LEAF
+      !Config Desc  = psi_leaf at 50% loss of leaf hydraulic conductivity    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 2.5, 2.5, 2.5,2.5, 2.5,2.5,2.5, 2.5,2.5,2.5,2.5,2.5   
+      !Config Help  =
+      !Config Units = [-MPa]
+      CALL getin_p('P50_LEAF',P50_leaf) 
+
+      !Config Key   = P50_STEM
+      !Config Desc  = psi_stem at 50% loss of leaf hydraulic conductivity    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 2.5, 2.5, 2.5,2.5, 2.5,2.5,2.5, 2.5,2.5,2.5,2.5,2.5   
+      !Config Help  =
+      !Config Units = [-MPa]
+      CALL getin_p('P50_STEM',P50_stem) 
+
+      !Config Key   = P50_ROOT
+      !Config Desc  = psi_root at 50% loss of leaf hydraulic conductivity    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 2.5, 2.5, 2.5,2.5, 2.5,2.5,2.5, 2.5,2.5,2.5,2.5,2.5   
+      !Config Help  =
+      !Config Units = [-MPa]
+      CALL getin_p('P50_ROOT',P50_root) 
+
+      !Config Key   = WOOD_DENSITY
+      !Config Desc  = g of stem dry mass per m3 of stem volume    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 645000, 645000, 645000,645000, 645000,645000,645000, 645000,645000,645000,645000,645000   
+      !Config Help  =
+      !Config Units = [g m^{-3}]
+      CALL getin_p('WOOD_DENSITY',wood_density) 
+
+      !Config Key   = W_DENSITY_STEM
+      !Config Desc  = mmol H2O per m3 of stem volume    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 25000000, 25000000, 25000000,25000000, 25000000,25000000,25000000, 25000000,25000000,25000000,25000000,25000000   
+      !Config Help  =
+      !Config Units = [mmol m^{-3}]
+      CALL getin_p('W_DENSITY_STEM',w_density_stem) 
+
+      !Config Key   = ROOT_SHOOT_RATIO
+      !Config Desc  = ratio of root mass to shoot mass    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 0.25, 0.25, 0.25,0.25, 0.25,0.25,0.25, 0.25,0.25,0.25,0.25,0.25   
+      !Config Help  =
+      !Config Units = [g g^{-1}]
+      CALL getin_p('ROOT_SHOOT_RATIO',root_shoot_ratio) 
+
+      !Config Key   = RWC_ROOT
+      !Config Desc  = relative water content in the root    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 35, 35, 35,35, 35,35,35, 35,35,35,35,35   
+      !Config Help  =
+      !Config Units = [mmol g{-1}]
+      CALL getin_p('RWC_ROOT',rwc_root) 
+      
+      !Config Key   = ROOT_DENSITY
+      !Config Desc  = relative water content in the root    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 0.502, 0.502, 0.502,0.502, 0.502,0.502,0.502, 0.502,0.502,0.502,0.502,0.502   
+      !Config Help  =
+      !Config Units = [g cm{-3}]
+      CALL getin_p('ROOT_DENSITY',root_density) 
+
+      !Config Key   = LDMC
+      !Config Desc  = leaf dry matter content    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 0.2, 0.2, 0.2,0.2, 0.2,0.2,0.2, 0.2,0.2,0.2,0.2,0.2   
+      !Config Help  =
+      !Config Units = [g g{-1}]
+      CALL getin_p('LDMC',LDMC) 
+   
+      !Config Key   = SLA_HYDRO
+      !Config Desc  = specific leaf area for use in the hydraulic architecture    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 16.6, 16.6, 16.6,16.6, 16.6,16.6,16.6, 16.6,16.6,16.6,16.6,16.6   
+      !Config Help  =
+      !Config Units = [m^{2} g{-1}]
+      CALL getin_p('SLA_HYDRO',sla_hydro) 
+
+      !Config Key   = CXYL
+      !Config Desc  = stem capacitance    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 0.5, 0.5, 0.5,0.5, 0.5,0.5,0.5, 0.5,0.5,0.5,0.5,0.5   
+      !Config Help  =
+      !Config Units = [mmol mmol^{-1} MPa^{-1}]
+      CALL getin_p('CXYL',cxyl) 
+
+      !Config Key   = CR
+      !Config Desc  = root capacitance    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 0.5, 0.5, 0.5,0.5, 0.5,0.5,0.5, 0.5,0.5,0.5,0.5,0.5   
+      !Config Help  =
+      !Config Units = [mmol mmol^{-1} MPa^{-1}]
+      CALL getin_p('CR',cr) 
+
+      !Config Key   = CL
+      !Config Desc  = leaf capacitance    
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, 0.1, 0.1, 0.1,0.1, 0.1,0.1,0.1, 0.1,0.1,0.1,0.1,0.1   
+      !Config Help  =
+      !Config Units = [mmol mmol^{-1} MPa^{-1}]
+      CALL getin_p('CL',cl) 
+!-----------------------------------------------------------------------------------------------------------------
+
+!
+      ! Mortality - lpj_gap
+      !
+      !Config Key   = DEATH_DISTRIBUTION_FACTOR
+      !Config Desc  = Shape parameter for tree mortality
+      !Config if    = OK_STOMATE, FUNCTIONAL ALLOCATION
+      !Config Def   = undef, 100., 100., 100., 100., 100., 100., 100., 100., undef, undef, undef, undef  
+      !Config Help  =
+      !Config Units = [-] 
+      CALL getin_p('DEATH_DF',death_distribution_factor) 
+
+      !Config Key   = NPP_RESET_VALUE
+      !Config Desc  = The value longterm NPP is reset to after a non-tree stand dies. 
+      !Config if    = OK_STOMATE, FUNCTIONAL ALLOCATION
+      !Config Def   = undef, undef, undef, undef, undef, undef, undef, undef, undef, 500., 500., 500., 500.  
+      !Config Help  =
+      !Config Units = [-]       CALL getin_p('NPP_RESET_VALUE',npp_reset_value) 
+
+      
+      ! Fire - stomate
+      !
+
+      !Config Key   = FLAM
+      !Config Desc  = flamability: critical fraction of water holding capacity
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, .15, .25, .25, .25, .25, .25, .25, .25, .25, .25, .35, .35
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('FLAM',flam)
+
+      !Config Key   = RESIST
+      !Config Desc  = fire resistance
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, .95, .90, .12, .50, .12, .12, .12, .12, .0, .0, .0, .0 
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('RESIST',resist)
+     
+      !
+      ! Flux - LUC
+      !
+
+      !Config Key   = COEFF_LCCHANGE_s
+      !Config Desc  = Coeff of biomass export for the year
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 0.897, 0.897, 0.597, 0.597, 0.597, 0.597, 0.597, 0.597, 0.597, 0.597, 0.597, 0.597 
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('COEFF_LCCHANGE_s',coeff_lcchange_s)
+
+      !Config Key   = COEFF_LCCHANGE_m
+      !Config Desc  = Coeff of biomass export for the decade
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 0.103, 0.103, 0.299, 0.299, 0.299, 0.299, 0.299, 0.299, 0.299, 0.403, 0.299, 0.403
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('COEFF_LCCHANGE_m',coeff_lcchange_m)
+
+      !Config Key   = COEFF_LCCHANGE_l
+      !Config Desc  = Coeff of biomass export for the century
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 0., 0., 0.104, 0.104, 0.104, 0.104, 0.104, 0.104, 0.104, 0., 0.104, 0.
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('COEFF_LCCHANGE_l',coeff_lcchange_l)
+      
+      !
+      ! Phenology
+      !
+
+      !Config Key   = LAI_MAX
+      !Config Desc  = maximum LAI, PFT-specific
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 7., 7., 5., 5., 5., 4.5, 4.5, 3.0, 2.5, 2.5, 5.,5. 
+      !Config Help  =
+      !Config Units = [m^2/m^2]
+      CALL getin_p('LAI_MAX',lai_max)
+
+      !Config Key   = PHENO_TYPE
+      !Config Desc  = type of phenology, 0=bare ground 1=evergreen,  2=summergreen,  3=raingreen,  4=perennial
+      !Config if    = OK_STOMATE
+      !Config Def   = 0, 1, 3, 1, 1, 2, 1, 2, 2, 4, 4, 2, 3
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('PHENO_TYPE',pheno_type)
+
+      !
+      ! Phenology : Leaf Onset
+      !
+
+      !Config Key   = PHENO_GDD_CRIT_C
+      !Config Desc  = critical gdd, tabulated (C), constant c of aT^2+bT+c
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, undef, undef, undef, undef, undef, undef, undef, 270., 400., 125., 400.
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('PHENO_GDD_CRIT_C',pheno_gdd_crit_c)
+
+      !Config Key   = PHENO_GDD_CRIT_B
+      !Config Desc  = critical gdd, tabulated (C), constant b of aT^2+bT+c
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, undef, undef, undef, undef, undef,undef, undef, 6.25, 0., 0., 0.
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('PHENO_GDD_CRIT_B',pheno_gdd_crit_b)
+
+      !Config Key   = PHENO_GDD_CRIT_A
+      !Config Desc  = critical gdd, tabulated (C), constant a of aT^2+bT+c
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, undef, undef, undef, undef, undef, undef, undef, 0.03125,  0., 0., 0.
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('PHENO_GDD_CRIT_A',pheno_gdd_crit_a)
+
+      !Config Key   = NGD_CRIT
+      !Config Desc  = critical ngd, tabulated. Threshold -5 degrees
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, undef, undef, undef, undef, undef, 0., undef, undef, undef, undef, undef
+      !Config Help  = NGD : Number of Growing Days.
+      !Config Units = [days]
+      CALL getin_p('NGD_CRIT',ngd_crit)
+
+
+      !Config Key   = OPTI_KPHENO_CRIT
+      !Config Desc  = multiplicative factor to optimize gdd_crit
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, undef, undef, undef, 1.13, undef, 0.87, 1.08, 0.81, undef, undef, undef
+      !Config Help  = 
+      !Config Units = [-]
+      CALL getin_p('OPTI_KPHENO_CRIT',opti_kpheno_crit)
+
+
+      !Config Key   = NCDGDD_TEMP
+      !Config Desc  = critical temperature for the ncd vs. gdd function in phenology
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, undef, undef, undef, 5., undef, 0., undef, undef, undef, undef, undef
+      !Config Help  =
+      !Config Units = [C] 
+      CALL getin_p('NCDGDD_TEMP',ncdgdd_temp)
+
+      !Config Key   = HUM_FRAC
+      !Config Desc  = critical humidity (relative to min/max) for phenology
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, .5, undef, undef, undef, undef, undef,  undef, .5, .5, .5,.5     
+      !Config Help  =
+      !Config Units = [%]
+      CALL getin_p('HUM_FRAC',hum_frac)
+
+      !Config Key   = HUM_MIN_TIME
+      !Config Desc  = minimum time elapsed since moisture minimum
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, 50., undef, undef, undef, undef, undef, undef, 35., 35., 75., 75.
+      !Config Help  =
+      !Config Units = [days]
+      CALL getin_p('HUM_MIN_TIME',hum_min_time)
+
+      !Config Key   = TAU_SAP
+      !Config Desc  = sapwood longivety (sapwood -> heartwood conversion time)
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 730., 730., 730., 730., 730., 730., 730., 730., undef, undef, undef, undef
+      !Config Help  =
+      !Config Units = [days]
+      CALL getin_p('TAU_SAP',tau_sap)
+
+      !Config Key   = TAU_FRUIT
+      !Config Desc  = fruit longivety
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 90., 90., 90., 90., 90., 90., 90., 90., undef, undef, undef, undef
+      !Config Help  =
+      !Config Units = [days]
+      CALL getin_p('TAU_FRUIT',tau_fruit)
+
+      !Config Key   = TAU_ROOT
+      !Config Desc  = root longivety
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 256., 256., 256., 256., 256., 256., 256., 256., 256., 256., 256., 256.
+      !Config Help  =
+      !Config Units = [days]
+      CALL getin_p('TAU_ROOT',tau_root)
+
+      !Config Key   = TAU_LEAF
+      !Config Desc  = leaf longivety
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 730., 180., 910., 730., 180., 910., 180., 180., 120., 120., 90., 90. 
+      !Config Help  =
+      !Config Units = [days]
+      CALL getin_p('TAU_LEAF',tau_leaf)
+  
+      !Config Key   = ECUREUIL
+      !Config Desc  = fraction of primary leaf and root allocation put into reserve
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, .0, 1., .0, .0, 1., .0, 1., 1., 1., 1., 1., 1.
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('ECUREUIL',ecureuil)
+
+      !Config Key   = ALLOC_MIN
+      !Config Desc  = minimum allocation above/below = f(age) - 30/01/04 NV/JO/PF
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, undef, undef, undef, undef 
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('ALLOC_MIN',alloc_min)
+
+      !Config Key   = ALLOC_MAX
+      !Config Desc  = maximum allocation above/below = f(age) - 30/01/04 NV/JO/PF
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, undef, undef, undef, undef
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('ALLOC_MAX',alloc_max)
+
+      !Config Key   = DEMI_ALLOC 
+      !Config Desc  = mean allocation above/below = f(age) - 30/01/04 NV/JO/PF
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, 5., 5., 5., 5., 5., 5., 5., 5., undef, undef, undef, undef
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('DEMI_ALLOC',demi_alloc)
+
+      !
+      ! Phenology : Senescence
+      !
+      !
+      !Config Key   = LEAFFALL
+      !Config Desc  = length of death of leaves, tabulated 
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, 10., undef, undef, 10., undef, 10., 10., 10., 10., 10., 10. 
+      !Config Help  =
+      !Config Units = [days]
+      CALL getin_p('LEAFFALL',leaffall)
+
+      !Config Key   = SENESCENCE_TYPE
+      !Config Desc  = type of senescence, tabulated
+      !Config if    = OK_STOMATE
+      !Config Def   = none, none, dry, none, none, cold, none, cold, cold, mixed, mixed, mixed, mixed 
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('SENESCENCE_TYPE',senescence_type) 
+
+      !Config Key   = SENESCENCE_HUM
+      !Config Desc  = critical relative moisture availability for senescence
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, .3, undef, undef, undef, undef, undef, undef, .2, .2, .3, .2 
+      !Config Help  =
+      !Config Units = [-] 
+      CALL getin_p('SENESCENCE_HUM',senescence_hum)
+
+      !Config Key   = NOSENESCENCE_HUM
+      !Config Desc  = relative moisture availability above which there is no humidity-related senescence
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, .8, undef, undef, undef, undef, undef, undef, .3, .3, .3, .3 
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('NOSENESCENCE_HUM',nosenescence_hum) 
+
+      !Config Key   = MAX_TURNOVER_TIME
+      !Config Desc  = maximum turnover time for grasse
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, undef, undef, undef, undef, undef, undef, undef,  80.,  80., 80., 80. 
+      !Config Help  =
+      !Config Units = [days]
+      CALL getin_p('MAX_TURNOVER_TIME',max_turnover_time)
+
+      !Config Key   = MIN_TURNOVER_TIME
+      !Config Desc  = minimum turnover time for grasse 
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, undef, undef, undef, undef, undef, undef, undef, 10., 10., 10., 10. 
+      !Config Help  =
+      !Config Units = [days]
+      CALL getin_p('MIN_TURNOVER_TIME',min_turnover_time)
+
+      !Config Key   = MIN_LEAF_AGE_FOR_SENESCENCE
+      !Config Desc  = minimum leaf age to allow senescence g
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, 90., undef, undef, 90., undef, 60., 60., 30., 30., 30., 30.
+      !Config Help  =
+      !Config Units = [days] 
+      CALL getin_p('MIN_LEAF_AGE_FOR_SENESCENCE',min_leaf_age_for_senescence)
+
+      !Config Key   = SENESCENCE_TEMP_C
+      !Config Desc  = critical temperature for senescence (C), constant c of aT^2+bT+c, tabulated
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, undef, undef, undef, 12., undef, 7., 2., -1.375, 5., 5., 10.
+      !Config Help  = Offset the quadratic relationship that determines the threshold temperature
+      !Config         below which senescence occurs
+      !Config Units = [-]
+      CALL getin_p('SENESCENCE_TEMP_C',senescence_temp_c)
+
+      !Config Key   = SENESCENCE_TEMP_B
+      !Config Desc  = critical temperature for senescence (C), constant b of aT^2+bT+c ,tabulated
+      !Config if    = OK_STOMATE 
+      !Config Def   = undef, undef, undef, undef, undef, 0., undef, 0., 0., .1, 0., 0., 0.
+      !Config Help  =
+      !Config Units = [-]
+      CALL getin_p('SENESCENCE_TEMP_B',senescence_temp_b)
+
+      !Config Key   = SENESCENCE_TEMP_A
+      !Config Desc  = critical temperature for senescence (C), constant a of aT^2+bT+c , tabulated
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, undef, undef, undef, 0., undef, 0., 0.,.00375, 0., 0., 0. 
+      !Config Help  =
+      !Config Units = [-] 
+      CALL getin_p('SENESCENCE_TEMP_A',senescence_temp_a)
+
+      !Config Key   = GDD_SENESCENCE
+      !Config Desc  = minimum gdd to allow senescence of crops  
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, undef, undef, undef, undef, undef, undef, undef, undef, undef, 950., 4000.
+      !Config Help  =
+      !Config Units = [days] 
+      CALL getin_p("GDD_SENESCENCE", gdd_senescence)
+
+
+      !
+      ! CROPLAND MANAGEMENT
+      !
+      !Config Key   = HARVEST_RATIO
+      !Config Desc  = Share of biomass that is harvested. This residual = 1 - harvest_ratio  
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, undef, undef, undef, undef, undef, undef, undef, undef, undef, 0.5, 0.5
+      !Config Help  =
+      !Config Units = [unitless] 
+      CALL getin_p("HARVEST_RATIO", harvest_ratio)
+
+      !
+      ! DGVM
+      !
+
+      !Config Key   = RESIDENCE_TIME
+      !Config Desc  = residence time of trees
+      !Config if    = OK_DGVM and NOT(LPJ_GAP_CONST_MORT)
+      !Config Def   = undef, 30.0, 30.0, 40.0, 40.0, 40.0, 80.0, 80.0, 80.0, 0.0, 0.0, 0.0, 0.0 
+      !Config Help  =
+      !Config Units = [years]
+      CALL getin_p('RESIDENCE_TIME',residence_time)
+
+
+      ! added by yitong yao 07 Jan 2020 08:26 
+      !Config Key   = PLC_KILL_FRAC
+      !Config Desc  = fraction of killed trees due to plc >50
+      !Config if 
+      !Config Def   = undef, 0.01,0.01,0.01,0.01,0.01,0.01,0.01,...
+      !Config Help  =
+      !Config Units =[years]
+      CALL getin_p('PLC_KILL_FRAC',plc_kill_frac)  
+
+      ! added by yitong yao 07 Jan 2020 08:27 
+      CALL getin_p('MOR_KILL_FRAC',mor_kill_frac)
+
+
+      !Config Key   = TMIN_CRIT
+      !Config Desc  = critical tmin, tabulated
+      !Config if    = OK_STOMATE
+      !Config Def   = undef,  0.0, 0.0, -30.0, -14.0, -30.0, -45.0, -45.0, undef, undef, undef, undef, undef
+      !Config Help  = 
+      !Config Units = [C]
+      CALL getin_p('TMIN_CRIT',tmin_crit)
+
+      !Config Key   = TCM_CRIT
+      !Config Desc  = critical tcm, tabulated 
+      !Config if    = OK_STOMATE
+      !Config Def   = undef, undef, undef, 5.0, 15.5, 15.5, -8.0, -8.0, -8.0, undef, undef, undef, undef
+      !Config Help  =
+      !Config Units = [C]
+      CALL getin_p('TCM_CRIT',tcm_crit)
+
+      !Config Key   = MORTALITY_MIN
+      !Config Desc  = Asymptotic mortality 
+      !Config if    = OK_STOMATE, functional allocation, lpj_const_mort
+      !Config Def   = undef, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01
+      !Config Help  =
+      !Config Units = [year-1]
+      CALL getin_p('MORTALITY_MIN',mortality_min)
+
+      !Config Key   = MORTALITY_MAX
+      !Config Desc  = Maximum mortality, tabulated 
+      !Config if    = OK_STOMATE, functional allocation + lpj_const_mort
+      !Config Def   = undef, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1
+      !Config Help  =
+      !Config Units = [year-1]
+      CALL getin_p('MORTALITY_MIN',mortality_min)
+
+      !Config Key   = REF_MORTALITY
+      !Config Desc  = Reference mortality, tabulated 
+      !Config if    = OK_STOMATE, functional allocation + lpj_const_mort
+      !Config Def   = undef, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035
+      !Config Help  =
+      !Config Units = [year-1]
+      CALL getin_p('REF_MORTALITY',ref_mortality)
+      
+      !Config Key   = TAU_HUM_GROWINGSEASON
+      !Config Desc  = time integral for waterstress on KF (allocation)
+      !Config if    = OK_STOMATE, functional allocation 
+      !Config Def   = undef, tau_sap, tau_sap, tau_sap, tau_sap, tau_sap, tau_sap, tau_sap, tau_sap, tau_hum_growingseason_grass, 
+      !                tau_hum_growingseason_grass, tau_hum_growingseason_grass, tau_hum_growingseason_grass  
+      !Config Help  =
+      !Config Units = [days]
+      CALL getin_p('TAU_HUM_GROWINGSEASON',tau_hum_growingseason)
+
+      !Config Key   = DENS_TARGET
+      !Config Desc  = 
+      !Config if    = OK_STOMATE, functional allocation
+      !Config Def   = 0.0, 100.0, 100.0, 200.0, 100.0, 100.0, 200.0, 100.0, 200.0, 0.0, 0.0, 0.0, 0.0
+      !Config Help  = 
+      !Config Units = 
+      CALL getin_p("DENS_TARGET",dens_target)
+
+      ! Age classes
+      ! I want to create a temporary array that indicates which "real" PFT starts
+      ! on which index.  This could probably be put somewhere else, but this
+      ! routine is only called once a year and this loop is not expensive.
+      start_index(:)=-1
+      nagec_pft(:)=-1
+      DO ivma=1,nvmap
+         ! The start index is just the first place we find this real PFT.
+         DO ivm=1,nvm
+            IF(agec_group(ivm) .EQ. ivma)THEN
+               start_index(ivma)=ivm
+               ! It is possible that not all forests will have multiple age classes.  For example,
+               ! the species might have age classes but metaclasses (running outside Europe) might not.
+               ! Let's check to see how many age classes each PFT has.  Right now, the only options
+               ! are 1 or nagec, but this could be changed without too much difficulty.
+               WRITE(numout,*) 'jifoez ',nagec,ivm,ivm+nagec-1
+               IF((ivm+nagec-1) .LT. nvm)THEN
+                  ! This first if loop prevents an out of bounds error
+                  IF(agec_group(ivm+nagec-1) == ivma)THEN
+                     nagec_pft(ivma)=nagec
+                  ELSE
+                     nagec_pft(ivma)=1
+                  ENDIF
+               ELSE
+                  nagec_pft(ivma)=1
+               ENDIF
+               EXIT
+            ENDIF
+         ENDDO
+      ENDDO
+      ! Check to see if the calculation worked and we found indices for all of them.
+      DO ivma=1,nvmap
+         IF(start_index(ivma) .LT. 0)THEN
+            WRITE(numout,*) 'Could not find a start index for one age class group!'
+            WRITE(numout,*) 'Check the input file to make sure the following ivma appears in agec_group'
+            WRITE(numout,*) 'ivma,nvmap',ivma,nvmap
+            WRITE(numout,*) 'agec_group',agec_group(:)
+            CALL ipslerr_p (3,'pft_parameters','pft_parameters_alloc','','')
+         ENDIF
+      ENDDO
+
+      first_call = .FALSE.
+       
+   ENDIF !(first_call)
+  
+ END SUBROUTINE config_stomate_pft_parameters
+!
+!=
+!
+!! ================================================================================================================================
+!! SUBROUTINE   : config_forest_management_parameters
+!!
+!>\BRIEF         This subroutine will read the imposed values for the forest management
+!! parameters. It is not called if IMPOSE_PARAM is set to NO.
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+ SUBROUTINE config_forest_manage_pft_parameters
+
+   IMPLICIT NONE
+   
+   !! 0. Variables and parameters declaration
+
+   !! 0.4 Local variable
+
+   LOGICAL, SAVE ::  first_call = .TRUE.   !! To keep first call trace (true/false)
+!$OMP THREADPRIVATE(first_call)
+   REAL(r_std)   :: ss_dens_init           !! Sensitivity parameter for dens_init  
+   REAL(r_std)   :: ss_branch_ratio        !! Sensitivity parameter for branch_ratio
+ 
+!_ ================================================================================================================================
+
+   !Config Key   = PLANTATION
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT
+   !Config Def   = n, n, n, n, n, n, n, n, n, n, n, n, n
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("PLANTATION",plantation)
+
+   !Config Key   = FM_ALLO_A
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = undef, 19.42, 19.42, 9.3, 19.42, 19.42, 9.3, 0.11, 0.35, undef, undef, undef, undef 
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("FM_ALLO_A",fm_allo_a)
+
+   !Config Key   = FM_ALLO_C 
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT
+   !Config Def   = undef, 0.11, 0.11, 0.35, 0.11, 0.11, 0.35, 0.11, 0.35, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("FM_ALLO_C",fm_allo_c)  
+
+   !Config Key   = FM_ALLO_D 
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = undef, 0.13, 0.13, 0.3, 0.13, 0.13, 0.3, 0.13, 0.3, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("FM_ALLO_D",fm_allo_d) 
+ 
+   !Config Key   = FM_ALLO_P
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = undef, 0.75, 0.75, 0.69, 0.75, 0.75, 0.69, 0.75, 0.69, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("FM_ALLO_P",fm_allo_p)
+
+   !Config Key   = FM_ALLO_Q
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT
+   !Config Def   = undef, -0.12, -0.12, -0.32, -0.12, -0.12, -0.32, -0.12, -0.32, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("FM_ALLO_Q",fm_allo_q)
+
+   !Config Key   = ALLO_CROWN_A0
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = undef, -0.7602, -0.7602, -1.019, -0.7602, -0.7602, -1.019, -0.7602, -1.019, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("ALLO_CROWN_A0",allo_crown_a0)
+
+   !Config Key   = ALLO_CROWN_A1
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = undef, 0.6672, 0.6672, 0.887, 0.6672, 0.6672, 0.887, 0.6672, 0.887, undef, undef, undef, undef 
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("ALLO_CROWN_A1",allo_crown_a1)
+
+   !Config Key   = ALLO_CROWN_A2
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = undef, 0.12646, 0.12646, 0.188, 0.12646, 0.12646, 0.188, 0.12646, 0.188, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("ALLO_CROWN_A2",allo_crown_a2)
+
+   !Config Key   = H_FIRST
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT
+   !Config Def   = 0.0, 10.0, 10.0, 10.0, 10.0, 10.0, 10.0, 10.0, 10.0, 0.0, 0.0, 0.0, 0.0   
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("H_FIRST",h_first)
+
+   !Config Key   = RECRUITMENT_LIGHT_THRESHOLD
+   !Config Desc  = 
+   !Config if    = 
+   !Config Def   = undef, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("RECRUITMENT_LIGHT_THRESHOLD",recruitment_light_threshold)
+  
+   !Config Key   = DIA_RECR
+   !Config Desc  = 
+   !Config if    = 
+   !Config Def   = undef, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("DIA_RECR",dia_recr)
+   
+   !Config Key   = HEI_RECR
+   !Config Desc  = 
+   !Config if    = 
+   !Config Def   = undef, 1.8, 1.8, 1.8, 1.8, 1.8, 1.8, 1.8, 1.8, 1.8, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("HEI_RECR",hei_recr)
+
+   
+   ! Sensitivity analysis
+   !
+   !Config Key   = SS_DENS_INIT
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = 1.
+   !Config Help  = 
+   !Config Units = 
+   ss_dens_init = 1.
+   CALL getin_p("SS_DENS_INIT",ss_dens_init)
+
+   !! Readjust nmaxtrees values according ss_dens_init value
+   IF (nmaxtrees(1) >= 10) THEN
+      nmaxtrees(:) = nmaxtrees(1)*ss_dens_init
+   ENDIF
+  
+   !Config Key   = LARGEST_TREE_DIA
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = 0.0, 45.0, 45.0, 45.0, 45.0, 45.0, 45.0, 45.0, 45.0, 0.0, 0.0, 0.0, 0.0
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("LARGEST_TREE_DIA",largest_tree_dia)
+
+   !Config Key   = THINSTRAT
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = 0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("THINSTRAT",thinstrat)
+
+   !Config Key   = TAUMIN
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = 0.0, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.0, 0.0, 0.0, 0.0
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("TAUMIN",taumin)
+
+   !Config Key   = TAUMAX
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = 0.0, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.0, 0.0, 0.0, 0.0
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("TAUMAX",taumax)
+
+   !Config Key   = ALPHA_RDI_UPPER
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = undef, 3000, 3000, 592, 862, 504, 1287, 984, 589, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("ALPHA_RDI_UPPER",alpha_rdi_upper)
+
+   !Config Key   = BETA_RDI_UPPER
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   =  undef, -0.57, -0.57, -0.46, -0.51, -0.44, -0.59, -0.57, -0.48, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("BETA_RDI_UPPER",beta_rdi_upper)
+   
+   !Config Key   = ALPHA_RDI_LOWER
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = undef, 2999, 2999, 433, 445, 369, 1022, 828, 385, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("ALPHA_RDI_LOWER",alpha_rdi_lower)
+
+   !Config Key   = BETA_RDI_LOWER
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   =  undef, -0.57, -0.57, -0.46, -0.51, -0.44, -0.59, -0.57, -0.48, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("BETA_RDI_LOWER",beta_rdi_lower)
+
+   !Config Key   = BRANCH_RATIO
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = 0.0, 0.38, 0.38, 0.25, 0.38, 0.38, 0.25, 0.38, 0.25, 0.0, 0.0, 0.0, 0.0  
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("BRANCH_RATIO",branch_ratio)
+
+   !Config Key   = BRANCH_HARVEST
+   !Config Desc  = The fraction of branches which are harvested during FM2 (the rest are left onsite)
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = 0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0  
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("BRANCH_HARVEST",branch_harvest)
+
+   ! Sensitivity parameter
+   !
+   !Config Key   = SS_BRANCH_RATIO
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = 
+   !Config Help  = 
+   !Config Units = 
+   ss_branch_ratio = 1.
+   CALL getin_p("SS_BRANCH_RATIO",ss_branch_ratio)
+
+   !! Readjust branch_ratio values 
+   branch_ratio(:) = ss_branch_ratio * branch_ratio(:)
+
+   !Config Key   = DECL_FACTOR
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = 0.0, 0.0005, 0.0005, 0.0007, 0.0005, 0.0005, 0.0009, 0.00075, 0.0005, 1.0, 1.0, 1.0, 1.0 
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("DECL_FACTOR",decl_factor)
+
+   !Config Key   = OPT_FACTOR
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0
+   !Config Help  = 
+   !Config Units = 
+   !CALL getin_p("OPT_FACTOR",opt_factor)
+
+   !Config Key   = COPPICE_DIAMETER
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = undef, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("COPPICE_DIAMETER",coppice_diameter)
+
+   !Config Key   = SHOOTS_PER_STOOL
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = undef, 6, 6, 6, 6, 6, 6, 6, 6, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("SHOOTS_PER_STOOL",shoots_per_stool)
+
+   !Config Key   = SRC_ROT_LENGTH
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = undef, 3, 3, 3, 3, 3, 3, 3, 3, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("SRC_ROT_LENGTH",src_rot_length)
+
+   !Config Key   = SRC_NROTS
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = undef, 10, 10, 10, 10, 10, 10, 10, 10, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("SRC_NROTS",src_nrots)
+
+   !Config Key   = M_DV
+   !Config Desc  = 
+   !Config if    = FOREST_MANAGEMENT 
+   !Config Def   = undef, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("M_DV",m_dv)
+
+   !Config Key   = DELEUZE_A
+   !Config Desc  = intercept of the intra-tree competition within a stand
+   !               based on the competion rule of Deleuze and Dhote 2004
+   !               Used when n_circ > 6
+   !Config if    = OK_STOMATE, functional allocation 
+   !Config Def   = undef, 0.23, 0.23, 0.23, 0.23, 0.23, 0.23, 0.23, 0.23, 0.23, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("DELEUZE_A",deleuze_a)
+
+   !Config Key   = DELEUZE_B
+   !Config Desc  = slope of the intra-tree competition within a stand
+   !               based on the competion rule of Deleuze and Dhote 2004
+   !               Used when n_circ > 6
+   !Config if    = OK_STOMATE, functional allocation  
+   !Config Def   = undef, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("DELEUZE_B",deleuze_b)
+
+   !Config Key   = DELEUZE_P_ALL
+   !Config Desc  = Percentile of the circumferences that receives photosynthates
+   !               based on the competion rule of Deleuze and Dhote 2004
+   !               Used when n_circ < 6 for FM 1, FM2 and FM4
+   !Config if    = OK_STOMATE, functional allocation  
+   !Config Def   = undef, 0.5, 0.5, 0.99, 0.99, 0.99, 0.99, 0.99, 0.99, 0.99, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("DELEUZE_P_ALL",deleuze_p_all)
+
+   !Config Key   = DELEUZE_P_COPPICE
+   !Config Desc  = Percentile of the circumferences that receives photosynthates
+   !               based on the competion rule of Deleuze and Dhote 2004
+   !               Used when n_circ < 6 for FM3
+   !Config if    = OK_STOMATE, functional allocation  
+   !Config Def   = undef, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, undef, undef, undef, undef
+   !Config Help  = 
+   !Config Units = 
+   CALL getin_p("DELEUZE_P_COPPICE",deleuze_p_coppice)
+
+ END SUBROUTINE config_forest_manage_pft_parameters
+
+!! ================================================================================================================================
+!! SUBROUTINE   : pft_parameters_clear
+!!
+!>\BRIEF         This subroutine deallocates memory at the end of the simulation. 
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+ SUBROUTINE pft_parameters_clear
+   
+   l_first_pft_parameters = .TRUE.
+   
+   IF (ALLOCATED(pft_to_mtc)) DEALLOCATE(pft_to_mtc)
+   IF (ALLOCATED(PFT_name)) DEALLOCATE(PFT_name)
+   IF (ALLOCATED(veget_ori_fixed_test_1)) DEALLOCATE(veget_ori_fixed_test_1)   
+   IF (ALLOCATED(llaimax)) DEALLOCATE(llaimax)
+   IF (ALLOCATED(llaimin)) DEALLOCATE(llaimin)
+   IF (ALLOCATED(height_presc)) DEALLOCATE(height_presc)   
+   IF (ALLOCATED(type_of_lai)) DEALLOCATE(type_of_lai)
+   IF (ALLOCATED(is_tree)) DEALLOCATE(is_tree)
+   IF (ALLOCATED(natural)) DEALLOCATE(natural)
+   IF (ALLOCATED(is_deciduous)) DEALLOCATE(is_deciduous)
+    IF (ALLOCATED(is_tropical)) DEALLOCATE(is_tropical)
+   IF (ALLOCATED(is_temperate)) DEALLOCATE(is_temperate)
+   IF (ALLOCATED(is_boreal)) DEALLOCATE(is_boreal)
+   IF (ALLOCATED(is_evergreen)) DEALLOCATE(is_evergreen)
+   IF (ALLOCATED(is_needleleaf)) DEALLOCATE(is_needleleaf)
+   IF (ALLOCATED(is_tropical)) DEALLOCATE(is_tropical)
+   IF (ALLOCATED(humcste)) DEALLOCATE(humcste)
+   IF (ALLOCATED(pref_soil_veg)) DEALLOCATE(pref_soil_veg)
+   IF (ALLOCATED(agec_group)) DEALLOCATE(agec_group)
+   IF (ALLOCATED(start_index)) DEALLOCATE(start_index)
+   IF (ALLOCATED(nagec_pft)) DEALLOCATE(nagec_pft)
+   IF (ALLOCATED(is_c4)) DEALLOCATE(is_c4)  
+   IF (ALLOCATED(vcmax_fix)) DEALLOCATE(vcmax_fix)
+   IF (ALLOCATED(E_KmC)) DEALLOCATE(E_KmC)
+   IF (ALLOCATED(E_KmO)) DEALLOCATE(E_KmO)
+   IF (ALLOCATED(E_gamma_star)) DEALLOCATE(E_gamma_star)
+   IF (ALLOCATED(E_Vcmax)) DEALLOCATE(E_Vcmax)
+   IF (ALLOCATED(E_Jmax)) DEALLOCATE(E_Jmax)
+   IF (ALLOCATED(aSV)) DEALLOCATE(aSV)
+   IF (ALLOCATED(bSV)) DEALLOCATE(bSV)
+   IF (ALLOCATED(tphoto_min)) DEALLOCATE(tphoto_min)
+   IF (ALLOCATED(tphoto_max)) DEALLOCATE(tphoto_max)
+   IF (ALLOCATED(aSJ)) DEALLOCATE(aSJ)
+   IF (ALLOCATED(bSJ)) DEALLOCATE(bSJ)
+   IF (ALLOCATED(D_Vcmax)) DEALLOCATE(D_Vcmax)
+   IF (ALLOCATED(D_Jmax)) DEALLOCATE(D_Jmax)
+   IF (ALLOCATED(E_Rd)) DEALLOCATE(E_Rd)
+   IF (ALLOCATED(Vcmax25)) DEALLOCATE(Vcmax25)
+   IF (ALLOCATED(arJV)) DEALLOCATE(arJV)
+   IF (ALLOCATED(brJV)) DEALLOCATE(brJV)
+   IF (ALLOCATED(KmC25)) DEALLOCATE(KmC25)
+   IF (ALLOCATED(KmO25)) DEALLOCATE(KmO25)
+   IF (ALLOCATED(gamma_star25)) DEALLOCATE(gamma_star25)
+   IF (ALLOCATED(a1)) DEALLOCATE(a1)
+   IF (ALLOCATED(b1)) DEALLOCATE(b1)
+   IF (ALLOCATED(g0)) DEALLOCATE(g0)
+   IF (ALLOCATED(h_protons)) DEALLOCATE(h_protons)
+   IF (ALLOCATED(fpsir)) DEALLOCATE(fpsir)
+   IF (ALLOCATED(fQ)) DEALLOCATE(fQ)
+   IF (ALLOCATED(fpseudo)) DEALLOCATE(fpseudo)
+   IF (ALLOCATED(kp)) DEALLOCATE(kp)
+   IF (ALLOCATED(alpha)) DEALLOCATE(alpha)
+   IF (ALLOCATED(gbs)) DEALLOCATE(gbs)
+   IF (ALLOCATED(theta)) DEALLOCATE(theta)
+   IF (ALLOCATED(alpha_LL)) DEALLOCATE(alpha_LL)
+   IF (ALLOCATED(downregulation_co2_coeff)) DEALLOCATE(downregulation_co2_coeff) 
+   IF (ALLOCATED(ext_coeff)) DEALLOCATE(ext_coeff)
+   IF (ALLOCATED(rveg_pft)) DEALLOCATE(rveg_pft)
+   IF (ALLOCATED(rstruct_const)) DEALLOCATE(rstruct_const)
+   IF (ALLOCATED(kzero)) DEALLOCATE(kzero)
+   IF (ALLOCATED(wmax_veg)) DEALLOCATE(wmax_veg)
+   IF (ALLOCATED(throughfall_by_pft)) DEALLOCATE(throughfall_by_pft)
+   IF (ALLOCATED(snowa_aged)) DEALLOCATE(snowa_aged)
+   IF (ALLOCATED(snowa_dec)) DEALLOCATE(snowa_dec)
+   IF (ALLOCATED(alb_leaf_vis)) DEALLOCATE(alb_leaf_vis)
+   IF (ALLOCATED(alb_leaf_nir)) DEALLOCATE(alb_leaf_nir)   
+   IF (ALLOCATED(leaf_ssa)) DEALLOCATE(leaf_ssa)   
+   IF (ALLOCATED(leaf_psd)) DEALLOCATE(leaf_psd)   
+   IF (ALLOCATED(bgd_reflectance)) DEALLOCATE(bgd_reflectance)
+   IF (ALLOCATED(leaf_to_shoot_clumping)) DEALLOCATE(leaf_to_shoot_clumping) 
+   IF (ALLOCATED(tune_coupled)) DEALLOCATE (tune_coupled)  
+   IF (ALLOCATED(lai_correction_factor)) DEALLOCATE(lai_correction_factor) 
+   IF (ALLOCATED(min_level_sep)) DEALLOCATE(min_level_sep)
+   IF (ALLOCATED(lai_top)) DEALLOCATE(lai_top)
+   IF (ALLOCATED(em_factor_isoprene)) DEALLOCATE(em_factor_isoprene)
+   IF (ALLOCATED(em_factor_monoterpene)) DEALLOCATE(em_factor_monoterpene)
+   IF (ALLOCATED(em_factor_ORVOC)) DEALLOCATE(em_factor_ORVOC)
+   IF (ALLOCATED(em_factor_OVOC)) DEALLOCATE(em_factor_OVOC)
+   IF (ALLOCATED(em_factor_MBO)) DEALLOCATE(em_factor_MBO)
+   IF (ALLOCATED(em_factor_methanol)) DEALLOCATE(em_factor_methanol)
+   IF (ALLOCATED(em_factor_acetone)) DEALLOCATE(em_factor_acetone)
+   IF (ALLOCATED(em_factor_acetal)) DEALLOCATE(em_factor_acetal)
+   IF (ALLOCATED(em_factor_formal)) DEALLOCATE(em_factor_formal)
+   IF (ALLOCATED(em_factor_acetic)) DEALLOCATE(em_factor_acetic)
+   IF (ALLOCATED(em_factor_formic)) DEALLOCATE(em_factor_formic)
+   IF (ALLOCATED(em_factor_no_wet)) DEALLOCATE(em_factor_no_wet)
+   IF (ALLOCATED(em_factor_no_dry)) DEALLOCATE(em_factor_no_dry)
+   IF (ALLOCATED(Larch)) DEALLOCATE(Larch)
+   IF (ALLOCATED(leaf_tab)) DEALLOCATE(leaf_tab)
+   IF (ALLOCATED(sla)) DEALLOCATE(sla)
+!!$   IF (ALLOCATED(tphoto_min_a)) DEALLOCATE(tphoto_min_a)
+!!$   IF (ALLOCATED(tphoto_min_b)) DEALLOCATE(tphoto_min_b)
+!!$   IF (ALLOCATED(tphoto_min_c)) DEALLOCATE(tphoto_min_c)
+!!$   IF (ALLOCATED(tphoto_opt_a)) DEALLOCATE(tphoto_opt_a)
+!!$   IF (ALLOCATED(tphoto_opt_b)) DEALLOCATE(tphoto_opt_b)
+!!$   IF (ALLOCATED(tphoto_opt_c)) DEALLOCATE(tphoto_opt_c)
+!!$   IF (ALLOCATED(tphoto_max_a)) DEALLOCATE(tphoto_max_a)
+!!$   IF (ALLOCATED(tphoto_max_b)) DEALLOCATE(tphoto_max_b)
+!!$   IF (ALLOCATED(tphoto_max_c)) DEALLOCATE(tphoto_max_c)
+   IF (ALLOCATED(S0)) DEALLOCATE(S0)
+   IF (ALLOCATED(L0)) DEALLOCATE(L0)
+   IF (ALLOCATED(maint_resp_slope)) DEALLOCATE(maint_resp_slope)
+   IF (ALLOCATED(maint_resp_slope_c)) DEALLOCATE(maint_resp_slope_c)
+   IF (ALLOCATED(maint_resp_slope_b)) DEALLOCATE(maint_resp_slope_b)
+   IF (ALLOCATED(maint_resp_slope_a)) DEALLOCATE(maint_resp_slope_a)
+   IF (ALLOCATED(coeff_maint_zero)) DEALLOCATE(coeff_maint_zero)
+   IF (ALLOCATED(cm_zero_leaf)) DEALLOCATE(cm_zero_leaf)
+   IF (ALLOCATED(cm_zero_sapabove)) DEALLOCATE(cm_zero_sapabove)
+   IF (ALLOCATED(cm_zero_sapbelow)) DEALLOCATE(cm_zero_sapbelow)
+   IF (ALLOCATED(cm_zero_heartabove)) DEALLOCATE(cm_zero_heartabove)
+   IF (ALLOCATED(cm_zero_heartbelow)) DEALLOCATE(cm_zero_heartbelow)
+   IF (ALLOCATED(cm_zero_root)) DEALLOCATE(cm_zero_root)
+   IF (ALLOCATED(cm_zero_fruit)) DEALLOCATE(cm_zero_fruit)
+   IF (ALLOCATED(cm_zero_carbres)) DEALLOCATE(cm_zero_carbres)
+   IF (ALLOCATED(cm_zero_labile)) DEALLOCATE(cm_zero_labile)
+   IF (ALLOCATED(coeff_maint_init)) DEALLOCATE(coeff_maint_init)
+   IF (ALLOCATED(frac_growthresp)) DEALLOCATE(frac_growthresp)
+   IF (ALLOCATED(gpp_to_labile)) DEALLOCATE(gpp_to_labile)
+   IF (ALLOCATED(pipe_density)) DEALLOCATE(pipe_density)
+   IF (ALLOCATED(pipe_tune1)) DEALLOCATE(pipe_tune1)
+   IF (ALLOCATED(pipe_tune2)) DEALLOCATE(pipe_tune2)
+   IF (ALLOCATED(pipe_tune3)) DEALLOCATE(pipe_tune3)
+   IF (ALLOCATED(pipe_tune4)) DEALLOCATE(pipe_tune4)
+   IF (ALLOCATED(tree_ff)) DEALLOCATE(tree_ff)
+   IF (ALLOCATED(pipe_k1)) DEALLOCATE(pipe_k1)
+   IF (ALLOCATED(pipe_tune_exp_coeff)) DEALLOCATE(pipe_tune_exp_coeff)
+   IF (ALLOCATED(mass_ratio_heart_sap)) DEALLOCATE(mass_ratio_heart_sap)
+   IF (ALLOCATED(lai_to_height)) DEALLOCATE(lai_to_height)
+   IF (ALLOCATED(canopy_cover)) DEALLOCATE(canopy_cover)
+   IF (ALLOCATED(nmaxtrees)) DEALLOCATE(nmaxtrees)
+   IF (ALLOCATED(height_init_min)) DEALLOCATE(height_init_min)
+   IF (ALLOCATED(height_init_max)) DEALLOCATE(height_init_max)
+   IF (ALLOCATED(alpha_self_thinning)) DEALLOCATE(alpha_self_thinning)
+   IF (ALLOCATED(beta_self_thinning)) DEALLOCATE(beta_self_thinning)
+   IF (ALLOCATED(fuelwood_diameter)) DEALLOCATE(fuelwood_diameter)
+   IF (ALLOCATED(coppice_kill_be_wood)) DEALLOCATE(coppice_kill_be_wood)
+   IF (ALLOCATED(cn_leaf_prescribed)) DEALLOCATE(cn_leaf_prescribed)
+   IF (ALLOCATED(fcn_wood)) DEALLOCATE(fcn_wood)
+   IF (ALLOCATED(fcn_root)) DEALLOCATE(fcn_root)
+   IF (ALLOCATED(k_latosa_max)) DEALLOCATE(k_latosa_max)
+   IF (ALLOCATED(k_latosa_min)) DEALLOCATE(k_latosa_min)
+   IF (ALLOCATED(fruit_alloc)) DEALLOCATE(fruit_alloc) 
+   IF (ALLOCATED(lai_max_to_happy)) DEALLOCATE(lai_max_to_happy)
+   IF (ALLOCATED(flam)) DEALLOCATE(flam)
+   IF (ALLOCATED(k_root)) DEALLOCATE(k_root)
+   IF (ALLOCATED(k_sap)) DEALLOCATE(k_sap)
+   IF (ALLOCATED(k_leaf)) DEALLOCATE(k_leaf)
+   IF (ALLOCATED(phi_leaf)) DEALLOCATE(phi_leaf)
+   IF (ALLOCATED(phi_50)) DEALLOCATE(phi_50)
+   IF (ALLOCATED(c_cavitation)) DEALLOCATE(c_cavitation)
+   IF (ALLOCATED(phi_soil_tune)) DEALLOCATE(phi_soil_tune)
+   IF (ALLOCATED(lai_happy)) DEALLOCATE(lai_happy)
+!-----------------------------------------------------------------------
+!tzjh hydraulic architecture
+
+   IF (ALLOCATED(gpsi)) DEALLOCATE(gpsi)
+   IF (ALLOCATED(gpsi_50)) DEALLOCATE(gpsi_50)
+   IF (ALLOCATED(gmax)) DEALLOCATE(gmax)
+   IF (ALLOCATED(gmin)) DEALLOCATE(gmin)
+   IF (ALLOCATED(kmax_leaf)) DEALLOCATE(kmax_leaf)
+   IF (ALLOCATED(kmax_stem)) DEALLOCATE(kmax_stem)
+   IF (ALLOCATED(kmax_root)) DEALLOCATE(kmax_root)
+   IF (ALLOCATED(a_leaf)) DEALLOCATE(a_leaf)
+   IF (ALLOCATED(a_stem)) DEALLOCATE(a_stem)
+   IF (ALLOCATED(a_root)) DEALLOCATE(a_root)
+   IF (ALLOCATED(P50_leaf)) DEALLOCATE(P50_leaf)
+   IF (ALLOCATED(P50_stem)) DEALLOCATE(P50_stem)
+   IF (ALLOCATED(P50_root)) DEALLOCATE(P50_root)
+   IF (ALLOCATED(wood_density)) DEALLOCATE(wood_density)
+   IF (ALLOCATED(w_density_stem)) DEALLOCATE(w_density_stem)
+   IF (ALLOCATED(root_shoot_ratio)) DEALLOCATE(root_shoot_ratio)
+   IF (ALLOCATED(rwc_root)) DEALLOCATE(rwc_root)
+   IF (ALLOCATED(root_density)) DEALLOCATE(root_density)
+   IF (ALLOCATED(LDMC)) DEALLOCATE(LDMC)
+   IF (ALLOCATED(sla_hydro)) DEALLOCATE(sla_hydro)
+   IF (ALLOCATED(cxyl)) DEALLOCATE(cxyl)
+   IF (ALLOCATED(cr)) DEALLOCATE(cr)
+   IF (ALLOCATED(cl)) DEALLOCATE(cl)
+
+!-----------------------------------------------------------------------
+
+   IF (ALLOCATED(tune_reserves_in_sapling)) DEALLOCATE(tune_reserves_in_sapling)
+   IF (ALLOCATED(death_distribution_factor)) DEALLOCATE(death_distribution_factor)
+   IF (ALLOCATED(npp_reset_value)) DEALLOCATE(npp_reset_value)
+   IF (ALLOCATED(resist)) DEALLOCATE(resist)
+   IF (ALLOCATED(coeff_lcchange_s)) DEALLOCATE(coeff_lcchange_s)
+   IF (ALLOCATED(coeff_lcchange_m)) DEALLOCATE(coeff_lcchange_m)
+   IF (ALLOCATED(coeff_lcchange_l)) DEALLOCATE(coeff_lcchange_l)
+   IF (ALLOCATED(lai_max)) DEALLOCATE(lai_max)
+   IF (ALLOCATED(pheno_model)) DEALLOCATE(pheno_model)
+   IF (ALLOCATED(pheno_type)) DEALLOCATE(pheno_type)
+   IF (ALLOCATED(pheno_gdd_crit_c)) DEALLOCATE(pheno_gdd_crit_c)
+   IF (ALLOCATED(pheno_gdd_crit_b)) DEALLOCATE(pheno_gdd_crit_b)
+   IF (ALLOCATED(pheno_gdd_crit_a)) DEALLOCATE(pheno_gdd_crit_a)
+   IF (ALLOCATED(pheno_gdd_crit)) DEALLOCATE(pheno_gdd_crit)
+   IF (ALLOCATED(ngd_crit)) DEALLOCATE(ngd_crit)
+   IF (ALLOCATED(opti_kpheno_crit)) DEALLOCATE(opti_kpheno_crit)
+   IF (ALLOCATED(ncdgdd_temp)) DEALLOCATE(ncdgdd_temp)
+   IF (ALLOCATED(hum_frac)) DEALLOCATE(hum_frac)
+   IF (ALLOCATED(hum_min_time)) DEALLOCATE(hum_min_time)
+   IF (ALLOCATED(tau_sap)) DEALLOCATE(tau_sap)
+   IF (ALLOCATED(tau_fruit)) DEALLOCATE(tau_fruit)
+   IF (ALLOCATED(tau_root)) DEALLOCATE(tau_root)
+   IF (ALLOCATED(tau_leaf)) DEALLOCATE(tau_leaf)
+   IF (ALLOCATED(ecureuil)) DEALLOCATE(ecureuil)
+   IF (ALLOCATED(alloc_min)) DEALLOCATE(alloc_min)
+   IF (ALLOCATED(alloc_max)) DEALLOCATE(alloc_max)
+   IF (ALLOCATED(demi_alloc)) DEALLOCATE(demi_alloc)
+   IF (ALLOCATED(leaffall)) DEALLOCATE(leaffall)
+   IF (ALLOCATED(senescence_type)) DEALLOCATE(senescence_type)
+   IF (ALLOCATED(senescence_hum)) DEALLOCATE(senescence_hum)
+   IF (ALLOCATED(nosenescence_hum)) DEALLOCATE(nosenescence_hum)
+   IF (ALLOCATED(max_turnover_time)) DEALLOCATE(max_turnover_time)
+   IF (ALLOCATED(min_turnover_time)) DEALLOCATE(min_turnover_time)
+   IF (ALLOCATED(min_leaf_age_for_senescence)) DEALLOCATE(min_leaf_age_for_senescence)
+   IF (ALLOCATED(senescence_temp_c)) DEALLOCATE(senescence_temp_c)
+   IF (ALLOCATED(senescence_temp_b)) DEALLOCATE(senescence_temp_b)
+   IF (ALLOCATED(senescence_temp_a)) DEALLOCATE(senescence_temp_a)
+   IF (ALLOCATED(senescence_temp)) DEALLOCATE(senescence_temp)
+   IF (ALLOCATED(gdd_senescence)) DEALLOCATE(gdd_senescence)
+   IF (ALLOCATED(residence_time)) DEALLOCATE(residence_time)
+   ! added by yitong yao 07 Jan 2020 08:30 
+   IF (ALLOCATED(plc_kill_frac)) DEALLOCATE(plc_kill_frac)
+   ! added by yitong yao 07 Jan 2020 08:30
+   IF (ALLOCATED(mor_kill_frac)) DEALLOCATE(mor_kill_frac)
+   IF (ALLOCATED(tmin_crit)) DEALLOCATE(tmin_crit)
+   IF (ALLOCATED(tcm_crit)) DEALLOCATE(tcm_crit)
+   IF (ALLOCATED(mortality_min)) DEALLOCATE(mortality_min)
+   IF (ALLOCATED(mortality_max)) DEALLOCATE(mortality_max)
+   IF (ALLOCATED(ref_mortality)) DEALLOCATE(ref_mortality)
+   IF (ALLOCATED(tau_hum_growingseason)) DEALLOCATE(tau_hum_growingseason)
+   IF (ALLOCATED(lai_initmin)) DEALLOCATE(lai_initmin)
+   IF (ALLOCATED(bm_sapl_old)) DEALLOCATE(bm_sapl_old)
+   IF (ALLOCATED(migrate)) DEALLOCATE(migrate)
+   IF (ALLOCATED(maxdia)) DEALLOCATE(maxdia)
+   IF (ALLOCATED(cn_sapl)) DEALLOCATE(cn_sapl)
+   IF (ALLOCATED(leaf_timecst)) DEALLOCATE(leaf_timecst)
+   IF (ALLOCATED(plantation)) DEALLOCATE(plantation)
+   IF (ALLOCATED(fm_allo_a)) DEALLOCATE(fm_allo_a)
+   IF (ALLOCATED(fm_allo_c)) DEALLOCATE(fm_allo_c)
+   IF (ALLOCATED(fm_allo_d)) DEALLOCATE(fm_allo_d)
+   IF (ALLOCATED(fm_allo_p)) DEALLOCATE(fm_allo_p)
+   IF (ALLOCATED(fm_allo_q)) DEALLOCATE(fm_allo_q)
+   IF (ALLOCATED(allo_crown_a0)) DEALLOCATE(allo_crown_a0)
+   IF (ALLOCATED(allo_crown_a1)) DEALLOCATE(allo_crown_a1)
+   IF (ALLOCATED(allo_crown_a2)) DEALLOCATE(allo_crown_a2)
+   IF (ALLOCATED(h_first)) DEALLOCATE(h_first)
+   IF (ALLOCATED(dens_target)) DEALLOCATE(dens_target)
+   IF (ALLOCATED(thinstrat)) DEALLOCATE(thinstrat)
+   IF (ALLOCATED(taumin)) DEALLOCATE(taumin)
+   IF (ALLOCATED(taumax)) DEALLOCATE(taumax)
+   IF (ALLOCATED(alpha_rdi_upper)) DEALLOCATE(alpha_rdi_upper)
+   IF (ALLOCATED(beta_rdi_upper)) DEALLOCATE(beta_rdi_upper)
+   IF (ALLOCATED(alpha_rdi_lower)) DEALLOCATE(alpha_rdi_lower)
+   IF (ALLOCATED(beta_rdi_lower)) DEALLOCATE(beta_rdi_lower)
+   IF (ALLOCATED(largest_tree_dia)) DEALLOCATE(largest_tree_dia)
+   IF (ALLOCATED(branch_ratio)) DEALLOCATE(branch_ratio)
+   IF (ALLOCATED(branch_ratio)) DEALLOCATE(branch_ratio)
+   IF (ALLOCATED(decl_factor)) DEALLOCATE(decl_factor)
+   !IF (ALLOCATED(opt_factor)) DEALLOCATE(opt_factor)
+   IF (ALLOCATED(coppice_diameter)) DEALLOCATE(coppice_diameter)
+   IF (ALLOCATED(shoots_per_stool)) DEALLOCATE(shoots_per_stool)
+   IF (ALLOCATED(src_rot_length)) DEALLOCATE(src_rot_length)
+   IF (ALLOCATED(src_nrots)) DEALLOCATE(src_nrots)
+   IF (ALLOCATED(m_dv)) DEALLOCATE(m_dv)
+   IF (ALLOCATED(recruitment_light_threshold)) DEALLOCATE(recruitment_light_threshold)
+   IF (ALLOCATED(dia_recr)) DEALLOCATE(dia_recr)
+   IF (ALLOCATED(hei_recr)) DEALLOCATE(hei_recr)
+   IF (ALLOCATED(harvest_ratio)) DEALLOCATE(harvest_ratio)
+   
+ END SUBROUTINE pft_parameters_clear
+
+END MODULE pft_parameters
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parameters/pft_parameters_var.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parameters/pft_parameters_var.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parameters/pft_parameters_var.f90	(revision 7236)
@@ -0,0 +1,1130 @@
+! =================================================================================================================================
+! MODULE       : pft_parameters_var
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2011)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        This module contains the variables in function of plant funtional type (pft).
+!!
+!!\n DESCRIPTION: This module contains the declarations for the externalized variables in function of the 
+!!                plant foncional type(pft). \n
+!!                The module is already USE in module pft_parameters. Therefor no need to USE it seperatly except
+!!                if the subroutines in module pft_parameters are not needed.\n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	: None
+!!
+!! SVN          :
+!! $HeadURL: $
+!! $Date: 2015-02-22 16:18:16 +0100 (Sun, 22 Feb 2015) $
+!! $Revision: 2555 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE pft_parameters_var
+
+  USE defprec
+  
+  IMPLICIT NONE
+
+
+  !
+  ! PFT GLOBAL
+  !
+  INTEGER(i_std), SAVE :: nvm = 13                               !! Number of vegetation types (2-N, unitless)
+!$OMP THREADPRIVATE(nvm)
+
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pft_to_mtc  !! Table of conversion : we associate one pft to one metaclass 
+                                                                 !! (1-13, unitless)
+!$OMP THREADPRIVATE(pft_to_mtc)
+
+  CHARACTER(LEN=34), ALLOCATABLE, SAVE, DIMENSION(:) :: PFT_name !! Description of the PFT (unitless)
+!$OMP THREADPRIVATE(PFT_name)
+
+  LOGICAL, SAVE   :: l_first_pft_parameters = .TRUE.             !! To keep first call trace of the module (true/false)
+!$OMP THREADPRIVATE(l_first_pft_parameters)
+  LOGICAL, SAVE   :: ok_throughfall_by_pft = .TRUE.             !! Flag to use the parameter PERCENT_THROUGHFALL_PFT (true/false) 
+!$OMP THREADPRIVATE(ok_throughfall_by_pft)
+
+
+  !
+  ! VEGETATION STRUCTURE
+  !
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: leaf_tab       !! leaf type (1-4, unitless)
+                                                                    !! 1=broad leaved tree, 2=needle leaved tree, 
+                                                                    !! 3=grass 4=bare ground 
+!$OMP THREADPRIVATE(leaf_tab)
+
+  CHARACTER(len=6), ALLOCATABLE, SAVE, DIMENSION(:) :: pheno_model  !! which phenology model is used? (tabulated) (unitless)
+!$OMP THREADPRIVATE(pheno_model)
+
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:) :: is_tree               !! Is the vegetation type a tree ? (true/false)
+!$OMP THREADPRIVATE(is_tree)
+
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:) :: is_deciduous          !! Is PFT deciduous ? (true/false)
+!$OMP THREADPRIVATE(is_deciduous)
+
+   LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:) :: is_tropical          !! Is PFT tropical ? (true/false)
+!$OMP THREADPRIVATE(is_tropical)
+
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:) :: is_temperate          !! Is PFT temperate ? (true/false)
+!$OMP THREADPRIVATE(is_temperate)
+
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:) :: is_boreal             !! Is PFT boreal ? (true/false)
+!$OMP THREADPRIVATE(is_boreal)
+
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:) :: is_evergreen          !! Is PFT evegreen ? (true/false)
+!$OMP THREADPRIVATE(is_evergreen)
+
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:) :: is_needleleaf         !! Is PFT needleleaf ? (true/false)
+!$OMP THREADPRIVATE(is_needleleaf)
+
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:) :: natural               !! natural? (true/false)
+!$OMP THREADPRIVATE(natural)
+
+  CHARACTER(len=5), ALLOCATABLE, SAVE, DIMENSION(:) :: type_of_lai  !! 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
+!$OMP THREADPRIVATE(type_of_lai)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: veget_ori_fixed_test_1 !! Value for veget_ori for tests in 0-dim simulations 
+                                                                         !! (0-1, unitless)
+!$OMP THREADPRIVATE(veget_ori_fixed_test_1)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: llaimax                !! laimax for maximum lai see also type of lai 
+                                                                         !! interpolation
+                                                                         !! @tex $(m^2.m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(llaimax)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: llaimin                !! laimin for minimum lai see also type of lai 
+                                                                         !! interpolation 
+                                                                         !! @tex $(m^2.m^{-2})$ @endtex
+!$OMP THREADPRIVATE(llaimin)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: height_presc           !! prescribed height of vegetation.(m) Only used without stomate
+                                                                         !! Value for height_presc : one for each vegetation type
+!$OMP THREADPRIVATE(height_presc)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) ::  rveg_pft              !! Potentiometer to set vegetation resistance (unitless)
+                                                                         !! Nathalie on March 28th, 2006 - from Fred Hourdin,
+!$OMP THREADPRIVATE(rveg_pft)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: sla                    !! specif leaf area @tex $(m^2.gC^{-1})$ @endtex 
+!$OMP THREADPRIVATE(sla)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: lai_happy              !! Lai threshold below which carbohydrate 
+                                                                         !! reserve may be used in functional allocation.
+                                                                         !! Also used in phenology to see if mixed classes
+                                                                         !! should die.  These seem completely arbitrary.
+                                                                         !! @tex $(m^2.m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(lai_happy)
+
+  !
+  ! EVAPOTRANSPIRATION (sechiba)
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: rstruct_const          !! Structural resistance. 
+                                                                         !! Value for rstruct_const : one for each vegetation type
+                                                                         !! @tex $(s.m^{-1})$ @endtex
+!$OMP THREADPRIVATE(rstruct_const)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: kzero                  !! A vegetation dependent constant used in the calculation
+                                                                         !! of the surface resistance. 
+                                                                         !! Value for kzero one for each vegetation type
+                                                                         !! @tex $(kg.m^2.s^{-1})$ @endtex
+!$OMP THREADPRIVATE(kzero)
+
+  !
+  ! WATER (sechiba)
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: wmax_veg  !! Volumetric available soil water capacity in each PFT
+                                                            !! @tex $(kg.m^{-3} of soil)$ @endtex
+!$OMP THREADPRIVATE(wmax_veg)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: humcste   !! 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 
+                                                            !! @tex $(m^{-1})$ @endtex
+!$OMP THREADPRIVATE(humcste)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: throughfall_by_pft !! Fraction of rain intercepted by the canopy (0-100, unitless)
+!$OMP THREADPRIVATE(throughfall_by_pft)
+
+  !
+  ! ALBEDO (sechiba)
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: snowa_aged    !! Minimum snow albedo value for each vegetation type
+                                                                !! after aging (dirty old snow) (unitless)
+                                                                !! Source : Values are from the Thesis of S. Chalita (1992)
+!$OMP THREADPRIVATE(snowa_aged)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: snowa_dec     !! Decay rate of snow albedo value for each vegetation type
+                                                                !! as it will be used in condveg_snow (unitless)
+                                                                !! Source : Values are from the Thesis of S. Chalita (1992)
+!$OMP THREADPRIVATE(snowa_dec)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: alb_leaf_vis  !! leaf albedo of vegetation type, visible albedo (unitless)
+!$OMP THREADPRIVATE(alb_leaf_vis)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: alb_leaf_nir  !! leaf albedo of vegetation type, near infrared albedo (unitless)
+!$OMP THREADPRIVATE(alb_leaf_nir)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:) :: leaf_ssa       !! leaf single scattering albedo of all 
+!$OMP THREADPRIVATE(leaf_ssa)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:) :: leaf_psd       !! leaf prefered scattering direction of all 
+                                                                       !! vegetation types and spectra (unitless)
+!$OMP THREADPRIVATE(leaf_psd)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:) :: bgd_reflectance  !! background reflectance of all vegetation types and spectra (unitless)
+!$OMP THREADPRIVATE(bgd_reflectance)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: leaf_to_shoot_clumping       !! The clumping factor for leaves to shoots in the 
+                                                                               !! effective LAI calculation...notice this should be
+                                                                               !! equal to unity for grasslands/croplands
+!$OMP THREADPRIVATE(leaf_to_shoot_clumping)
+
+
+!---add by YC ---a constant for tunning the LAI, which coupled with the atmosphere for the transpiaration  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: tune_coupled                 !! The coupled factor of LAI for the transpiration                                                                    
+!$OMP THREADPRIVATE(tune_coupled)
+
+
+
+
+! NOTE: this next variable originally was a plant-to-stand clumping factor to be used
+! in describing how grasses and crops clump together at the plant level (but not trees, 
+! as their plant-to-stand clumping is calculated directly) to calculate abledo. However, we
+! get the effective spectral parameters for the albedo calculation from inverting satelite data,
+! which includes all clumping.  Therefore we do not wish to account for this effect twice.
+! What will be incorrect about our grassland and crop albedo is the lack of management options
+! for these PFTs in ORCHIDEE, which will lead to LAI values which are wrong.  Thus we 
+! will include an LAI correction factor in the calculation of the effective LAI which
+! allows us to compensate for this via tuning. 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: lai_correction_factor  !! see note above
+!$OMP THREADPRIVATE(lai_correction_factor)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: min_level_sep          !! This is used in determining the levels
+                                                                         !! for photosynthesis.  This is the thinnest
+                                                                         !! that the levels are allowed to be, in 
+                                                                         !! vertical thickness.
+                                                                         !! @tex $(m)$ @endtex
+!$OMP THREADPRIVATE(min_level_sep)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: lai_top                !! Diffuco.f90 calculates the stomatal conductance of the
+                                                                         !! top layer of the canopy. Because the top layer can contain
+                                                                         !! different amounts of LAI depending on the crown diameter
+                                                                         !! we had to define top layer in terms of the LAI it contains.
+                                                                         !! stomatal conductance in the top layer contributes to the 
+                                                                         !! transpiration (m2 m-2). Arbitrary values.
+!$OMP THREADPRIVATE(lai_top)
+
+
+
+  !
+  ! SOIL - VEGETATION
+  !
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pref_soil_veg      !! 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
+                                                                        !! This variable is initialized in slowproc.(1-3, unitless)
+!$OMP THREADPRIVATE(pref_soil_veg)
+
+  !
+  ! PHOTOSYNTHESIS
+  !
+  !-
+  ! 1. CO2
+  !-
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:) :: is_c4             !! flag for C4 vegetation types (true/false)
+!$OMP THREADPRIVATE(is_c4)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: vcmax_fix     !! values used for vcmax when STOMATE is not activated
+                                                                !! @tex $(\mu mol.m^{-2}.s^{-1})$ @endtex
+!$OMP THREADPRIVATE(vcmax_fix)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: vjmax_fix     !! values used for vjmax when STOMATE is not activated 
+                                                                !! @tex $(\mu mol.m^{-2}.s^{-1})$ @endtex
+!$OMP THREADPRIVATE(vjmax_fix)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: co2_tmin_fix  !! values used for photosynthesis tmin when STOMATE 
+                                                                !! is not activated (C)
+!$OMP THREADPRIVATE(co2_tmin_fix)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: co2_topt_fix  !! values used for photosynthesis topt when STOMATE 
+                                                                !! is not activated (C)
+!$OMP THREADPRIVATE(co2_topt_fix)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: co2_tmax_fix  !! values used for photosynthesis tmax when STOMATE 
+                                                                !! is not activated (C)
+!$OMP THREADPRIVATE(co2_tmax_fix)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: downregulation_co2_coeff !! Coefficient for CO2 downregulation (unitless)
+!$OMP THREADPRIVATE(downregulation_co2_coeff)
+
+
+  !-
+  ! 2. Stomate
+  !-
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: ext_coeff     !! extinction coefficient of the Monsi&Saeki relationship (1953)
+                                                                !! (unitless)
+!$OMP THREADPRIVATE(ext_coeff)
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: E_KmC          !! Energy of activation for KmC (J mol-1)
+!$OMP THREADPRIVATE(E_KmC)                                                               
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: E_KmO         !! Energy of activation for KmO (J mol-1)
+!$OMP THREADPRIVATE(E_KmO)          
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: E_gamma_star  !! Energy of activation for gamma_star (J mol-1)
+!$OMP THREADPRIVATE(E_gamma_star)    
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: E_Vcmax       !! Energy of activation for Vcmax (J mol-1) 
+!$OMP THREADPRIVATE(E_Vcmax)                                                              
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: E_Jmax        !! Energy of activation for Jmax (J mol-1)
+!$OMP THREADPRIVATE(E_Jmax) 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: aSV           !! a coefficient of the linear regression (a+bT) defining the Entropy term for Vcmax (J K-1 mol-1)
+!$OMP THREADPRIVATE(aSV)    
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: bSV           !! b coefficient of the linear regression (a+bT) defining the Entropy term for Vcmax (J K-1 mol-1 Â°C-1)
+!$OMP THREADPRIVATE(bSV)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: tphoto_min   !! minimum photosynthesis temperature (deg C)
+!$OMP THREADPRIVATE(tphoto_min) 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: tphoto_max   !! maximum photosynthesis temperature (deg C)
+!$OMP THREADPRIVATE(tphoto_max) 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: aSJ           !! a coefficient of the linear regression (a+bT) defining the Entropy term for Jmax (J K-1 mol-1)
+!$OMP THREADPRIVATE(aSJ)    
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: bSJ           !! b coefficient of the linear regression (a+bT) defining the Entropy term for Jmax (J K-1 mol-1 Â°C-1)
+!$OMP THREADPRIVATE(bSJ)    
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: D_Vcmax       !! Energy of deactivation for Vcmax (J mol-1)
+!$OMP THREADPRIVATE(D_Vcmax)                     
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: D_Jmax        !! Energy of deactivation for Jmax (J mol-1)
+!$OMP THREADPRIVATE(D_Jmax)                                    
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: E_Rd          !! Energy of activation for Rd (J mol-1)
+!$OMP THREADPRIVATE(E_Rd)                                      
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: Vcmax25       !! Maximum rate of Rubisco activity-limited carboxylation at 25Â°C
+                                                                !! @tex $(\mu mol.m^{-2}.s^{-1})$ @endtex
+!$OMP THREADPRIVATE(Vcmax25)
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: arJV          !! a coefficient of the linear regression (a+bT) defining the Jmax25/Vcmax25 ratio (mu mol e- (mu mol CO2)-1)
+!$OMP THREADPRIVATE(arJV)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: brJV          !! b coefficient of the linear regression (a+bT) defining the Jmax25/Vcmax25 ratio (mu mol e- (mu mol CO2)-1)
+!$OMP THREADPRIVATE(brJV)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: KmC25         !! MichaelisâMenten constant of Rubisco for CO2 at 25Â°C (ubar)
+!$OMP THREADPRIVATE(KmC25)                                     
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: KmO25         !! MichaelisâMenten constant of Rubisco for O2 at 25Â°C (ubar)
+!$OMP THREADPRIVATE(KmO25)                
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: gamma_star25  !! Ci-based CO2 compensation point in the absence of Rd at 25Â°C (ubar)
+!$OMP THREADPRIVATE(gamma_star25)       
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: a1            !! Empirical factor involved in the calculation of fvpd (-)
+!$OMP THREADPRIVATE(a1)                                        
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: b1            !! Empirical factor involved in the calculation of fvpd (-)
+!$OMP THREADPRIVATE(b1)                                        
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: g0            !! Residual stomatal conductance when irradiance approaches zero (mol mâ2 sâ1 barâ1)
+!$OMP THREADPRIVATE(g0)                                        
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: h_protons     !! Number of protons required to produce one ATP (mol mol-1)
+!$OMP THREADPRIVATE(h_protons)                                 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: fpsir         !! Fraction of PSII eâ transport rate partitioned to the C4 cycle (-)
+!$OMP THREADPRIVATE(x)                                         
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: fQ            !! Fraction of electrons at reduced plastoquinone that follow the Q-cycle (-) - Values for C3 platns are not used
+!$OMP THREADPRIVATE(fQ)                                        
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: fpseudo       !! Fraction of electrons at PSI that follow  pseudocyclic transport (-) - Values for C3 platns are not used
+!$OMP THREADPRIVATE(fpseudo)                                   
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: kp            !! Initial carboxylation efficiency of the PEP carboxylase (mol mâ2 sâ1 barâ1) 
+!$OMP THREADPRIVATE(kp)                                        
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: alpha         !! Fraction of PSII activity in the bundle sheath (-)
+!$OMP THREADPRIVATE(alpha)                                     
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: gbs           !! Bundle-sheath conductance (mol mâ2 sâ1 barâ1)
+!$OMP THREADPRIVATE(gbs)                                       
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: theta         !! Convexity factor for response of J to irradiance (-)
+!$OMP THREADPRIVATE(theta)                                     
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: alpha_LL      !! Conversion efficiency of absorbed light into J at strictly limiting light (mol eâ (mol photon)â1)
+!$OMP THREADPRIVATE(alpha_LL)
+                                                                                                                                                                              
+  !
+  ! ALLOCATION (stomate)
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: S0            !! Default sapwood allocation (0-1, unitless)
+!$OMP THREADPRIVATE(S0)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: L0            !! Default leaf allocation (0-1, unitless)
+!$OMP THREADPRIVATE(L0)
+
+
+  !
+  ! RESPIRATION (stomate)
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:) :: maint_resp_slope  !! slope of maintenance respiration coefficient 
+                                                                      !! (1/K, 1/K^2, 1/K^3), used in the code
+!$OMP THREADPRIVATE(maint_resp_slope)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: maint_resp_slope_c  !! slope of maintenance respiration coefficient (1/K),
+                                                                      !! constant c of aT^2+bT+c , tabulated
+!$OMP THREADPRIVATE(maint_resp_slope_c)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: maint_resp_slope_b  !! slope of maintenance respiration coefficient (1/K), 
+                                                                      !! constant b of aT^2+bT+c , tabulated
+!$OMP THREADPRIVATE(maint_resp_slope_b)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: maint_resp_slope_a  !! slope of maintenance respiration coefficient (1/K), 
+                                                                      !! constant a of aT^2+bT+c , tabulated
+!$OMP THREADPRIVATE(maint_resp_slope_a)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:) :: coeff_maint_zero  !! maintenance respiration coefficient at 0 deg C, 
+                                                                      !! @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+!$OMP THREADPRIVATE(coeff_maint_zero)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: cm_zero_leaf        !! maintenance respiration coefficient at 0 deg C,
+                                                                      !! for leaves, tabulated 
+                                                                      !! @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+!$OMP THREADPRIVATE(cm_zero_leaf)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: cm_zero_sapabove    !! maintenance respiration coefficient at 0 deg C,
+                                                                      !! for sapwood above, tabulated
+                                                                      !! @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+!$OMP THREADPRIVATE(cm_zero_sapabove)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: cm_zero_sapbelow    !! maintenance respiration coefficient at 0 deg C,
+                                                                      !! for sapwood below, tabulated 
+                                                                      !! @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+!$OMP THREADPRIVATE(cm_zero_sapbelow)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: cm_zero_heartabove  !! maintenance respiration coefficient at 0 deg C
+                                                                      !! for heartwood above, tabulated 
+                                                                      !! @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+!$OMP THREADPRIVATE(cm_zero_heartabove)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: cm_zero_heartbelow  !! maintenance respiration coefficient at 0 deg C,
+                                                                      !! for heartwood below, tabulated 
+                                                                      !! @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+!$OMP THREADPRIVATE(cm_zero_heartbelow)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: cm_zero_root        !! maintenance respiration coefficient at 0 deg C,
+                                                                      !! for roots, tabulated
+                                                                      !! @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+!$OMP THREADPRIVATE(cm_zero_root)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: cm_zero_fruit       !! maintenance respiration coefficient  at 0 deg C,
+                                                                      !! for fruits, tabulated
+                                                                      !! @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+!$OMP THREADPRIVATE(cm_zero_fruit)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: cm_zero_carbres     !! maintenance respiration coefficient at 0 deg C,
+                                                                      !! for carbohydrate reserve, tabulated
+                                                                      !! @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+!$OMP THREADPRIVATE(cm_zero_carbres)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: cm_zero_labile      !! maintenance respiration coefficient at 0 deg C,
+                                                                      !! for the labile pool, tabulated
+                                                                      !! @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+!$OMP THREADPRIVATE(cm_zero_labile)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: coeff_maint_init    !! initial value for maintenance respiration 
+                                                                      !! coefficient at 0 deg C used in functional allocation
+                                                                      !! @tex $(gC.gC^{-1}.day^{-1})$ @endtex
+!$OMP THREADPRIVATE(coeff_maint_init)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: frac_growthresp     !! Fraction of growth respiration expressed as
+                                                                      !! share of the total C that is to be allocated
+                                                                      !! (0-1).
+!$OMP THREADPRIVATE(frac_growthresp)
+
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: gpp_to_labile        !! The size of the labile pool as a fraction of the
+                                                                      !! weekly gpp (-). For example, 3 indicates that the 
+                                                                      !! is 3 times the weekly gpp. 
+!$OMP THREADPRIVATE(gpp_to_labile)
+
+
+  !
+  ! STAND STRUCTURE (stomate) 
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pipe_density        !! Wood density in @tex $(gC.m^{-3})$ @endtex
+!$OMP THREADPRIVATE(pipe_density)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pipe_tune1          !! crown area = pipe_tune1*stem diameter**pipe_tune_exp_coeff
+!$OMP THREADPRIVATE(pipe_tune1)
+  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pipe_tune2          !! height=pipe_tune2 * diameter**pipe_tune3
+!$OMP THREADPRIVATE(pipe_tune2)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: tree_ff             !! Volume reduction factor from cylinder to real tree shape (inc.branches)
+!$OMP THREADPRIVATE(tree_ff)
+  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pipe_tune3          !! height=pipe_tune2 * diameter**pipe_tune3
+!$OMP THREADPRIVATE(pipe_tune3)      
+  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pipe_tune4          !! ???needed for stem diameter
+!$OMP THREADPRIVATE(pipe_tune4)      
+  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pipe_k1             !! ???
+!$OMP THREADPRIVATE(pipe_k1)       
+  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pipe_tune_exp_coeff !! crown area = pipe_tune1*stem diameter**pipe_tune_exp_coeff
+!$OMP THREADPRIVATE(pipe_tune_exp_coeff)      
+  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: mass_ratio_heart_sap!! mass ratio (heartwood+sapwood)/heartwood 
+!$OMP THREADPRIVATE(mass_ratio_heart_sap)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: lai_to_height       !! Covert lai into vegetation height for grasses and crops
+!$OMP THREADPRIVATE(lai_to_height)    
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: canopy_cover        !! Canopy cover - current values are guesses for testing
+                                                                      !! could tune this variable to match MODIS albedo
+!$OMP THREADPRIVATE(canopy_cover)
+ 
+
+  !
+  ! GROWTH (resource limitation - stomate) 
+  !  
+  
+  !
+  ! GROWTH (functional allocation - stomate)
+  !  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: cn_leaf_prescribed  !! CN of foliage for allocation, according to stich et al 2003
+!$OMP THREADPRIVATE(cn_leaf_prescribed)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: fcn_wood            !! CN of wood for allocation, relative to leaf CN according
+                                                                      !! to stich et al 2003
+!$OMP THREADPRIVATE(fcn_wood)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: fcn_root            !! CN of roots for allocation, relative to leaf CN according
+                                                                      !! to stich et al 2003
+!$OMP THREADPRIVATE(fcn_root)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: k_latosa_max       !! Maximum leaf-to-sapwood area ratio (unitless)
+!$OMP THREADPRIVATE(k_latosa_max)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: k_latosa_min       !! Minimum leaf-to-sapwood area ratio (unitless)
+!$OMP THREADPRIVATE(k_latosa_min)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: fruit_alloc         !! Fraction of biomass allocated to fruit production (0-1)
+
+!$OMP THREADPRIVATE(fruit_alloc) 
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: m_dv                !! Parameter in the Deleuze & Dhote allocation rule that
+                                                                      !! relaxes the cut-off imposed by ::sigma. Owing to m_relax 
+                                                                      !! trees still grow a little when their ::circ is below 
+                                                                      !! ::sigma
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: recruitment_light_threshold !! Parameter in the Deleuze & Dhote allocation rule that
+                                                                      !! relaxes the cut-off imposed by ::sigma. Owing to m_relax 
+                                                                      !! trees still grow a little when their ::circ is below 
+                                                                      !! ::sigma
+!$OMP THREADPRIVATE(recruitment_light_threshold) 
+
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: dia_recr              !! Parameter in the Deleuze & Dhote allocation rule that
+                                                                      !! relaxes the cut-off imposed by ::sigma. Owing to m_relax 
+                                                                      !! trees still grow a little when their ::circ is below 
+                                                                      !! ::sigma
+!$OMP THREADPRIVATE(dia_recr) 
+
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: hei_recr              !! Parameter in the Deleuze & Dhote allocation rule that
+                                                                      !! relaxes the cut-off imposed by ::sigma. Owing to m_relax 
+                                                                      !! trees still grow a little when their ::circ is below 
+                                                                      !! ::sigma
+!$OMP THREADPRIVATE(hei_recr) 
+                                                                      
+!$OMP THREADPRIVATE(m_dv) 
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: lai_max_to_happy    !! Multiplicative factor of lai_max that determines
+                                                                      !! the threshold value of LAI below which the carbohydrate
+                                                                      !! reserve is used. 
+                                                       
+!$OMP THREADPRIVATE(lai_max_to_happy) 
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: k_root              !! Fine root specific conductivity 
+                                                                      !! @tex $(m^{3} kg^{-1} s^{-1} MPa^{-1})$ @endtex 
+!$OMP THREADPRIVATE(k_root)
+ 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: k_sap               !! Sapwood specific conductivity
+                                                                      !! @tex $(m^{3} kg^{-1} s^{-1} MPa^{-1})$ @endtex 
+!$OMP THREADPRIVATE(k_sap)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: k_leaf              !! Leaf conductivity @tex $(m s^{-1} MPa^{-1})$ @endtex
+!$OMP THREADPRIVATE(k_leaf)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: phi_leaf            !! Minimal leaf water potential @tex $(m s^{-1} MPa^{-1})$ @endtex
+!$OMP THREADPRIVATE(phi_leaf)
+  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: phi_50              !! Sapwood leaf water potential that causes 50% loss of xylem
+                                                                      !! conductivity through cavitation @tex $(m s^{-1} MPa^{-1})$ @endtex
+!$OMP THREADPRIVATE(phi_50)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: c_cavitation        !! Shape parameter for loss of conductance Machado & Tyree, 1994 (unitless)          
+!$OMP THREADPRIVATE(c_cavitation)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: phi_soil_tune       !! Additive tuning parameter to account for soil-root interaction
+                                                                      !! @tex $(MPa)$ @endtex        
+!$OMP THREADPRIVATE(phi_soil_tune)
+
+! -----------------------------------------------------------------------------------------------------
+! tzjh hydraulic conductivity
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: gpsi    !! gs vs psi_leaf curve parameter     
+!$OMP THREADPRIVATE(gpsi)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: gpsi_50    !! psi_leaf at 50% stomatal closure, -MPa       
+!$OMP THREADPRIVATE(gpsi_50)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: gmax    !! maximum stomatal conductance @tex $mmol m^{-2}s^{-1}$ @endtex   
+!$OMP THREADPRIVATE(gmax)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: gmin    !! minimum stomatal conductance @tex $mmol m^{-2}s^{-1}$ @endtex   
+!$OMP THREADPRIVATE(gmin)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: kmax_leaf    !! maximum hydraulic conductivity of leaf @tex $mmol m^{-2}s^{-1} MPa^{-1}$ @endtex   
+!$OMP THREADPRIVATE(kmax_leaf)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: kmax_stem    !! maximum hydraulic conductivity of stem @tex $mmol m^{-2}s^{-1} MPa^{-1}$ @endtex   
+!$OMP THREADPRIVATE(kmax_stem)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: kmax_root    !! maximum hydraulic conductivity of root @tex $mmol m^{-2}s^{-1} MPa^{-1}$ @endtex   
+!$OMP THREADPRIVATE(kmax_root)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: a_leaf    !!  kleaf vs. psi_leaf curve parameter  
+!$OMP THREADPRIVATE(a_leaf)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: a_stem    !!  kstem vs. psi_stem curve parameter  
+!$OMP THREADPRIVATE(a_stem)
+ 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: a_root    !!  kroot vs. psi_root curve parameter  
+!$OMP THREADPRIVATE(a_root)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: P50_leaf    !!  psi_leaf at 50% loss of leaf hydraulic conductivity, MPa  
+!$OMP THREADPRIVATE(P50_leaf)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: P50_stem    !!  psi_stem at 50% loss of leaf hydraulic conductivity, MPa  
+!$OMP THREADPRIVATE(P50_stem)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: P50_root    !!  psi_root at 50% loss of leaf hydraulic conductivity, MPa  
+!$OMP THREADPRIVATE(P50_root)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: wood_density    !!  g of stem dry mass per m3 of stem volume Averaged across all Neotropical species from Chave et al. 2006 Ecological Applications  
+!$OMP THREADPRIVATE(wood_density)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: w_density_stem    !!  mmol H2O per m3 of stem volume values averaged from a Bornean tropical forest  
+!$OMP THREADPRIVATE(w_density_stem)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: root_shoot_ratio    !!   ratio of root mass to shoot mass, g g-1 values are averaged for wet an dry tropical forests from Mokany et al. 2005 Global Change Biology
+!$OMP THREADPRIVATE(root_shoot_ratio)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: rwc_root    !!  mmol H2O per g of dry root mass dry tropical forests from Mokany et al. 2005 Global Change Biology
+!$OMP THREADPRIVATE(rwc_root)
+ 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: root_density    !! wood density of the roots, g dry mass cm-3 volume  
+!$OMP THREADPRIVATE(root_density)
+  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: LDMC    !! leaf dry matter content (g dry mass g-1 fresh mass),    
+!$OMP THREADPRIVATE(LDMC)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: sla_hydro    !! sla (m2 kg-1), currenly the global mean in the TRY    
+!$OMP THREADPRIVATE(sla_hydro)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: cxyl   !!  stem capacitance, kg m^-3 MPa-1  
+!$OMP THREADPRIVATE(cxyl)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: cr   !!  root capacitance, kg m^-3 MPa-1  
+!$OMP THREADPRIVATE(cr)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: cl   !!  leaf capacitance, mmol m^-2 MPa-1  
+!$OMP THREADPRIVATE(cl)
+
+
+  !
+  ! PRESCRIBE (stomate)
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: tune_reserves_in_sapling  !! A factor to scale the reserve pool of newly
+                                                                      !! planted saplings.  This is required by some deciduous
+                                                                      !! trees in order to survive the first year until budburst,
+                                                                      !! but it has no physical basis.
+                                                                      !! (unitless)
+
+!$OMP THREADPRIVATE(tune_reserves_in_sapling)
+
+  !
+  ! MORTALITY (stomate)
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) &
+                          :: death_distribution_factor              !! The scale factor between the smallest and largest 
+                                                                    !! circ class for tree mortality in lpj_kill.
+                                                                    !! (unitless)
+!$OMP THREADPRIVATE(death_distribution_factor)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) &
+                          :: npp_reset_value                        !! The value of the NPP that the long-term value is
+                                                                    !! reset to after a PFT dies in stomate_kill.  This
+                                                                    !! only seems to be used for non-trees.
+                                                                    !! @tex $(gC m^{-2})$ @endtex
+!$OMP THREADPRIVATE(npp_reset_value)
+
+  !
+  ! FIRE (stomate)
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: flam              !! flamability : critical fraction of water holding 
+                                                                    !! capacity (0-1, unitless)
+!$OMP THREADPRIVATE(flam)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: resist            !! fire resistance (0-1, unitless)
+!$OMP THREADPRIVATE(resist)
+
+
+  !
+  ! FLUX - LUC (Land Use Change)
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: coeff_lcchange_s   !! Coeff of biomass export for the year (unitless)
+!$OMP THREADPRIVATE(coeff_lcchange_s)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: coeff_lcchange_m  !! Coeff of biomass export for the decade (unitless)
+!$OMP THREADPRIVATE(coeff_lcchange_m)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: coeff_lcchange_l !! Coeff of biomass export for the century (unitless)
+!$OMP THREADPRIVATE(coeff_lcchange_l)
+ 
+ 
+  !
+  ! PHENOLOGY
+  !
+  !-
+  ! 1. Stomate
+  !-
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: lai_max           !! maximum LAI, PFT-specific @tex $(m^2.m^{-2})$ @endtex
+!$OMP THREADPRIVATE(lai_max)
+
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pheno_type     !! type of phenology (0-4, unitless)
+                                                                    !! 0=bare ground 1=evergreen,  2=summergreen, 
+                                                                    !! 3=raingreen,  4=perennial
+                                                                    !! For the moment, the bare ground phenotype is not managed, 
+                                                                    !! so it is considered as "evergreen"
+!$OMP THREADPRIVATE(pheno_type)
+
+  !-
+  ! 2. Leaf Onset
+  !-
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:) :: pheno_gdd_crit   !! critical gdd,tabulated (C), used in the code
+!$OMP THREADPRIVATE(pheno_gdd_crit)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pheno_gdd_crit_c   !! critical gdd,tabulated (C), 
+                                                                     !! constant c of aT^2+bT+c (unitless)
+!$OMP THREADPRIVATE(pheno_gdd_crit_c)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pheno_gdd_crit_b   !! critical gdd,tabulated (C), 
+                                                                     !! constant b of aT^2+bT+c (unitless)
+!$OMP THREADPRIVATE(pheno_gdd_crit_b)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pheno_gdd_crit_a   !! critical gdd,tabulated (C), 
+                                                                     !! constant a of aT^2+bT+c (unitless)
+!$OMP THREADPRIVATE(pheno_gdd_crit_a)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: ngd_crit           !! critical ngd,tabulated. Threshold -5 degrees (days)
+!$OMP THREADPRIVATE(ngd_crit)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: opti_kpheno_crit   !! multiplicative factor to use optimised gdd_crit (Natasha MacBean)
+                                                                     !! (unitless)
+!$OMP THREADPRIVATE(opti_kpheno_crit)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: ncdgdd_temp        !! critical temperature for the ncd vs. gdd function
+                                                                     !! in phenology (C)
+!$OMP THREADPRIVATE(ncdgdd_temp)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: hum_frac           !! critical humidity (relative to min/max) for phenology
+                                                                     !! (0-1, unitless)
+!$OMP THREADPRIVATE(hum_frac)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: hum_min_time       !! minimum time elapsed since moisture minimum (days)
+!$OMP THREADPRIVATE(hum_min_time)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: tau_sap            !! turnover sapwood -> heartwood conversion time (1/days)
+!$OMP THREADPRIVATE(tau_sap)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: tau_fruit          !! fruit turnover (1/days)
+!$OMP THREADPRIVATE(tau_fruit)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: tau_root           !! root turnover (1/days)
+!$OMP THREADPRIVATE(tau_root)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: tau_leaf           !! leaf turnover (1/years)
+!$OMP THREADPRIVATE(tau_leaf)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: ecureuil           !! fraction of primary leaf and root allocation put
+                                                                     !! into reserve (0-1, unitless)
+!$OMP THREADPRIVATE(ecureuil)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: alloc_min          !! NEW - allocation above/below = f(age) - 30/01/04 NV/JO/PF
+!$OMP THREADPRIVATE(alloc_min)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: alloc_max          !! NEW - allocation above/below = f(age) - 30/01/04 NV/JO/PF
+!$OMP THREADPRIVATE(alloc_max)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: demi_alloc         !! NEW - allocation above/below = f(age) - 30/01/04 NV/JO/PF
+!$OMP THREADPRIVATE(demi_alloc)
+
+
+  !-
+  ! 3. Senescence
+  !-
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: leaffall              !! length of death of leaves,tabulated (days)
+!$OMP THREADPRIVATE(leaffall)
+
+  CHARACTER(len=6), ALLOCATABLE, SAVE, DIMENSION(:) :: senescence_type  !! type of senescence,tabulated (unitless)
+                                                                        !! List of avaible types of senescence :
+                                                                        !! 'cold  ', 'dry   ', 'mixed ', 'none  '
+!$OMP THREADPRIVATE(senescence_type)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: senescence_hum        !! critical relative moisture availability for senescence
+                                                                        !! (0-1, unitless)
+!$OMP THREADPRIVATE(senescence_hum)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: nosenescence_hum      !! relative moisture availability above which there is
+                                                                        !! no humidity-related senescence (0-1, unitless)
+!$OMP THREADPRIVATE(nosenescence_hum)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: max_turnover_time     !! maximum turnover time for grasses (days)
+!$OMP THREADPRIVATE(max_turnover_time)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: min_turnover_time     !! minimum turnover time for grasses (days)
+!$OMP THREADPRIVATE(min_turnover_time)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: min_leaf_age_for_senescence  !! minimum leaf age to allow senescence g (days)
+!$OMP THREADPRIVATE(min_leaf_age_for_senescence)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:) :: senescence_temp     !! critical temperature for senescence (C),
+                                                                        !! used in the code
+!$OMP THREADPRIVATE(senescence_temp)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: senescence_temp_c     !! critical temperature for senescence (C), 
+                                                                        !! constant c of aT^2+bT+c , tabulated (unitless)
+!$OMP THREADPRIVATE(senescence_temp_c)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: senescence_temp_b     !! critical temperature for senescence (C), 
+                                                                        !! constant b of aT^2+bT+c , tabulated (unitless)
+!$OMP THREADPRIVATE(senescence_temp_b)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: senescence_temp_a     !! critical temperature for senescence (C),
+                                                                        !! constant a of aT^2+bT+c , tabulated (unitless)
+!$OMP THREADPRIVATE(senescence_temp_a)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: gdd_senescence        !! minimum gdd to allow senescence of crops (days)
+!$OMP THREADPRIVATE(gdd_senescence)
+
+  !
+  ! DGVM
+  !
+  ! added by yitong yao 07 Jan 08:37 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: plc_kill_frac     !! fraction 
+  ! added by yitong yao 07 Jan 08:37 above line 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: mor_kill_frac     !! fraction
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: residence_time    !! residence time of trees (y) 
+!$OMP THREADPRIVATE(residence_time)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: tmin_crit         !! critical tmin, tabulated (C)
+!$OMP THREADPRIVATE(tmin_crit)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: tcm_crit          !! critical tcm, tabulated (C)
+!$OMP THREADPRIVATE(tcm_crit)
+
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)   :: mortality_min     !! Asymptotic mortality if plant growth exceeds long term
+                                                                    !! NPP @tex $(year^{-1})$ @endtex
+!$OMP THREADPRIVATE(mortality_min) 
+
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)   :: mortality_max     !! Maximum mortality if plants hardly grows
+                                                                    !! @tex $(year^{-1})$ @endtex
+!$OMP THREADPRIVATE(mortality_max) 
+
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)   :: ref_mortality     !! Reference mortality rate used to calculate mortality
+                                                                    !! as a function of the plant vigor @tex $(year^{-1})$ @endtex
+!$OMP THREADPRIVATE(ref_mortality) 
+
+  !
+  ! Seasonal average
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: tau_hum_growingseason !! Time integral to calculate the mean growingseason
+                                                                        !! plant available soilmoisture (days)
+!$OMP THREADPRIVATE(tau_hum_growingseason)
+
+
+  !
+  ! Biogenic Volatile Organic Compounds
+  !
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: em_factor_isoprene       !! Isoprene emission factor
+                                                                           !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+!$OMP THREADPRIVATE(em_factor_isoprene)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: em_factor_monoterpene    !! Monoterpene emission factor
+                                                                           !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+!$OMP THREADPRIVATE(em_factor_monoterpene)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: em_factor_ORVOC          !! ORVOC emissions factor
+                                                                           !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+!$OMP THREADPRIVATE(em_factor_ORVOC)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: em_factor_OVOC           !! OVOC emissions factor
+                                                                           !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+!$OMP THREADPRIVATE(em_factor_OVOC)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: em_factor_MBO            !! MBO emissions factor 
+                                                                           !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+!$OMP THREADPRIVATE(em_factor_MBO)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: em_factor_methanol       !! Methanol emissions factor
+                                                                           !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+!$OMP THREADPRIVATE(em_factor_methanol)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: em_factor_acetone        !! Acetone emissions factor 
+                                                                           !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+!$OMP THREADPRIVATE(em_factor_acetone)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: em_factor_acetal         !! Acetaldehyde emissions factor
+                                                                           !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+!$OMP THREADPRIVATE(em_factor_acetal)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: em_factor_formal         !! Formaldehyde emissions factor
+                                                                           !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+!$OMP THREADPRIVATE(em_factor_formal)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: em_factor_acetic         !! Acetic Acid emissions factor 
+                                                                           !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+!$OMP THREADPRIVATE(em_factor_acetic)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: em_factor_formic         !! Formic Acid emissions factor 
+                                                                           !! @tex $(\mu gC.g^{-1}.h^{-1})$ @endtex
+!$OMP THREADPRIVATE(em_factor_formic)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: em_factor_no_wet         !! NOx emissions factor soil emissions and 
+                                                                           !! exponential dependancy factor for wet soils
+                                                                           !! @tex $(ngN.m^{-2}.s^{-1})$ @endtex
+!$OMP THREADPRIVATE(em_factor_no_wet)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: em_factor_no_dry         !! NOx emissions factor soil emissions and
+                                                                           !! exponential dependancy factor for dry soils
+                                                                           !! @tex $(ngN.m^{-2}.s^{-1})$ @endtex
+!$OMP THREADPRIVATE(em_factor_no_dry)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: Larch                    !! Larcher 1991 SAI/LAI ratio (unitless)
+!$OMP THREADPRIVATE(Larch)
+
+  !
+  ! INTERNAL PARAMETERS USED IN STOMATE_DATA
+  !
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: lai_initmin   !! Initial lai for trees/grass 
+                                                                !! @tex $(m^2.m^{-2})$ @endtex
+!$OMP THREADPRIVATE(lai_initmin)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: bm_sapl_old   !! sapling biomass for the OLD allocation
+                                                                    !! @tex $(gC.ind^{-1})$ @endtex
+!$OMP THREADPRIVATE(bm_sapl_old)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: migrate       !! migration speed @tex $(m.year^{-1})$ @endtex
+!$OMP THREADPRIVATE(migrate)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: maxdia        !! maximum stem diameter from which on crown area no longer 
+                                                                !! increases (m)
+!$OMP THREADPRIVATE(maxdia)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: cn_sapl       !! crown of tree when sapling  @tex $(m^2$)$ @endtex
+!$OMP THREADPRIVATE(cn_sapl)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: leaf_timecst  !! time constant for leaf age discretisation (days)
+!$OMP THREADPRIVATE(leaf_timecst)
+ 
+  !
+  ! FOREST MANAGEMENT
+  !
+
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:)     :: plantation        !!
+!$OMP THREADPRIVATE(plantation)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: fm_allo_a         !!
+!$OMP THREADPRIVATE(fm_allo_a)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: fm_allo_c         !! 
+!$OMP THREADPRIVATE(fm_allo_c)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: fm_allo_d         !!
+!$OMP THREADPRIVATE(fm_allo_d)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: fm_allo_p         !!
+!$OMP THREADPRIVATE(fm_allo_p)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: fm_allo_q         !!
+!$OMP THREADPRIVATE(fm_allo_q)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: allo_crown_a0     !!
+!$OMP THREADPRIVATE(fm_allo_a0)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: allo_crown_a1     !!
+!$OMP THREADPRIVATE(fm_allo_a1)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: allo_crown_a2     !!
+!$OMP THREADPRIVATE(fm_allo_a2)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: h_first           !!
+!$OMP THREADPRIVATE(h_first)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: nmaxtrees      !! Intial number of seedlings per hectare. Used 
+                                                                    !! in prescribe to initialize the model and after 
+                                                                    !! every clearcut
+!$OMP THREADPRIVATE(nmaxtrees)
+
+! The following two variables are used to define the range of sapling heights for a newly cleared plot
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: height_init_min   !! The minimum height of a tree sapling when a forest 
+                                                                    !! stand is established. Owing to the allometric 
+                                                                    !! relationship this setting determines all
+                                                                    !! biomass components of a newly establised stand
+                                                                    !! @tex $(m)$ @endtex
+!$OMP THREADPRIVATE(height_init_min)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: height_init_max   !! The maximum height of a tree sapling when a forest 
+                                                                    !! stand is established. 
+                                                                    !! @tex $(m)$ @endtex
+!$OMP THREADPRIVATE(height_init_max)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: alpha_self_thinning !! Coefficient of the self-thinning relationship D=alpha*N^beta 
+                                                                    !! estimated from German, French, Spanish and Swedish 
+                                                                    !! forest inventories
+!$OMP THREADPRIVATE(alpha_self_thinning)
+ 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: beta_self_thinning!! Exponent of the self-thinning relationship D=alpha*N^beta 
+                                                                    !! estimated from German, French, Spanish and swedish
+                                                                    !! forest inventories
+!$OMP THREADPRIVATE(beta_self_thinning)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: fuelwood_diameter !! Diameter below which the wood harvest is used as fuelwood (m)
+                                                                    !! Affects the way the wood is used in the dim_product_use
+                                                                    !! subroutine         
+!$OMP THREADPRIVATE(fuelwood_diameter)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: coppice_kill_be_wood !! Diameter below which the wood harvest is used as fuelwood (m)
+!$OMP THREADPRIVATE(coppice_kill_be_wood)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: thinstrat         !! The thinning strategy used for forest management.
+                                                                    !! Comes from Eq. 12 of Bellassen et al (2010)
+                                                                    !! @tex $(unitless)$ @endtex
+!$OMP THREADPRIVATE(thinstrat) 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: taumin            !! Minimum tree death probability. stomate_forest.f90
+                                                                    !! Comes from Eq. 12 of Bellassen et al (2010)
+                                                                    !! @tex $(unitless)$ @endtex
+!$OMP THREADPRIVATE(taumin) 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: taumax            !! Maximum tree death probability. stomate_forest.f90
+                                                                    !! Comes from Eq. 12 of Bellassen et al (2010)
+                                                                    !! @tex $(unitless)$ @endtex
+!$OMP THREADPRIVATE(taumax) 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: alpha_rdi_upper   !! Coefficient of the yield-table derived thinning relationship
+                                                                    !! D=alpha*N^beta estimated from JRC yield table database
+!$OMP THREADPRIVATE(alpha_rdi_upper)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: beta_rdi_upper    !! Coefficient of the yield-table derived thinning relationship
+                                                                    !! D=alpha*N^beta estimated from JRC yield table database
+!$OMP THREADPRIVATE(beta_rdi_upper)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: alpha_rdi_lower   !! Coefficient of the yield-table derived thinning relationship
+                                                                    !! D=alpha*N^beta estimated from JRC yield table database
+!$OMP THREADPRIVATE(alpha_rdi_lower) 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: beta_rdi_lower    !! Coefficient of the yield-table derived thinning relationship
+                                                                    !! D=alpha*N^beta estimated from JRC yield table database
+!$OMP THREADPRIVATE(beta_rdi_lower)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: dens_target       !! The minimum density of trees in a stand before
+                                                                    !! they all die off and we replant.  This is to prevent
+                                                                    !! the stand from becoming just one large tree.
+                                                                    !! @tex $(trees ha{-1})$ @endtex
+!$OMP THREADPRIVATE(dens_target) 
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: largest_tree_dia !! The diameter at which we decide to clearcut
+                                                                    !! a stand because our equipment cannot handle
+                                                                    !! trees larger than this.
+                                                                    !! @tex $(cm)$ @endtex
+!$OMP THREADPRIVATE(largest_tree_dia)
+                                 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: branch_ratio      !! branches/total aboveground biomass ratio
+                                                                    !! (cf carbofor for CITEPA inventory, these 
+                                                                    !! Guerric, Lim 2004, Peischl 2007, 
+                                                                    !! Schulp 2008: 15-30% slash after harvest,
+                                                                    !! Zaehle 2007: 30% slash after harvest)
+!$OMP THREADPRIVATE(branch_ratio)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: branch_harvest    !! The fraction of branches which are harvested
+                                                                    !! during thinning and clearcut operations on 
+                                                                    !! forests.  1.0 means all branches are taken offsite,
+                                                                    !! 0.0 means all branches are left onsite and go
+                                                                    !! into the litter pool.  This number is not
+                                                                    !! based on any data.
+!$OMP THREADPRIVATE(branch_harvest)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: decl_factor       !! Age_decline factor in fraction of vmax decline per year
+                                                                    !! (yield tables > 130 years : inc90=0.8inc50, 
+                                                                    !! inc130=0.55inc50, 
+                                                                    !! same for broadleaves and coniferous. 
+                                                                    !! For temperate pfts, calibration on one site to get a 0.55 
+                                                                    !! increment decrease. 
+                                                                    !! For boreal pfts, calibration to get an average 0.55 
+                                                                    !! increment decrease over 25,7 and 2 sites: Adam Wolf dataset)
+!$OMP THREADPRIVATE(decl_factor)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)    :: opt_factor     !! Optimisation factor for vcmax and vjmax
+!$OMP THREADPRIVATE(opt_factor)                    
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)    :: coppice_diameter !! The trunk diameter at which a coppice will be cut.
+                                                                    !! @tex $(m)$ @endtex
+!$OMP THREADPRIVATE(coppice_diameter)  
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: shoots_per_stool !! The number of shoots that regrow per stool after
+                                                                    !! the first coppice cut
+                                                                    !! @tex $-$ @endtex
+!$OMP THREADPRIVATE(shoots_per_stool) 
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: src_rot_length !! The number of years between cuttings for short
+                                                                    !! rotation coppices.
+                                                                    !! @tex $-$ @endtex
+!$OMP THREADPRIVATE(src_rot_length) 
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: src_nrots      !! The number of rotations for short rotations coppices
+                                                                    !! before the roots are killed and replanted.
+                                                                    !! @tex $-$ @endtex
+!$OMP THREADPRIVATE(src_nrots) 
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)    :: deleuze_a      !! intercept of the intra-tree competition within a stand
+                                                                    !! based on the competion rule of Deleuze and Dhote 2004
+                                                                    !! Used when n_circ > 6
+!$OMP THREADPRIVATE(deleuze_a)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)    :: deleuze_b      !! slope of the intra-tree competition within a stand
+                                                                    !! based on the competion rule of Deleuze and Dhote 2004
+                                                                    !! Used when n_circ > 6
+!$OMP THREADPRIVATE(deleuze_b)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)    :: deleuze_p_all  !! Percentile of the circumferences that receives photosynthates
+                                                                    !! based on the competion rule of Deleuze and Dhote 2004
+                                                                    !! Used when n_circ > 6 for FM1, FM2 and FM4 
+!$OMP THREADPRIVATE(deleuze_p_all)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)    :: deleuze_p_coppice  !! Percentile of the circumferences that receives photosynthates
+                                                                    !! based on the competion rule of Deleuze and Dhote 2004
+                                                                    !! Used when n_circ > 6 for FM3
+!$OMP THREADPRIVATE(deleuze_p_coppice)
+
+
+! SAPIENS - CROP MANAGEMENT
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)    :: harvest_ratio  !! Share of biomass that is removed from the site during harvest
+                                                                    !! A high value indicates a high harvest efficiency and thus a 
+                                                                    !! input of residuals. (unitless, 0-1).
+
+!$OMP THREADPRIVATE(harvest_ratio)
+
+
+! STOMATE - Age classes
+
+  INTEGER(i_std), SAVE                            :: nvmap          !! The number of PFTs we have if we ignore age classes.
+                                                                    !! @tex $-$ @endtex
+!$OMP THREADPRIVATE(nvmap) 
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: agec_group     !! The age class group that this PFT belongs to.
+                                                                    !! If you're not using age classes, this will just be
+                                                                    !! set to the number of the PFT and should be ignored
+                                                                    !! in the code.
+                                                                    !! @tex $-$ @endtex
+!$OMP THREADPRIVATE(agec_groups) 
+! I do not like the location of these next two variables.  They are computed
+! after agec_group is read in.  Ideally, they would be passed around
+! as arguments or in a structure, since they are not really
+! parameters read in from the input file.
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: start_index    !! Gives the index that this real PFT starts
+                                                                    !! on, ignoring age classes
+                                                                    !! @tex $-$ @endtex
+!$OMP THREADPRIVATE(start_index) 
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: nagec_pft      !! The number of age classes for each PFT.
+                                                                    !! Only 1 or nagec are supported right now.
+                                                                    !! @tex $-$ @endtex
+!$OMP THREADPRIVATE(nagec_pft) 
+
+
+END MODULE pft_parameters_var
Index: branches/publications/ORCHIDEE_CAN_NHA/src_parameters/structures.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_parameters/structures.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_parameters/structures.f90	(revision 7236)
@@ -0,0 +1,105 @@
+! =================================================================================================================================
+! MODULE       : structures
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        Contains structures and types used throughout the code
+!!
+!!\n DESCRIPTION: In this module, structural types should be declared.  There are
+!!                also routines for allocating and deallocating the memory in structures,
+!!                if necessary.
+!!
+!! RECENT CHANGE(S): 
+!!
+!! REFERENCE(S)	: 
+!!
+!! SVN          :
+!! $HeadURL: $
+!! $Date: 2013-09-25 17:38:26 +0200 (Wed, 25 Sep 2013) $
+!! $Revision: 1480 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE structures
+
+  USE defprec
+  USE constantes
+  USE pft_parameters
+!-
+  IMPLICIT NONE
+!-
+
+  ! The purpose of this structure is to contain all
+  ! the information needed to fit the effective LAI
+  ! as a function of the solar angle.  Doing this
+  ! as a structure means that we can change which
+  ! function we fit to more easily.  We will have
+  ! to allocate this for every grid cell, PFT, and
+  ! level.
+  INTEGER,PARAMETER :: nparams_laieff = 5 ! The number of parameters in the structure below
+  TYPE laieff_type
+     REAL(r_std) :: a,b,c,d,e          !! We do a polynomial fit, a+b*x+c*x**2+d*x**3+e*x**4
+  END type laieff_type
+
+
+ CONTAINS
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : laieff_type_init
+!!
+!>\BRIEF        Set the values for all the parameters of this type to zero.
+!!
+!! DESCRIPTION  : 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::laieff_type
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!!
+!!
+!!
+!_ ================================================================================================================================
+
+   SUBROUTINE laieff_type_init(npts, nlevels_loc, laieff_fit)
+
+     !! 0. Variable and parameter declaration
+
+     !! 0.1 Input variables
+     INTEGER(i_std), INTENT(in)                                :: npts        !! Domain size - Number of land pixels  (unitless)       
+     INTEGER(i_std), INTENT(in)                                :: nlevels_loc     !! The number of vertical levels in the canopy (unitless)    
+     !! 0.2 Output variables
+     
+     !! 0.3 Modified variables
+     TYPE(laieff_type),DIMENSION (:,:,:),INTENT(inout)    :: laieff_fit      !! Fitted parameters for the effective LAI
+   
+     !! 0.4 Local variables
+
+     INTEGER :: ipts,ivm,ilevel
+
+!_ ================================================================================================================================
+
+     DO ipts=1,npts
+        DO ivm=1,nvm
+           DO ilevel=1,nlevels_loc
+              laieff_fit(ipts,ivm,ilevel)%a=zero
+              laieff_fit(ipts,ivm,ilevel)%b=zero
+              laieff_fit(ipts,ivm,ilevel)%c=zero
+              laieff_fit(ipts,ivm,ilevel)%d=zero
+              laieff_fit(ipts,ivm,ilevel)%e=zero
+           ENDDO
+        ENDDO
+     ENDDO
+
+
+   END SUBROUTINE laieff_type_init
+
+
+
+ END MODULE structures
Index: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/AA_make
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/AA_make	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/AA_make	(revision 7236)
@@ -0,0 +1,192 @@
+#-
+#- $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 =              \
+  albedo.f90        \
+  qsat_moisture.f90 \
+  sechiba_io_p.f90   \
+  sechiba_io.f90     \
+  watchout.f90       \
+  slowproc.f90       \
+  diffuco.f90        \
+  condveg.f90        \
+  enerbil.f90        \
+  hydrol.f90         \
+  hydrolc.f90        \
+  sechiba_hydrol_arch.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
+	$(A_C) $(ORCHIDEE_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)(pft_parameters.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)(sechiba_hydrol_arch.o)  \
+  $(MODEL_LIB)(thermosoil.o)      \
+  $(MODEL_LIB)(slowproc.o)        \
+  $(MODEL_LIB)(routing.o)
+ 
+$(MODEL_LIB)(sechiba_io_p.o): \
+  $(PARAM_LIB)(constantes.o)  \
+  $(PARALLEL_LIB)(mod_orchidee_para.o)
+
+$(MODEL_LIB)(sechiba_io.o): \
+  $(MODEL_LIB)(sechiba_io_p.o) \
+  $(PARAM_LIB)(constantes.o)
+
+$(MODEL_LIB)(watchout.o): \
+  $(ORGLOB_LIB)(grid.o)
+
+$(MODEL_LIB)(albedo.o):           \
+  $(PARAM_LIB)(constantes.o)  \
+  $(STOMATE_LIB)(stomate_laieff.o)
+
+$(MODEL_LIB)(hydrol.o):           \
+  $(PARAM_LIB)(constantes.o)  \
+  $(MODEL_LIB)(sechiba_io.o)      \
+  $(ORGLOB_LIB)(grid.o)
+
+$(MODEL_LIB)(hydrolc.o):          \
+  $(PARAM_LIB)(constantes.o)  \
+  $(MODEL_LIB)(sechiba_io.o)
+
+$(MODEL_LIB)(sechiba_hydrol_arch.o):       \
+  $(PARAM_LIB)(constantes.o)       \
+  $(PARAM_LIB)(pft_parameters.o)   \
+  $(MODEL_LIB)(sechiba_io.o)       \
+  $(STOMATE_LIB)(stomate.o)       
+
+$(MODEL_LIB)(slowproc.o):         \
+  $(PARAM_LIB)(pft_parameters.o)  \
+  $(STOMATE_LIB)(stomate.o)       \
+  $(MODEL_LIB)(sechiba_io.o)      \
+  $(ORGLOB_LIB)(interpol_help.o)
+
+$(MODEL_LIB)(diffuco.o):          \
+  $(PARAM_LIB)(pft_parameters.o)  \
+  $(MODEL_LIB)(qsat_moisture.o)  \
+  $(MODEL_LIB)(sechiba_io.o)
+
+$(MODEL_LIB)(enerbil.o):          \
+  $(PARAM_LIB)(constantes.o)      \
+  $(MODEL_LIB)(qsat_moisture.o)   \
+  $(MODEL_LIB)(sechiba_io.o)
+
+$(MODEL_LIB)(condveg.o):          \
+  $(MODEL_LIB)(albedo.o)   \
+  $(PARAM_LIB)(constantes.o)  \
+  $(PARAM_LIB)(constantes_soil.o)  \
+  $(PARAM_LIB)(pft_parameters.o)  \
+  $(ORGLOB_LIB)(interpol_help.o)
+
+$(MODEL_LIB)(thermosoil.o): \
+  $(PARAM_LIB)(constantes.o)  \
+  $(MODEL_LIB)(sechiba_io.o)
+
+$(MODEL_LIB)(routing.o):          \
+  $(PARAM_LIB)(constantes.o)  \
+  $(MODEL_LIB)(sechiba_io.o)
+
+$(MODEL_LIB)(intersurf.o):   \
+  $(PARAM_LIB)(constantes.o)  \
+  $(ORGLOB_LIB)(grid.o)      \
+  $(MODEL_LIB)(watchout.o)   \
+  $(MODEL_LIB)(thermosoil.o) \
+  $(MODEL_LIB)(sechiba.o)
+
Index: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/AA_make.ldef
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/AA_make.ldef	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/AA_make.ldef	(revision 7236)
@@ -0,0 +1,19 @@
+#-
+#- $Id$
+#-
+#---------------------------------------------------------------------
+#- Creation des elements relatifs a SECHIBA
+#---------------------------------------------------------------------
+SHELL = /bin/sh
+#---------------------------------------------------------------------
+LIBDIR = ../../../lib
+BINDIR = ../../../bin
+MODDIR = $(LIBDIR)
+#---------------------------------------------------------------------
+ORCHIDEE_LIB = $(LIBDIR)/liborchidee.a
+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: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/albedo.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/albedo.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/albedo.f90	(revision 7236)
@@ -0,0 +1,2209 @@
+! ===============================================================================================================================
+! MODULE       : albedo
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        Calculate the surface albedo using a variety of different schemes
+!!
+!! \n DESCRIPTION : This module includes the mechanisms for
+!! 1. :: albedo_calc for computing the albedo with the old method (need to ask
+!!           someone what exactly this is from)...the simplest version
+!!           this does not distinguish between diffuse and direct, but can 
+!!           distinguish between NIR and VIS
+!! 2. :: albedo_two_stream computes the two_stream approach of Pinty et al 2006.
+!!           Requires an effective leaf area index and depends on the solar angle.
+!!           Separates light into NIR and VIS, and diffuse and direct illumination
+!! 3. :: calculate_surface_albedo_with_snow is a way to calculate the snow albedo 
+!!           based on the method of Chalita and Treut (1994)
+!!           This does not distinguish between NIR and VIR light, nor diffuse 
+!!           and direct, and should probably only be used with albedo_calc
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCES(S)    : 
+!!                    Chalita, S. and H Le Treut (1994), The albedo of temperate
+!!                    and boreal forest and the Northern Hemisphere climate: a 
+!!                    sensitivity experiment using the LMD GCM, 
+!!                    Climate Dynamics, 10 231-240.
+!!
+!!                    B. Pinty, T. Lavergne, R.E. Dickinson, J-L. Widlowski, 
+!!                    N. Gobron and M. M. Verstraete (2006). Simplifying the 
+!!                    Interaction of Land Surfaces with Radiation for Relating 
+!!                    Remote Sensing Products to Climate Models. Journal of 
+!!                    Geophysical Research. Vol 111, D02116.
+!!
+!! SVN              :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/perso/matthew.mcgrath/TRUNK/ORCHIDEE/src_sechiba/albedo.f90 $
+!! $Date: 2012-07-19 15:12:52 +0200 (Thu, 1 Nov 2012) $
+!! $Revision: 947 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE albedo
+  !
+  USE ioipsl
+  !
+  ! modules used :
+  USE constantes
+  USE constantes_soil
+  USE pft_parameters
+  USE structures
+  USE interpol_help
+  USE ioipsl_para
+  USE stomate_laieff
+
+  IMPLICIT NONE
+
+  PRIVATE :: print_debugging_albedo_info,calculate_snow_albedo,&
+       twostream_solver,gammas
+  ! public routines :
+  PUBLIC :: albedo_calc, albedo_two_stream, calculate_surface_albedo_with_snow
+
+  !
+  ! variables used inside albedo module : declaration and initialisation
+  !
+                                                                        
+
+CONTAINS
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : albedo_calc
+!!
+!>\BRIEF        This subroutine calculates the albedo without snow.
+!!
+!! DESCRIPTION  : The albedo is calculated for both the visible and near-infrared 
+!! domain. First the mean albedo of the bare soil is calculated. Two options exist: 
+!! either the soil albedo depends on soil wetness (drysoil_frac variable), or the 
+!! soil albedo is set to a mean soil albedo value.  It should be noted that this 
+!! routine essential separates vegetated land into 1) 100Ã¹ plant covered and 2) 
+!! bare soil parts, and calculates the albedo for them seperately.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): albedo 
+!!
+!! REFERENCE(S) : Krinner, G., Viovy, N., Noblet-Ducoudre, N. de, Ogee, J., Polcher, 
+!!                J., Friedlingstein, P., Ciais, P., Sitch, S., and Prentice, I. C 
+!!                (2005). A dynamic global vegetation model for studies of the 
+!!                coupled atmosphere-biosphere system. Global Biogeochem. Cycles, 19, GB1015.
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE albedo_calc (npts, drysoil_frac, veget, soilalb_dry, &
+          soilalb_wet, soilalb_moy, tot_bare_soil, alb_veget, &
+          alb_bare, albedo)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+ 
+    INTEGER(i_std), INTENT(in)                       :: npts       !! Domain size - Number of land pixels  (unitless)
+    REAL(r_std), DIMENSION(npts), INTENT(in)     :: drysoil_frac   !! Fraction of  dry soil (unitless) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in) :: veget          !! PFT coverage fraction of a PFT (= ind*cn_ind) 
+                                                                       !! (m^2 m^{-2})        
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)   :: soilalb_dry    !! Albedo values for the dry bare soil (unitless)
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)   :: soilalb_wet    !! Albedo values for the wet bare soil (unitless)
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)   :: soilalb_moy    !! Albedo values for the mean bare soil (unitless)
+    REAL(r_std), DIMENSION (npts), INTENT(in)    :: tot_bare_soil  !! total evaporating bare soil fraction 
+    
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(npts,2), INTENT(out)  :: alb_veget      !! Mean vegetation albedo for visible and 
+                                                                       !! near-infrared range (unitless) 
+    REAL(r_std), DIMENSION(npts,2), INTENT(out)  :: alb_bare       !! Mean bare soil albedo for visible and near-infrared
+    REAL(r_std),DIMENSION (npts,2), INTENT (out) :: albedo         !! Albedo for visible and near-infrared range 
+                                                                       !! (unitless)   
+ 
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+ 
+    REAL(r_std),DIMENSION (nvm,2)                    :: alb_leaf_tmp   !! Variable for albedo values for all PFTs and 
+                                                                       !! spectral domains (unitless) 
+    INTEGER(i_std)                                   :: ks             !! Index for visible and near-infraread range
+    INTEGER(i_std)                                   :: jv             !! Index for vegetative PFTs
+!_ ================================================================================================================================
+    
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering albedo_calc'
+
+    !! 1. Preliminary calculation
+    
+    ! Assign values of leaf albedo for visible and near-infrared range
+    ! to local variable (constantes_veg.f90)
+    alb_leaf_tmp(:,ivis) = alb_leaf_vis(:)
+    alb_leaf_tmp(:,inir) = alb_leaf_nir(:)
+
+    !! 2. Calculation and assignment of soil albedo
+
+    DO ks = 1, 2! Loop over # of spectra
+
+       ! If 'alb_bare_model' is set to TRUE,  the soil albedo calculation depends
+       ! on soil moisture
+       ! If 'alb_bare_model' is set to FALSE, the mean soil albedo is used without
+       ! the dependance on soil moisture
+       ! see subroutine 'conveg_soilalb'
+       IF ( alb_bare_model ) THEN
+          alb_bare(:,ks) = soilalb_wet(:,ks) + drysoil_frac(:) * &
+               (soilalb_dry(:,ks) -  soilalb_wet(:,ks))
+       ELSE
+          alb_bare(:,ks) = soilalb_moy(:,ks)
+       ENDIF
+
+       ! Soil albedo is weighed by fraction of bare soil          
+       albedo(:,ks) = tot_bare_soil(:) * alb_bare(:,ks)
+
+       !! 3. Calculation of mean albedo of over the grid cell 
+
+       ! Calculation of mean albedo of over the grid cell and
+       !    mean albedo of only vegetative PFTs over the grid cell
+       alb_veget(:,ks) = zero
+
+       DO jv = 2, nvm  ! Loop over # of PFTs
+
+          ! Mean albedo of grid cell for visible and near-infrared range
+          albedo(:,ks) = albedo(:,ks) + veget(:,jv)*alb_leaf_tmp(jv,ks)
+
+          ! Mean albedo of vegetation for visible and near-infrared range
+          alb_veget(:,ks) = alb_veget(:,ks) + veget(:,jv)*alb_leaf_tmp(jv,ks)
+       ENDDO ! Loop over # of PFTs
+
+    ENDDO ! ks = 1, 2
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving albedo_calc'
+
+  END SUBROUTINE albedo_calc
+
+!! ==============================================================================================================================\n
+!! SUBROUTINE   : calculate_surface_albedo_with_snow
+!!
+!>\BRIEF        Calcuating snow albedo and snow cover fraction, which are then used to 
+!! update the gridbox surface albedo following Chalita and Treut (1994).  This is the old
+!! condveg_snow routine, and is only used for calculated the snow albedo with the old
+!! albedo scheme.
+!!
+!! DESCRIPTION  : The snow albedo scheme presented below belongs to prognostic albedo 
+!! category, i.e. the snow albedo value at a time step depends on the snow albedo value 
+!! at the previous time step.
+!!
+!! First, the following formula (described in Chalita and Treut 1994) is used to describe 
+!! the change in snow albedo with snow age on each PFT and each non-vegetative surfaces, 
+!! i.e. continental ice, lakes, etc.: \n 
+!! \latexonly 
+!! \input{SnowAlbedo.tex}
+!! \endlatexonly
+!! \n
+!! Where snowAge is snow age, tcstSnowa is a critical aging time (tcstSnowa=5 days)
+!! snowaIni and snowaIni+snowaDec corresponds to albedos measured for aged and
+!! fresh snow respectively, and their values for each PFT and each non-vegetative surfaces 
+!! is precribed in in constantes_veg.f90.\n
+!! In order to estimate gridbox snow albedo, snow albedo values for each PFT and 
+!! each  non-vegetative surfaces with a grid box are weightedly summed up by their 
+!! respective fractions.\n
+!! Secondly, the snow cover fraction is computed as:
+!! \latexonly 
+!! \input{SnowFraction.tex}
+!! \endlatexonly
+!! \n
+!! Where fracSnow is the fraction of snow on total vegetative or total non-vegetative
+!! surfaces, snow is snow mass (kg/m^2) on total vegetated or total nobio surfaces.\n 
+!! Finally, the surface albedo is then updated as the weighted sum of fracSnow, total
+!! vegetated fraction, total nobio fraction, gridbox snow albedo, and previous
+!! time step surface albedo.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): :: albedo; surface albedo. :: albedo_snow; snow
+!! albedo
+!!
+!! REFERENCE(S) :  
+!! Chalita, S. and H Le Treut (1994), The albedo of temperate and boreal forest and 
+!!  the Northern Hemisphere climate: a sensitivity experiment using the LMD GCM,
+!!  Climate Dynamics, 10 231-240.
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE  calculate_surface_albedo_with_snow  (npts,  veget,  veget_max, &
+           frac_nobio,  totfrac_nobio,  snow,  snow_age, &
+           snow_nobio,  snow_nobio_age,  tot_bare_soil,  albedo, &
+           albedo_snow,  albedo_glob)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                          :: npts        !! Domain size - Number of land pixels  (unitless)
+    REAL(r_std),DIMENSION (npts,nvm), INTENT (in)   :: veget           !! PFT coverage fraction of a PFT (= ind*cn_ind) 
+                                                                           !! (m^2 m^{-2})   
+    REAL(r_std),DIMENSION (npts,nvm), INTENT(in)    :: veget_max
+    REAL(r_std),DIMENSION (npts,nnobio), INTENT(in) :: frac_nobio      !! Fraction of non-vegetative surfaces, i.e. 
+                                                                           !! continental ice, lakes, etc. (unitless)     
+    REAL(r_std),DIMENSION (npts), INTENT(in)        :: totfrac_nobio   !! Total fraction of non-vegetative surfaces, i.e. 
+                                                                           !! continental ice, lakes, etc. (unitless)   
+    REAL(r_std),DIMENSION (npts), INTENT(in)        :: snow            !! Snow mass in vegetation (kg m^{-2})           
+    REAL(r_std),DIMENSION (npts,nnobio), INTENT(in) :: snow_nobio      !! Snow mass on continental ice, lakes, etc. (kg m^{-2})      
+    REAL(r_std),DIMENSION (npts), INTENT(in)        :: snow_age        !! Snow age (days)        
+    REAL(r_std),DIMENSION (npts,nnobio), INTENT(in) :: snow_nobio_age  !! Snow age on continental ice, lakes, etc. (days)    
+    REAL(r_std), DIMENSION (npts), INTENT(in)       :: tot_bare_soil  !! total evaporating bare soil fraction 
+
+    !! 0.2 Output variables
+    
+    REAL(r_std),DIMENSION (npts,2), INTENT (inout)  :: albedo          !! Albedo (unitless ratio)          
+    REAL(r_std),DIMENSION (npts), INTENT (out)      :: albedo_snow     !! Snow albedo (unitless ratio)     
+    REAL(r_std),DIMENSION (npts), INTENT (out)      :: albedo_glob     !! Mean albedo (unitless ratio)     
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+ 
+    INTEGER(i_std)                                      :: ji, jv, jb      !! indices (unitless)
+    REAL(r_std), DIMENSION(npts)                    :: frac_snow_veg   !! Fraction of snow on vegetation (unitless ratio)
+    REAL(r_std), DIMENSION(npts,nnobio)             :: frac_snow_nobio !! Fraction of snow on continental ice, lakes, etc. 
+                                                                           !! (unitless ratio)
+    REAL(r_std), DIMENSION(npts)                    :: snowa_veg       !! Albedo of snow covered area on vegetation
+                                                                           !! (unitless ratio)
+    REAL(r_std), DIMENSION(npts,nnobio)             :: snowa_nobio     !! Albedo of snow covered area on continental ice, 
+                                                                           !! lakes, etc. (unitless ratio)     
+    REAL(r_std), DIMENSION(npts)                    :: fraction_veg    !! Total vegetation fraction (unitless ratio)
+    REAL(r_std), DIMENSION(npts)                    :: agefunc_veg     !! Age dependency of snow albedo on vegetation 
+                                                                           !! (unitless)
+    REAL(r_std), DIMENSION(npts,nnobio)             :: agefunc_nobio   !! Age dependency of snow albedo on ice, 
+                                                                           !! lakes, .. (unitless)
+    REAL(r_std)                                         :: alb_nobio       !! Albedo of continental ice, lakes, etc. 
+                                                                           !!(unitless ratio)
+!_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering calculate_surface_albedo_with_snow '
+
+    !! 1.Reset output variable (::albedo_snow ::albedo_glob) 
+    
+    DO ji = 1, npts
+       albedo_snow(ji) = zero
+       albedo_glob(ji) = zero
+    ENDDO
+
+    !! 2. Calculate snow albedos on both total vegetated and total nobio surfaces
+
+    ! The snow albedo could be either prescribed (in condveg_init.f90) or 
+    !  calculated following Chalita and Treut (1994).
+    ! Check if the precribed value fixed_snow_albedo exists
+    IF (ABS(fixed_snow_albedo - undef_sechiba) .GT. EPSILON(undef_sechiba)) THEN
+       snowa_veg(:) = fixed_snow_albedo
+       snowa_nobio(:,:) = fixed_snow_albedo
+    ELSE ! calculated following Chalita and Treut (1994)
+
+       !! 2.1 Calculate age dependence
+
+       ! On vegetated surfaces
+       DO ji = 1, npts
+          agefunc_veg(ji) = EXP(-snow_age(ji)/tcst_snowa)
+       ENDDO
+
+       ! On non-vegtative surfaces
+       DO jv = 1, nnobio ! Loop over # nobio types
+          DO ji = 1, npts
+             agefunc_nobio(ji,jv) = EXP(-snow_nobio_age(ji,jv)/tcst_snowa)
+          ENDDO
+       ENDDO
+
+       !! 2.1 Calculate snow albedo 
+
+       ! For  vegetated surfaces
+       fraction_veg(:) = un - totfrac_nobio(:)
+       snowa_veg(:) = zero
+       IF (control%ok_dgvm) THEN
+          DO ji = 1, npts
+             IF ( fraction_veg(ji) .GT. min_sechiba ) THEN
+                snowa_veg(ji) = snowa_veg(ji) + &
+                     tot_bare_soil(ji)/fraction_veg(ji) * &
+                     ( snowa_aged(1)+snowa_dec(1)*agefunc_veg(ji) )
+             ENDIF
+          ENDDO
+
+          DO jv = 2, nvm
+             DO ji = 1, npts
+                IF ( fraction_veg(ji) .GT. min_sechiba ) THEN
+                   snowa_veg(ji) = snowa_veg(ji) + &
+                        veget(ji,jv)/fraction_veg(ji) * &
+                        ( snowa_aged(jv)+snowa_dec(jv)*agefunc_veg(ji) )
+                ENDIF
+             ENDDO
+          ENDDO
+       ELSE
+          DO jv = 1, nvm
+             DO ji = 1, npts
+                IF ( fraction_veg(ji) .GT. min_sechiba ) THEN
+                   snowa_veg(ji) = snowa_veg(ji) + &
+                        veget_max(ji,jv)/fraction_veg(ji) * &
+                        ( snowa_aged(jv)+snowa_dec(jv)*agefunc_veg(ji) )
+                ENDIF
+             ENDDO
+          ENDDO
+       ENDIF ! control%ok_dgvm
+       !
+       ! snow albedo on other surfaces
+       !
+       DO jv = 1, nnobio
+          DO ji = 1, npts
+             snowa_nobio(ji,jv) = &
+                  ( snowa_aged(1) + snowa_dec(1) * agefunc_nobio(ji,jv) ) 
+          ENDDO
+       ENDDO
+    ENDIF ! prescribe or calculate the snow albedo?
+
+    !! 3. Calculate snow cover fraction for both total vegetated and total 
+    !! non-vegtative surfaces.\n
+
+    ! This has been changed from the trunk version to match what is actually 
+    ! in the reference...Jan 1, 2013
+    frac_snow_veg(:) = MIN(MAX(snow(:),zero)/&
+         (MAX(snow(:),zero)+snowcri_alb*sn_dens/100.0_r_std),un)
+    DO jv = 1, nnobio
+       frac_snow_nobio(:,jv) = MIN(MAX(snow_nobio(:,jv),zero)/&
+            (MAX(snow_nobio(:,jv),zero)+snowcri_alb*sn_dens/100.0_r_std),un)
+    ENDDO
+
+    !! 4. Update surface albedo
+
+    ! Update surface albedo using the weighted sum of previous time step surface
+    ! albedo, total vegetated fraction, total nobio fraction, snow cover 
+    ! fraction (both vegetated and non-vegetative surfaces), and snow albedo
+    ! (both vegetated and non-vegetative surfaces). Although both visible and
+    ! near-infrared surface albedo are presented, their calculations are the same.
+    DO jb = 1, n_spectralbands
+
+       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 ! Loop over # nobio surfaces
+          ! 
+          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 ! jv = 1, nnobio 
+
+    END DO ! jb = 1, n_spectralbands
+
+    ! this accounts for the fact that the calculations are done for each
+    ! spectra
+    DO ji = 1, npts
+       albedo_snow(ji) = (albedo_snow(ji))/REAL(n_spectralbands,r_std)
+       albedo_glob(ji) = (albedo_glob(ji))/REAL(n_spectralbands,r_std)
+    ENDDO
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving calculate_surface_albedo_with_snow '
+
+  END SUBROUTINE calculate_surface_albedo_with_snow
+  
+
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : albedo_two_stream
+!!
+!>\BRIEF        This subroutine calculates the albedo for two stream radiation transfer model.  This routine includes
+!!              the effect of snow on the background albedo, through one of two methods.
+!!
+!! DESCRIPTION  : The albedo for two stream radiation transfer model  is calculated for both the visible and near-infrared 
+!! domain. First the mean albedo of the bare soil is calculated. Two options exist: 
+!! either the soil albedo depends on soil wetness (drysoil_frac variable), or the soil albedo 
+!! is set to a mean soil albedo value.
+!!
+!!    NOTE: the main output variable, albedo, is an unweighted average of the direct and diffuse albedos
+!!          for each grid point...this is done in this way right now to be consistent with the new scheme,
+!!          but it doesn't have to be combined like that once we have an energy budget which can
+!!          use both types of light directly
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::albedo
+!!
+!! REFERENCE(S) : B. Pinty, T. Lavergne, R.E. Dickinson, J-L. Widlowski, N. Gobron and M. M. Verstraete (2006).
+!! Simplifying the Interaction of Land Surfaces with Radiation for Relating Remote Sensing Products to Climate Models.
+!! Journal of Geophysical Research. Vol 111, D02116.
+!!
+!! FLOWCHART    : None
+!! \n
+!!
+!!
+!!
+!_ ================================================================================================================================
+
+  SUBROUTINE albedo_two_stream(npts,  nlevels_loc, &
+       drysoil_frac,  lai,  &
+       veget_max,  sinang,   soilalb_dry,  soilalb_wet, &
+       frac_nobio,  soilalb_moy,  alb_bare,  albedo, &
+       snow,  snow_age,  snow_nobio,  snow_nobio_age, &
+       albedo_snow,  albedo_glob, circ_class_biomass, &
+       circ_class_n,  lai_split, z0_veg, Isotrop_Abs_Tot_p,&
+       Isotrop_Tran_Tot_p, laieff_fit, albedo_pft, frac_snow_nobio,&
+       frac_snow_veg)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+ 
+   INTEGER(i_std), INTENT(in)                                :: npts        !! Domain size - Number of land pixels  (unitless)       
+   INTEGER(i_std), INTENT(in)                                :: nlevels_loc     !! The number of vertical levels in the canopy (unitless)
+   REAL(r_std), DIMENSION(:), INTENT(in)              :: drysoil_frac    !! Fraction of  dry soil (unitless)
+   REAL(r_std),DIMENSION (:,:), INTENT (in)         :: lai             !! Leaf area index (m^2 m^{-2})
+
+   REAL(r_std), DIMENSION(:), INTENT(in)              :: sinang          !! 
+   REAL(r_std), DIMENSION(:,:), INTENT(in)          :: veget_max       !! PFT coverage fraction of a PFT (= ind*cn_ind) 
+                                                                                !! (m^2 m^{-2})
+   REAL(r_std), DIMENSION(:,:), INTENT(in)            :: soilalb_dry     !! Albedo values for the dry bare soil (unitless)
+   REAL(r_std), DIMENSION(:,:), INTENT(in)            :: soilalb_wet     !! Albedo values for the wet bare soil (unitless)
+   REAL(r_std), DIMENSION(:,:), INTENT(in)            :: soilalb_moy     !! Albedo values for the mean bare soil (unitless)
+   REAL(r_std),DIMENSION (:), INTENT(in)              :: snow            !! Snow mass in vegetation (kg m^{-2})           
+   REAL(r_std),DIMENSION (:,:), INTENT(in)       :: snow_nobio      !! Snow mass on continental ice, lakes, etc. (kg m^{-2})      
+   REAL(r_std),DIMENSION (:), INTENT(in)              :: snow_age        !! Snow age (days)        
+   REAL(r_std),DIMENSION (:,:), INTENT(in)       :: snow_nobio_age  !! Snow age on continental ice, lakes, etc. (days)    
+   REAL(r_std),DIMENSION (:,:), INTENT(in)       :: frac_nobio      !! Fraction of non-vegetative surfaces, i.e. 
+                                                                                !! continental ice, lakes, etc. (unitless)     
+   REAL(r_std), DIMENSION(:,:,:,:,:), &
+                                               INTENT(IN)    :: circ_class_biomass !! Stem diameter 
+                                                                                !! @tex $(m)$ @endtex
+   REAL(r_std), DIMENSION(:,:,:), INTENT(IN)    :: circ_class_n    !! Number of trees within each circumference
+   REAL(r_std),DIMENSION(:),INTENT(IN)                 :: lai_split
+   REAL(r_std), DIMENSION(:), INTENT(in)              :: z0_veg          !! Roughness height of vegetated part (m)
+   TYPE(laieff_type),DIMENSION (:,:,:),INTENT(in)    :: laieff_fit      !! Fitted parameters for the effective LAI
+
+   
+   !! 0.2 Output variables
+   
+   REAL(r_std), DIMENSION(:,:), INTENT(out)           :: alb_bare        !! Mean bare soil albedo for visible and near-infrared
+   REAL(r_std), DIMENSION (:,:), INTENT (out)         :: albedo          !! Albedo (two stream radiation transfer model)
+                                                                                !! for visible and near-infrared range 
+                                                                                !! (unitless)
+   REAL(r_std),DIMENSION (:), INTENT (out)            :: albedo_snow     !! Snow albedo (unitless ratio)     
+   REAL(r_std),DIMENSION (:), INTENT (out)            :: albedo_glob     !! Mean albedo (unitless ratio)
+   REAL(r_std),DIMENSION (:,:,:), INTENT (out)        :: Isotrop_Abs_Tot_p !! Absorbed radiation per layer for photosynthesis
+   REAL(r_std),DIMENSION (:,:,:), INTENT (out)        :: Isotrop_Tran_Tot_p !! Transmitted radiation per layer for photosynthesis
+   REAL(r_std), DIMENSION (:,:,:), INTENT (out)       :: albedo_pft      !! Albedo (two stream radiation transfer model)
+                                                                         !! for visible and near-infrared range 
+                                                                         !! for each PFT (unitless)
+   REAL(r_std), DIMENSION(npts,nnobio), INTENT(out)   :: frac_snow_nobio !! Fraction of snow on continental ice, lakes, etc. 
+                                                                         !! (unitless ratio)
+   REAL(r_std), DIMENSION(npts,nvm), INTENT(out)      :: frac_snow_veg   !! the fraction of ground covered with snow, between 0 and 1
+
+
+
+   !! 0.3 Modified variables
+   
+   !! 0.4 Local variables
+
+   REAL(r_std), DIMENSION(nlevels_loc,npts,nvm)          :: laieff_collim  !! Leaf Area Index Effective for direct light
+   REAL(r_std), DIMENSION(nlevels_loc,npts,nvm)          :: laieff_isotrop  !! Leaf Area Index Effective converts
+                                                                                !! 3D lai into 1D lai for two stream
+                                                                                !! radiation transfer model...this is for 
+                                                                                !! isotropic light and only calculated once per day
+                                                                                !! @tex $(m^{2} m^{-2})$ @endtex      
+   REAL(r_std),DIMENSION (nlevels_loc)         :: laieff_isotrop_pft, laieff_collim_pft   !! 
+   REAL(r_std)                           :: cosine_sun_angle   !! the cosine of the solar zenith angle
+   INTEGER(i_std)                        :: ks                 !! Index for visible and near-infraread range
+   INTEGER(i_std)                        :: ivm                !! Index for vegetative PFTs
+   INTEGER(i_std)                        :: ipts                !! Index for spatial domain
+   INTEGER(i_std)                        :: ilevel             !! Index for canopy levels
+   REAL(r_std)                           :: leaf_reflectance
+   REAL(r_std)                           :: leaf_transmittance
+   REAL(r_std)                           :: br_base_temp,br_base_temp_collim,br_base_temp_isotrop
+   REAL(r_std)                           :: leaf_psd_temp
+   REAL(r_std)                           :: leaf_single_scattering_albedo
+   REAL(r_std),DIMENSION(nlevels_loc)          :: Collim_Alb_Tot   !! Collimated (direct) total albedo for a given level
+   REAL(r_std),DIMENSION(nlevels_loc)          :: Collim_Tran_Uncoll  !! collimated total transmission of uncollided light for a given level 
+   REAL(r_std),DIMENSION(nlevels_loc)          :: Collim_Tran_Coll  !! collimated total transmission for a given level
+   REAL(r_std),DIMENSION(nlevels_loc)          :: Collim_Abs_Tot   !! collimated total absorption for a given level
+   REAL(r_std),DIMENSION(nlevels_loc)          :: Isotrop_Alb_Tot  !! isotropic (diffuse) total albedo for a given level
+   REAL(r_std),DIMENSION(nlevels_loc)          :: Isotrop_Tran_Uncoll !! isotropic total transmission of uncollided light for a given level
+   REAL(r_std),DIMENSION(nlevels_loc)          :: Isotrop_Tran_Coll !! isotropic total transmission for a given level
+   REAL(r_std),DIMENSION(nlevels_loc)          :: Isotrop_Abs_Tot  !! isotropic total absporbtion for a given level
+   INTEGER :: jv, inno
+   REAL(r_std) :: alb_nobio
+
+   REAL(r_std):: laieff_collim_1, laieff_isotrop_1, Collim_Alb_Tot_1,Collim_Tran_Tot_1,Collim_Abs_Tot_1,&
+                 Isotrop_Alb_Tot_1,Isotrop_Tran_Tot_1,Isotrop_Abs_Tot_1,&
+                 Collim_Tran_Uncollided_1, Isotrop_Tran_Uncollided_1   !! Values for the one level solution
+
+   REAL(r_std):: converged_albedo
+   REAL(r_std):: isotrop_angle
+   LOGICAL :: lconverged
+   LOGICAL :: lprint           !! a flag for printing some debug statements
+   REAL(r_std), DIMENSION(npts,nvm,n_spectralbands) :: snowa_veg  !! snow albedo due to vegetated surfaces, between 0 and 1
+   REAL(r_std), DIMENSION(npts,nnobio,n_spectralbands) :: snowa_nobio !! Albedo of snow covered area on continental ice, 
+                                                                          !! lakes, etc. (unitless ratio)  
+   
+!_ ================================================================================================================================
+
+
+   IF (bavard.GE.2) WRITE(numout,*) 'Entering albedo_two_stream'
+
+   !! 1. We will now calculate the background reflectance to be used in the model.
+   !! The parameters read in from the input file do not include the effect of snow,
+   !! so we need to figure out the snow's contribution for each grid space
+   
+   !initialize some output variables
+   DO ipts = 1, npts
+      albedo_snow(ipts) = zero
+   ENDDO
+   Isotrop_Abs_Tot_p(:,:,:)=zero
+   Isotrop_Tran_Tot_p(:,:,:)=un
+   albedo_pft(:,:,:)=zero
+
+   ! We need to calculate the LAI effective for this solar angle. The other LAI
+   ! effective that we calculated was computed at an angle of 60.0 degrees for
+   ! the isotropic contribution. Notice that, in many situations, the results 
+   ! will be exactly the same.  One can show that Pgap is proportional to 
+   ! 1/cos(theta) if the level bottom is below all canopy elements, which
+   ! means that the cos(theta) in the calculation of the LAIeff will be
+   ! cancelled out
+
+   isotrop_angle=COS(60.0/180.0*pi)
+   DO ipts=1,npts
+      DO ivm=1,nvm
+         DO ilevel=1,nlevels_loc
+            laieff_isotrop(ilevel,ipts,ivm)=calculate_laieff_fit(isotrop_angle,laieff_fit(ipts,ivm,ilevel))
+            laieff_collim(ilevel,ipts,ivm)=calculate_laieff_fit(sinang(ipts),laieff_fit(ipts,ivm,ilevel))
+            ! Because we are fitting these values, it's possible that some will 
+            ! drop below zero.  This causes a serious problem here,
+            ! so let's make sure this doesn't happen.  Unfortunately, by
+            ! doing this, we lose a test of things going wrong (an unfitted
+            ! negative LAIeff can be the sign of another problem), but we
+            ! don't really have a choice.
+            IF(laieff_isotrop(ilevel,ipts,ivm) .LT. min_stomate) &
+                 laieff_isotrop(ilevel,ipts,ivm)=zero
+            IF(laieff_collim(ilevel,ipts,ivm) .LT. min_stomate) &
+                 laieff_collim(ilevel,ipts,ivm)=zero
+         ENDDO
+      ENDDO
+   ENDDO
+
+   IF(ld_albedo)THEN
+      DO ivm=1,nvm
+         IF(ivm == test_pft)THEN
+            DO ipts = 1, npts
+               IF(ipts == test_grid)THEN
+                  WRITE(numout,*) 'Laieff_collim and laieff_isotrop in albedo'
+                  WRITE(numout,*) 'sinang(ipts): ',ACOS(sinang(ipts))/pi*180.0_r_std
+                  DO ilevel=nlevels_loc,1,-1
+                     WRITE(numout,*) ilevel,laieff_collim(ilevel,ipts,ivm),&
+                          laieff_isotrop(ilevel,ipts,ivm)
+                  END DO
+                  DO ilevel=nlevels_loc,1,-1
+                     WRITE(numout,*) 'Fitting parameters: ',laieff_fit(ipts,ivm,ilevel)%a,laieff_fit(ipts,ivm,ilevel)%b,&
+                          laieff_fit(ipts,ivm,ilevel)%c,laieff_fit(ipts,ivm,ilevel)%d,laieff_fit(ipts,ivm,ilevel)%e
+                  ENDDO
+               ENDIF
+            ENDDO
+         ENDIF
+      ENDDO
+   ENDIF
+
+   CALL calculate_snow_albedo(npts,  sinang,  snow,  snow_nobio, &
+        snow_age, snow_nobio_age,  frac_nobio,  albedo_snow, &
+        snowa_veg,  frac_snow_veg,  snowa_nobio,  frac_snow_nobio, &
+        veget_max, z0_veg)
+
+!!$   !+++++ CHECK +++++++
+!!$   DO ipts=1,npts
+!!$      DO ivm=1,nvm
+!!$         IF(frac_snow_veg(ipts,ivm) .LT. 0.0)THEN
+!!$            WRITE(numout,*) 'SNOWFRAC ipts ',ipts,frac_snow_veg(ipts,ivm)
+!!$            CALL ipslerr_p (3,'albedo', 'snow frac error','','')
+!!$         ENDIF
+!!$      ENDDO
+!!$      DO inno=1,nnobio
+!!$         IF(frac_snow_nobio(ipts,inno) .LT. 0.0)THEN
+!!$            WRITE(numout,*) 'SNOWFRAC ipts ',ipts,frac_snow_nobio(ipts,inno)
+!!$            CALL ipslerr_p (3,'albedo', 'nobio snow frac error','','')
+!!$         ENDIF
+!!$      ENDDO
+!!$   ENDDO
+!!$
+!!$   !++++++++++++++++++
+
+   ! initialize the albedo in every square for both spectra by calculating the 
+   ! bare soil albedo
+
+   DO ks = 1, n_spectralbands 
+      DO ipts = 1, npts
+         ! If 'alb_bare_model' is set to TRUE,  the soil albedo calculation 
+         ! depends on soil moisture
+         ! If 'alb_bare_model' is set to FALSE, the mean soil albedo is used 
+         ! without the dependance on soil moisture
+         ! see subroutine 'conveg_soilalb'
+         IF ( alb_bare_model ) THEN
+            alb_bare(ipts,ks) = soilalb_wet(ipts,ks) + drysoil_frac(ipts) * &
+                 (soilalb_dry(ipts,ks) -  soilalb_wet(ipts,ks))
+         ELSE
+            alb_bare(ipts,ks) = soilalb_moy(ipts,ks)
+         ENDIF
+
+         ! we need to take into account any snow that has fallen on the bare soil
+         ! since there may be some bare soil, initialize the albedo with this fraction
+         albedo(ipts,ks) = veget_max(ipts,1) * (alb_bare(ipts,ks)*&
+              (un-frac_snow_veg(ipts,1))+frac_snow_veg(ipts,1)*snowa_veg(ipts,1,ks))
+      ENDDO ! ipts = 1, npts
+   ENDDO ! ks = 1, n_spectralbands 
+
+   !! 3. Calculation of albedo of the whole grid cell, taking into account all 
+   !!    PFTs (except bare soil) and spectral bands
+
+   DO ipts = 1, npts ! loop over the grid squares
+
+      ! it appears that sinang is the sin of the angle from the horizon
+      ! this is equal to the cos of the zenith angle, which is what we need
+      cosine_sun_angle = sinang(ipts)
+
+      ! For the coupled model, the angles can be negative.
+      ! Offline, they are always between zero and 90 degrees.
+      IF(cosine_sun_angle .LE. min_sechiba)THEN
+         ! it's night, so no sunlight...don't need to calculate albedo.  Set it equal to
+         ! zero, because the snow albedo has already been calculated and it looks funny on
+         ! the coupled run maps otherwise.
+         albedo(ipts,:)=zero
+         CYCLE
+      ENDIF
+
+
+      ! are there any non-bio PFTs here that we need to take into account?
+      DO ks = 1, n_spectralbands ! Loop over # of spectra
+         DO jv = 1, nnobio 
+            ! now update the albedo
+            IF ( jv .EQ. iice ) THEN
+               alb_nobio = alb_ice(ks)
+            ELSE
+               WRITE(numout,*) 'jv=',jv
+               STOP 'DO NOT KNOW ALBEDO OF THIS SURFACE TYPE'
+            ENDIF
+
+            ! this takes into account both snow covered and non-snow covered non
+            ! bio regios in all grid squares
+            albedo(ipts,ks) = albedo(ipts,ks) + &
+                 ( frac_nobio(ipts,jv) ) * &
+                 ( (un-frac_snow_nobio(ipts,jv)) * alb_nobio + &
+                 ( frac_snow_nobio(ipts,jv)  ) * snowa_nobio(ipts,jv,ks)   )
+            albedo_snow(ipts) = albedo_snow(ipts) + &
+                 ( frac_nobio(ipts,jv) ) * ( frac_snow_nobio(ipts,jv) ) * &
+                 snowa_nobio(ipts,jv,ks)/REAL(n_spectralbands,r_std) 
+
+         ENDDO ! jv = 1, nnobio 
+      ENDDO ! ks = 1, n_spectralbands 
+
+      DO ivm = 2, nvm  ! Loop over # of PFTs     
+
+         ! for this grid square and this vegetation type, we have a set LAI 
+         ! effective
+         laieff_collim_pft(1:nlevels_loc) = laieff_collim(1:nlevels_loc,ipts,ivm)
+         laieff_isotrop_pft(1:nlevels_loc) = laieff_isotrop(1:nlevels_loc,ipts,ivm)
+
+         IF(veget_max(ipts,ivm) == zero)THEN
+            ! this vegetation type is not present, so no reason to do the 
+            ! calculation
+            CYCLE
+         ENDIF
+
+         DO ks = 1, n_spectralbands ! Loop over # of spectra
+
+            ! set single scattering albedo and preferred scattering direction
+            leaf_single_scattering_albedo = leaf_ssa(ivm,ks)
+            leaf_psd_temp = leaf_psd(ivm,ks)                 
+
+            ! calculate the rleaf and tleaf from wl=rl+tl and dl=rl/tl
+
+            leaf_transmittance = leaf_single_scattering_albedo/ & 
+                 (leaf_psd_temp+1)
+            leaf_reflectance = leaf_psd_temp * &
+                 leaf_transmittance
+
+            ! We need to take into account the effect of snow on the background 
+            ! reflectance here
+
+            ! from the snow above I can calculate the true background reflectance
+            ! for this PFT
+            br_base_temp= (un-frac_snow_veg(ipts,ivm)) * bgd_reflectance(ivm,ks)&
+                 + ( frac_snow_veg(ipts,ivm)  ) * snowa_veg(ipts,ivm,ks)
+
+            ! At this step, we assume that there is no difference between the 
+            ! direct and the diffuse background reflectance, which is true for 
+            ! the background but not the canopy albedo
+            br_base_temp_collim=br_base_temp
+            br_base_temp_isotrop=br_base_temp
+
+            ! This prints out some debugging information
+            IF(ld_albedo .AND. ivm == test_pft .AND. ipts == test_grid)THEN
+               DO ilevel=nlevels_loc,1,-1
+                  laieff_collim_1=laieff_collim_pft(ilevel)
+                  laieff_isotrop_1=laieff_isotrop_pft(ilevel)
+                  call twostream_solver(leaf_reflectance,leaf_transmittance,&
+                       br_base_temp_collim,br_base_temp_isotrop,&
+                       cosine_sun_angle,Collim_Alb_Tot_1,Collim_Tran_Tot_1,&
+                       Collim_Abs_Tot_1,Isotrop_Alb_Tot_1,Isotrop_Tran_Tot_1,&
+                       Isotrop_Abs_Tot_1,laieff_collim_1,  laieff_isotrop_1, &
+                       Collim_Tran_Uncollided_1, Isotrop_Tran_Uncollided_1)
+                  
+                  
+                  CALL print_debugging_albedo_info(ilevel,cosine_sun_angle,&
+                       leaf_reflectance,leaf_transmittance,&
+                       laieff_collim_1,laieff_isotrop_1,&
+                       br_base_temp_collim,br_base_temp_isotrop,Collim_Alb_Tot_1,&
+                       Collim_Tran_Tot_1,Collim_Abs_Tot_1,&
+                       Isotrop_Alb_Tot_1,Isotrop_Tran_Tot_1,Isotrop_Abs_Tot_1)
+                  
+               ENDDO ! loop over levels
+            ENDIF ! debugging
+
+            ! Calculate the one level approach to use as a template. Notice that
+            ! this is not actually needed for the multilevel approach, since there
+            ! are no parameters that we can tune to get the multilevel result
+            ! closer to the one level result.
+
+            ! First, we need to recombine all the levels into a one level LAI
+            laieff_collim_1=SUM(laieff_collim_pft(1:nlevels_loc))
+            laieff_isotrop_1=SUM(laieff_isotrop_pft(1:nlevels_loc))
+            call twostream_solver(leaf_reflectance, leaf_transmittance, &
+                 br_base_temp_collim, br_base_temp_isotrop, &
+                 cosine_sun_angle, Collim_Alb_Tot_1, Collim_Tran_Tot_1, &
+                 Collim_Abs_Tot_1, &
+                 Isotrop_Alb_Tot_1, Isotrop_Tran_Tot_1, Isotrop_Abs_Tot_1, &
+                 laieff_collim_1, &
+                 laieff_isotrop_1,  Collim_Tran_Uncollided_1,  &
+                 Isotrop_Tran_Uncollided_1)
+
+             ! Print out more debugging information
+             IF(ld_albedo .AND. ipts == test_grid .AND. ivm == test_pft) &
+                  CALL print_debugging_albedo_info(1, cosine_sun_angle, &
+                  leaf_reflectance, leaf_transmittance, laieff_collim_1, &
+                  laieff_isotrop_1, br_base_temp_collim, br_base_temp_isotrop, &
+                  Collim_Alb_Tot_1, Collim_Tran_Tot_1, Collim_Abs_Tot_1, &
+                  Isotrop_Alb_Tot_1, Isotrop_Tran_Tot_1, Isotrop_Abs_Tot_1)
+
+            ! If we only have one canopy level, there is no reason to try to fit
+            ! the nlevel case, since we just calculated the answer above
+            IF(nlevels_loc == 1)THEN
+               ! notice that this albedo assumes that diffuse and direct albedo 
+               ! are of equal importance
+               converged_albedo=(Collim_Alb_Tot_1+Isotrop_Alb_Tot_1)/2.0_r_std
+               albedo(ipts,ks) = albedo(ipts,ks) + veget_max(ipts,ivm)*converged_albedo
+               albedo_pft(ipts,ivm,ks)=veget_max(ipts,ivm)*converged_albedo
+               Isotrop_Abs_Tot_p(ipts,ivm,:) = Isotrop_Abs_Tot_1
+               Isotrop_Tran_Tot_p(ipts,ivm,:) = Isotrop_Tran_Tot_1
+
+               CYCLE
+            ENDIF
+
+
+            ! now solve the multilevel scheme
+            IF(ld_albedo .AND. test_pft == ivm .AND. test_grid == ipts)THEN
+               lprint=.TRUE.
+            ELSE
+               lprint=.FALSE.
+            ENDIF
+
+            CALL multilevel_albedo(nlevels_loc, cosine_sun_angle, leaf_single_scattering_albedo, &
+                 leaf_psd_temp, br_base_temp_collim, br_base_temp_isotrop, &
+                 laieff_collim_pft, laieff_isotrop_pft, lconverged, &
+                 Collim_Alb_Tot, Collim_Tran_Coll, Collim_Abs_Tot, Isotrop_Alb_Tot, &
+                 Isotrop_Tran_Coll, Isotrop_Abs_Tot, Collim_Tran_Uncoll, Isotrop_Tran_Uncoll, lprint)
+            
+            ! This is a lot of information printed out for the paper
+            ! on the multilevel albedo scheme.  Probably not useful
+            ! for anyone else, but I'm keeping it in until the paper is published.
+            ! This is why I'm protecting it with an IF statement.  I do not use
+            ! ld_albedo since it really is too much information for normal usage.
+            IF(.FALSE.)THEN
+
+               WRITE(6,'(A,2F14.10)') 'Background reflectance ',&
+                    br_base_temp_collim,br_base_temp_isotrop
+               WRITE(6,'(A,F14.10)') 'Single scattering albedo (wl): ',&
+                    leaf_single_scattering_albedo
+               WRITE(6,'(A,F14.10)') 'Preferred scattering direction (dl): ',&
+                    leaf_psd_temp
+
+               WRITE(6,*) 'Collimated light ',ACOS(cosine_sun_angle)/pi*180.0
+               WRITE(6,'(A,F4.1,A,4(F10.6,A))') '        1  &  ',laieff_collim_1,&
+                    ' & ',Collim_Alb_Tot_1,' & ',&
+                    Collim_Tran_Tot_1-Collim_Tran_Uncollided_1,' & ',&
+                    Collim_Tran_Uncollided_1,' & ',&
+                    Collim_Alb_Tot_1+Collim_Tran_Tot_1,' \\ '
+               WRITE(6,'(A,F4.1,A,4(F10.6,A))') '        2  &  ',laieff_collim_1,&
+                    ' & ',Collim_Alb_Tot(nlevels_loc),' & ',&
+                    Collim_Tran_Coll(1),' & ',Collim_Tran_Uncoll(1),' & ',&
+                    Collim_Alb_Tot(nlevels_loc)+Collim_Tran_Coll(1)+&
+                    Collim_Tran_Uncoll(1),' \\ '
+               WRITE(6,'(A,F4.1,A,4(F10.6,A))') '     Diff  &  ',laieff_collim_1,&
+                    ' & ',ABS(Collim_Alb_Tot_1-Collim_Alb_Tot(nlevels_loc)),' & ',&
+                    ABS((Collim_Tran_Tot_1-Collim_Tran_Uncollided_1)-&
+                    Collim_Tran_Coll(1)),' & ',&
+                    ABS(Collim_Tran_Uncollided_1-Collim_Tran_UnColl(1)),' & ',&
+                    ABS((Collim_Alb_Tot_1+Collim_Tran_Tot_1)-&
+                    (Collim_Alb_Tot(nlevels_loc)+Collim_Tran_Coll(1)+&
+                    Collim_Tran_Uncoll(1))),' \\ '
+
+               WRITE(6,*) 'Isotropic light '
+               WRITE(6,'(A,F4.1,A,4(F10.6,A))') '        1  &  ',&
+                    laieff_isotrop_1,' & ',Isotrop_Alb_Tot_1,' & ',&
+                    Isotrop_Tran_Tot_1-Isotrop_Tran_Uncollided_1,' & ',&
+                    Isotrop_Tran_Uncollided_1,' & ',&
+                    Isotrop_Alb_Tot_1+Isotrop_Tran_Tot_1,' \\ '
+               WRITE(6,'(A,F4.1,A,4(F10.6,A))') '        2  &  ',&
+                    laieff_isotrop_1,' & ',Isotrop_Alb_Tot(nlevels_loc),' & ',&
+                    Isotrop_Tran_Coll(1),' & ',Isotrop_Tran_Uncoll(1),' & ',&
+                    Isotrop_Alb_Tot(nlevels_loc)+Isotrop_Tran_Coll(1)+&
+                    Isotrop_Tran_Uncoll(1),' \\ '
+               WRITE(6,'(A,F4.1,A,4(F10.6,A))') '     Diff  &  ',&
+                    laieff_isotrop_1,&
+                    ' & ',ABS(Isotrop_Alb_Tot_1-Isotrop_Alb_Tot(nlevels_loc)),' & ',&
+                    ABS((Isotrop_Tran_Tot_1-Isotrop_Tran_Uncollided_1)-&
+                    Isotrop_Tran_Coll(1)),' & ',&
+                    ABS(Isotrop_Tran_Uncollided_1-Isotrop_Tran_UnColl(1)),' & ',&
+                    ABS((Isotrop_Alb_Tot_1+Isotrop_Tran_Tot_1)-&
+                    (Isotrop_Alb_Tot(nlevels_loc)+Isotrop_Tran_Coll(1)+&
+                    Isotrop_Tran_Uncoll(1))),' \\ '
+
+               WRITE(6,1010) 'COLLIMTRAN ',laieff_collim_1, &
+                    laieff_collim_pft(nlevels_loc),1,&
+                    leaf_single_scattering_albedo,br_base_temp_collim,&
+                    leaf_psd_temp,ACOS(cosine_sun_angle)/pi*180.0,&
+                    Collim_Tran_Tot_1,(Collim_Tran_Coll(1)+Collim_Tran_Uncoll(1))
+               WRITE(6,1010) 'COLLIMALB ',laieff_collim_1, &
+                    laieff_collim_pft(nlevels_loc),2,&
+                    leaf_single_scattering_albedo,br_base_temp_collim,&
+                    leaf_psd_temp,ACOS(cosine_sun_angle)/pi*180.0,&
+                    Collim_Alb_Tot_1,Collim_Alb_Tot(nlevels_loc)
+               WRITE(6,1010) 'COLLIMABSCAN ',laieff_collim_1, &
+                    laieff_collim_pft(nlevels_loc),3,&
+                    leaf_single_scattering_albedo,br_base_temp_collim,&
+                    leaf_psd_temp,ACOS(cosine_sun_angle)/pi*180.0,&
+                    Collim_Abs_Tot_1,SUM(Collim_Abs_Tot(:))
+               WRITE(6,1010) 'COLLIMABSSOIL ',laieff_collim_1, &
+                    laieff_collim_pft(nlevels_loc),4,&
+                    leaf_single_scattering_albedo,br_base_temp_collim,&
+                    leaf_psd_temp,ACOS(cosine_sun_angle)/pi*180.0,&
+                    un-Collim_Alb_Tot_1-Collim_Abs_Tot_1,un-&
+                    Collim_Alb_Tot(nlevels_loc)-SUM(Collim_Abs_Tot(:))
+
+               WRITE(6,1010) 'ISOTROPTRAN ',laieff_isotrop_1, &
+                    laieff_isotrop_pft(nlevels_loc),1,&
+                    leaf_single_scattering_albedo,br_base_temp_isotrop,&
+                    leaf_psd_temp,ACOS(cosine_sun_angle)/pi*180.0,&
+                    Isotrop_Tran_Tot_1,(Isotrop_Tran_Coll(1)+Isotrop_Tran_Uncoll(1))
+               WRITE(6,1010) 'ISOTROPALB ',laieff_isotrop_1, &
+                    laieff_isotrop_pft(nlevels_loc),2,&
+                    leaf_single_scattering_albedo,br_base_temp_isotrop,&
+                    leaf_psd_temp,ACOS(cosine_sun_angle)/pi*180.0,&
+                    Isotrop_Alb_Tot_1,Isotrop_Alb_Tot(nlevels_loc)
+               WRITE(6,1010) 'ISOTROPABSCAN ',laieff_isotrop_1, &
+                    laieff_isotrop_pft(nlevels_loc),3,&
+                    leaf_single_scattering_albedo,br_base_temp_isotrop,&
+                    leaf_psd_temp,ACOS(cosine_sun_angle)/pi*180.0,&
+                    Isotrop_Abs_Tot_1,SUM(Isotrop_Abs_Tot(:))
+               WRITE(6,1010) 'ISOTROPABSSOIL ',laieff_isotrop_1, &
+                    laieff_isotrop_pft(nlevels_loc),4,&
+                    leaf_single_scattering_albedo,br_base_temp_isotrop,&
+                    leaf_psd_temp,ACOS(cosine_sun_angle)/pi*180.0,&
+                    un-Isotrop_Alb_Tot_1-Isotrop_Abs_Tot_1,un-&
+                    Isotrop_Alb_Tot(nlevels_loc)-SUM(Isotrop_Abs_Tot(:))
+
+1010           FORMAT(A,2(F12.6,2X),I4,2X,6(F14.8,2X))
+
+            ENDIF ! debugging
+
+            ! For our total albedo, we are just taking a simple mean of the diffuse
+            ! and the direct light, which means we lose some information. This 
+            ! might be changed in the future. We also need to weight this by the 
+            ! percentage of nonbio land, but this appears to be included in veget_max
+
+            converged_albedo =(Collim_Alb_Tot(nlevels_loc)+Isotrop_Alb_Tot(nlevels_loc))/2.0_r_std
+            albedo(ipts,ks) = albedo(ipts,ks) + veget_max(ipts,ivm)*converged_albedo
+            albedo_pft(ipts,ivm,ks)=veget_max(ipts,ivm)*converged_albedo
+
+            ! Save the absorbed radiation for photosynthesis, we need only the
+            ! visible range and use the isotropic part, this can be change later
+            ! to distinguish between sunlit and shaded leaves.
+            ! Be careful here
+            IF (ks == 1) THEN
+               ! Test if Collim_Abs_Tot has negative values
+               ! If so, set it to min_sechiba  
+               DO  ilevel=1,nlevels_loc
+                  IF (Isotrop_Abs_Tot(ilevel) .LT. zero) THEN
+                     Isotrop_Abs_Tot(ilevel) =  min_sechiba
+                  ENDIF
+               ENDDO
+               !
+               Isotrop_Abs_Tot_p(ipts,ivm,:) = Isotrop_Abs_Tot(:)
+               Isotrop_Tran_Tot_p(ipts,ivm,:) = Isotrop_Tran_Coll(:) + Isotrop_Tran_Uncoll(:)
+
+               ! Notice that this light is actually cumulative, not per
+               ! level!  This was needed for debugging purposes and running
+               ! tests.  However, the photosynthesis routines need the light
+               ! transmitted per level, i.e. if there is zero LAI
+               ! in a level, the transmitted light will be one.
+               DO ilevel=1,nlevels_loc-1
+                  IF(Isotrop_Tran_Tot_p(ipts,ivm,ilevel+1) .GT. alb_threshold)THEN
+                     Isotrop_Tran_Tot_p(ipts,ivm,ilevel)=&
+                          Isotrop_Tran_Tot_p(ipts,ivm,ilevel)/Isotrop_Tran_Tot_p(ipts,ivm,ilevel+1)
+                  ELSE
+                     ! Here, we really don't know anything about how much light is transmitted
+                     ! in this layer, but there is no light reaching it from above so we
+                     ! can safely assume no photosynthesis takes place.  This is equivalent
+                     ! to assuming it has no LAI, which means the transmission will be unity.
+                     Isotrop_Tran_Tot_p(ipts,ivm,ilevel)=un
+                  ENDIF
+               ENDDO
+
+               ! Debugging information
+               IF (ld_albedo .AND. ivm == test_pft .AND. ipts == test_grid) THEN
+                  WRITE(numout,*) 'Absorbed light in albedo.f90: ', ipts, ivm
+                  DO ilevel=nlevels_loc,1,-1
+                     WRITE(numout,'(I5,10F20.10)') ilevel, Isotrop_Abs_Tot_p(ipts,ivm,ilevel),&
+                          Isotrop_Tran_Tot_p(ipts,ivm,ilevel),&
+                          laieff_isotrop(ilevel,ipts,ivm),laieff_collim(ilevel,ipts,ivm)
+                  ENDDO
+               ENDIF
+
+            ENDIF ! IF ks==1
+
+         ENDDO ! ks = 1, n_spectralbands 
+
+      ENDDO ! ivm = 2, nvm  
+
+   ENDDO ! ipts = 1, npts 
+
+   ! now we need to average the albedo over all our spectra, so we can pass it to
+   ! methods which do not distinguish between different spectral bands
+   albedo_glob(:) = zero
+   DO ks = 1, n_spectralbands ! Loop over # of spectra
+      albedo_glob(:) = albedo_glob(:) + albedo(:,ks)
+   ENDDO
+   albedo_glob(:)=albedo_glob(:)/REAL(n_spectralbands,r_std)
+
+   ! WRITE(*,*) '281013 in albedo_two_stream, Isotrop_Abs_Tot_p is: ', Isotrop_Abs_Tot_p
+
+   IF (bavard.GE.2) WRITE(numout,*) 'Leaving albedo_two_stream'
+
+ END SUBROUTINE albedo_two_stream
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : twostream_solver
+!!
+!>\BRIEF        : Computes the two-stream albedo solution for a level with given single scatterer properties
+!!                and a defined background albedo
+!!
+!! DESCRIPTION  : This solution is the two-stream solution of Pinty et al (2006) for a vegetation level above
+!!                an isotropically reflecting background.  It breaks down the problem into three parts, solving
+!!                each part for the case of diffuse (isotropic) and direct (collimated) light.  The three parts are,
+!!                1) The term due to light that does not interact at all with the canopy (Black Canopy)
+!!                2) Light that does not interact at all with the background (Black Background)
+!!                3) Light that bounces between the background and the canopy
+!!                This routine (and the routines it uses) were received directly from Bernard Pinty, and only some
+!!                minor modifcations were made, in addition to more documentation
+!! 
+!! 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): Collim_Alb_Tot,Collim_Tran_Tot,
+!!      Collim_Abs_Tot,Isotrop_Alb_Tot,Isotrop_Tran_Tot,Isotrop_Abs_To
+!!
+!! REFERENCE(S) :  B. Pinty, T. Lavergne, R.E. Dickinson, J-L. Widlowski, N. Gobron and M. M. Verstraete (2006).
+!! Simplifying the Interaction of Land Surfaces with Radiation for Relating Remote Sensing Products to Climate Models.
+!! Journal of Geophysical Research. Vol 111, D02116.
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+
+ SUBROUTINE twostream_solver(leaf_reflectance, leaf_transmittance, background_reflectance_collim, background_reflectance_isotrop, &
+          cosine_sun_angle, Collim_Alb_Tot, Collim_Tran_Tot, Collim_Abs_Tot, &
+          Isotrop_Alb_Tot, Isotrop_Tran_Tot, Isotrop_Abs_Tot, laieff_collim, &
+           laieff_isotrop,  Collim_Tran_Uncollided,  Isotrop_Tran_Uncollided)
+
+
+   !! 0. Variables and parameter declaration
+   !! 0.1 Input variables
+   REAL(r_std), INTENT(IN)    :: leaf_reflectance            !! effective leaf reflectance, between 0 and 1
+                                                             !! @tex $()$ @endtex 
+   REAL(r_std), INTENT(IN)    :: leaf_transmittance          !! effective leaf transmittance, between 0 and 1
+                                                             !! @tex $()$ @endtex 
+   REAL(r_std), INTENT(IN)    :: background_reflectance_collim      !! background reflectance for direct radiation,
+                                                             !! between 0 and 1
+   REAL(r_std), INTENT(IN)    :: background_reflectance_isotrop      !! background reflectance for diffuse radiation,
+                                                             !! between 0 and 1
+   REAL(r_std), INTENT(IN)    :: cosine_sun_angle            !! cosine of the solar zenith angle, between 0 and 1
+                                                             !! @tex $()$ @endtex 
+   REAL(r_std), INTENT(IN)    :: laieff_collim               !! Effective Leaf Area Index, computed at current sun angle
+   REAL(r_std), INTENT(IN)    :: laieff_isotrop              !! Effective Leaf Area Index, computed at 60 degrees
+                                                             !! @tex $(m^{2} m^{-2})$ @endtex 
+
+   !! 0.2 Output variables
+   !! notice that these variables (absorption + transmission + reflection) do not necessarily add up to 1 due to multiple scattering
+   REAL(r_std), INTENT(OUT)   :: Collim_Alb_Tot              !! collimated total albedo from this level, between 0 and 1
+                                                             !! @tex $()$ @endtex 
+   REAL(r_std), INTENT(OUT)   :: Collim_Tran_Tot             !! collimated total transmission through this level, between 0 and 1
+                                                             !! @tex $()$ @endtex 
+   REAL(r_std), INTENT(OUT)   :: Collim_Abs_Tot              !! collimated total absorption by this level, between 0 and 1
+                                                             !! @tex $()$ @endtex 
+   REAL(r_std), INTENT(OUT)   :: Isotrop_Alb_Tot             !! isotropic total albedo from this level, between 0 and 1
+                                                             !! @tex $()$ @endtex 
+   REAL(r_std), INTENT(OUT)   :: Isotrop_Tran_Tot            !! isotropic total transmission through this level, between 0 and 1
+                                                             !! @tex $()$ @endtex 
+   REAL(r_std), INTENT(OUT)   :: Isotrop_Abs_Tot             !! isotropic total absorption by this level, between 0 and 1
+                                                             !! @tex $()$ @endtex 
+   REAL(r_std), INTENT(OUT)   :: Collim_Tran_Uncollided      !! collimated uncollied transmission through this level, between 0 and 1
+                                                             !! @tex $()$ @endtex 
+   REAL(r_std), INTENT(OUT)   :: Isotrop_Tran_Uncollided     !! isotropic uncollied transmission through this level, between 0 and 1
+                                                             !! @tex $()$ @endtex 
+
+   !! 0.3 Modified variables
+
+   !! 0.4 Local variables
+   LOGICAL :: ok
+   REAL(r_std), DIMENSION(4)                           :: gammaCoeffs
+   REAL(r_std), DIMENSION(4)                           :: gammaCoeffs_star
+   REAL(r_std)                                         :: tauprimetilde
+   REAL(r_std)                                         :: tauprimestar
+   REAL(r_std)                                         :: sun_zenith_angle_radians
+   REAL(r_std), PARAMETER                              :: isotropic_cosine_constant=0.5/0.705
+
+   !calculated fluxes
+
+   REAL(r_std)                :: Collim_Alb_BB 
+   REAL(r_std)                :: Collim_Tran_BB
+   REAL(r_std)                :: Collim_Abs_BB
+   REAL(r_std)                :: Isotrop_Alb_BB
+   REAL(r_std)                :: Isotrop_Tran_BB
+   REAL(r_std)                :: Isotrop_Abs_BB
+   REAL(r_std)                :: Collim_Tran_BC
+   REAL(r_std)                :: Isotrop_Tran_BC
+   REAL(r_std)                :: Collim_Tran_TotalOneWay
+   REAL(r_std)                :: Isotrop_Tran_TotalOneWay
+   REAL(r_std)                :: Below_reinject_rad_collim,Below_reinject_rad_isotrop
+
+!_ ================================================================================================================================
+
+   IF (bavard.GE.2) WRITE(numout,*) 'Entering twostream_solver'
+
+   ! convert angular values
+   
+   sun_zenith_angle_radians = acos(cosine_sun_angle)
+
+   ! calculate the 4 gamma coefficients both in isotropic and collimated illumination 
+
+   call gammas(leaf_reflectance, leaf_transmittance, cosine_sun_angle, gammaCoeffs)
+   call gammas(leaf_reflectance,leaf_transmittance,isotropic_cosine_constant,&
+        gammaCoeffs_star)
+
+   ! estimate the effective value of the optical thickness 
+
+   tauprimetilde = 0.5_r_std * laieff_collim
+   !tauprimetilde = 1.
+
+   ! Should become zenit angle dependent (=60Â°) calculated by the Monte Carlo 
+   ! photon shooting routine
+
+   tauprimestar  = 0.5_r_std * laieff_isotrop
+   !tauprimestar  = 1.
+
+   ! +++++++++++++ BLACK BACKGROUND ++++++++++++++++++++++ 
+   ! * Apply the black-background 2stream solution 
+   ! * These equations are written for the part of the incoming radiation 
+   ! * that never hits the background but does interact with the vegetation 
+   ! * canopy.
+   ! * 
+   ! * Note : the same routine dhrT1() is used for both the isotropic and
+   ! * collimated illumination conditions but the calling arguments differ.
+   ! * (especially the solar angle used).
+   ! */
+
+   !	/* 1) collimated source */
+   ok=dhrT1(leaf_reflectance,leaf_transmittance,&
+        gammaCoeffs(1),gammaCoeffs(2),gammaCoeffs(3),gammaCoeffs(4),&
+        sun_zenith_angle_radians, tauprimetilde,&
+        Collim_Alb_BB,Collim_Tran_BB,Collim_Abs_BB)                      
+   ! 	/* 2) isotropic source */
+   ok=dhrT1(leaf_reflectance,leaf_transmittance,&
+        gammaCoeffs_star(1),gammaCoeffs_star(2),gammaCoeffs_star(3),&
+        gammaCoeffs_star(4),&
+        acos(isotropic_cosine_constant),tauprimestar,&
+        Isotrop_Alb_BB,Isotrop_Tran_BB,Isotrop_Abs_BB)
+
+
+   ! +++++++++++++ BLACK CANOPY ++++++++++++++++++++++ 
+   ! * Apply the black canopy solution.
+   ! * These equations hold for the part of the incoming radiation 
+   ! * that do not interact with the vegetation, travelling through 
+   ! * its gaps.
+   ! */
+
+   ! 	/* 1) collimated source */
+   IF (cosine_sun_angle .NE. 0) THEN
+      Collim_Tran_BC  = exp( - tauprimetilde/cosine_sun_angle)
+      Collim_Tran_Uncollided = Collim_Tran_BC
+   ENDIF
+   ! 	/* 2) isotropic source */
+   Isotrop_Tran_BC = TBarreUncoll_exact(tauprimestar)
+   Isotrop_Tran_Uncollided = Isotrop_Tran_BC
+
+   ! /* Total one-way transmissions:
+   ! * The vegetation canopy is crossed (one way) by the uncollided radiation
+   ! * (black canopy) and the collided one (black background). */
+
+   !	/* 1) collimated source */
+   Collim_Tran_TotalOneWay  = Collim_Tran_BC  + Collim_Tran_BB 
+
+   !	/* 2) isotropic source */
+   Isotrop_Tran_TotalOneWay = Isotrop_Tran_BC + Isotrop_Tran_BB 
+
+   ! * The Below_reinject_rad describes the process of reflecting toward the 
+   ! * background the upward travelling radiation (re-emitted from below the 
+   ! * canopy). It appears in the coupling equations as the limit of the series: 
+   ! *    1 + rg*rbv + (rg*rbv)^2 + (rg*rbv)^3 + ...
+   ! *      where rg is the background_reflectance and rbv is Isotrop_Alb_BB
+   ! *      (with Isotrop describing the Lambertian reflectance of the background).
+   ! */
+   ! this might be involved in Eq. 27, 
+   Below_reinject_rad_collim = un / (un - background_reflectance_collim*Isotrop_Alb_BB)
+   Below_reinject_rad_isotrop = un / (un - background_reflectance_isotrop*Isotrop_Alb_BB)
+
+   !/* TOTAL ALBEDO */
+   ! 	/* 1) collimated source */
+   Collim_Alb_Tot = Collim_Alb_BB + &
+        background_reflectance_collim * Collim_Tran_TotalOneWay * &
+        Isotrop_Tran_TotalOneWay * Below_reinject_rad_collim
+   !	/* 2) isotropic source */
+   Isotrop_Alb_Tot = Isotrop_Alb_BB + & 
+        background_reflectance_isotrop * Isotrop_Tran_TotalOneWay * &
+        Isotrop_Tran_TotalOneWay * Below_reinject_rad_isotrop ! this seems to be
+   ! exactly Eq. 33
+
+   !/* TOTAL TRANSMITION TO THE BACKGROUND LEVEL */
+   !	/* 1) collimated source */
+   Collim_Tran_Tot = Collim_Tran_TotalOneWay * Below_reinject_rad_collim ;
+
+   !	/* 2) isotropic source */
+   Isotrop_Tran_Tot = Isotrop_Tran_TotalOneWay * Below_reinject_rad_isotrop ;
+
+   !/* TOTAL ABSORPTION BY THE VEGETATION LEVEL */
+   !	/* 1) collimated source */
+   Collim_Abs_Tot = un - (Collim_Tran_Tot + Collim_Alb_Tot) + &
+        background_reflectance_collim * Collim_Tran_Tot;
+   !	/* 2) isotropic source */
+   Isotrop_Abs_Tot = un - (Isotrop_Tran_Tot + Isotrop_Alb_Tot) + &
+        background_reflectance_isotrop * Isotrop_Tran_Tot;
+
+   IF (bavard.GE.2) WRITE(numout,*) 'Exiting twostream_solver'
+
+ END SUBROUTINE twostream_solver
+
+
+!! ============================================================================\n
+!! FUNCTION     : dhrT1
+!!
+!>\BREF         
+!!
+!! DESCRIPTION : Taken directly from the Fortan code provided by Pinty et al for their \n
+!!               two-stream model.  The only changes are the REAL types.  This is used
+!!               to compute the black background absorption, transmission, and reflectance
+!!               in Pintys scheme and it's based on the older model of Meador and Weaver...
+!!               Pinty 2006 also includes a short discussion of it in Appendix A 
+!!
+!! RECENT CHANGE(S): None\n
+!!
+!! RETURN VALUE : dhrT1
+!!
+!! REFERENCE(S) : Meador and Weaver, 'Two-stream approximations to radiative transfer in
+!!    planetary atmosphere: a unified description of existing methods and a new improvement'
+!!    J. Atmospheric Sciences, VOL 37, p. 630--643, 1980.
+!!
+!! FLOWCHART    : None
+!_ =============================================================================
+
+FUNCTION dhrT1(rl,tl,gamma1,gamma2,gamma3,gamma4,tta,tau,AlbBS,Tdif,AbsVgt)
+
+
+  !! 0. Variables and parameter declaration
+  !! 0.1 Input variables
+  REAL(r_std), INTENT(IN) :: rl  ! the effective reflectance of a single scatterer, between 0 and 1
+                                 !! @tex $()$ @endtex      
+  REAL(r_std), INTENT(IN) :: tl  ! the effective transmittance of a single scatterer, between 0 and 1
+                                 !! @tex $()$ @endtex      
+  REAL(r_std), INTENT(IN) :: gamma1 ! the gamma coefficients from Meador and Weaver
+  REAL(r_std), INTENT(IN) :: gamma2
+  REAL(r_std), INTENT(IN) :: gamma3
+  REAL(r_std), INTENT(IN) :: gamma4
+  REAL(r_std), INTENT(IN) :: tta ! the solar zenith angle, between 0 and pi/2
+                                 !! @tex $(radians)$ @endtex      
+
+  REAL(r_std), INTENT(IN) :: tau ! Effective LAI * G(theta)
+                                 !! @tex $()$ @endtex      
+
+  !! 0.2 Output variables
+  REAL(r_std), INTENT(OUT) :: AlbBS ! the albedo of level, between 0 and 1
+                                 !! @tex $()$ @endtex      
+  REAL(r_std), INTENT(OUT) :: Tdif ! the transmitted light (all diffuse) from this light source, between 0 and 1
+                                 !! @tex $()$ @endtex      
+  REAL(r_std), INTENT(OUT) :: AbsVgt ! the light absorbed by the level, between 0 and 1
+                                 !! @tex $()$ @endtex      
+  LOGICAL :: dhrT1 ! the output flag, which always appears to be true
+
+  !! 0.3 Modified variables
+  !! 0.4 Local variables
+
+  REAL(r_std) :: alpha1,alpha2,ksquare,k
+  REAL(r_std) :: first_term,secnd_term1,secnd_term2,secnd_term3
+  REAL(r_std) :: expktau,Tdir
+  REAL(r_std) :: mu0,w0 
+
+  !_ ================================================================================================================================
+
+  mu0=cos(tta)
+  w0=rl+tl
+
+
+  Tdir = exp(-tau/mu0) ! direct transmission
+
+  ! There is a difference between conservative and non-conservative scattering 
+  ! conditions */
+  IF (w0 .ne. 1.0 .AND. w0 .ne. 0.0) THEN
+     !NON_CONSERVATIVE SCATTERING
+
+     ! some additional parameters, taken from Eq. 16--18 of Meador and Weaver, J. Atmospheric Sciences,
+     ! Vol 37, p. 630--643 (1980)
+     alpha1  = gamma1*gamma4 + gamma2*gamma3
+     alpha2  = gamma1*gamma3 + gamma2*gamma4
+     ksquare = gamma1*gamma1 - gamma2*gamma2
+     k       = sqrt(ksquare)
+
+     expktau = exp(k*tau)
+
+     !Black Soil Albedo...Eq. 14 in Meador and Weaver
+     first_term  = ((un-ksquare*mu0*mu0)*((k+gamma1)*expktau + (k-gamma1)/expktau))
+     IF (first_term .eq. 0.0) THEN
+        !we will be dividing by zero : cannot continue.
+        dhrT1 = .false.
+     ELSE 
+        first_term = un/first_term
+        secnd_term1 = (un - k*mu0)*(alpha2 + k*gamma3)*expktau
+        secnd_term2 = (un + k*mu0)*(alpha2 - k*gamma3)/expktau
+        secnd_term3 = 2.0_r_std * k * (gamma3 - alpha2*mu0)*Tdir
+        AlbBS = (w0 * first_term * (secnd_term1 - secnd_term2 - secnd_term3))
+
+        !Transmission...Eq. 15 in Meador and Weaver, for diffuse light?
+        IF (ksquare .eq. 0.0) THEN 
+           first_term = un
+        ENDIF
+        secnd_term1 = (un+k*mu0)*(alpha1+k*gamma4)*expktau
+        secnd_term2 = (un-k*mu0)*(alpha1-k*gamma4)/expktau
+        secnd_term3 = 2.0_r_std * k * (gamma4 + alpha1*mu0)
+        Tdif = - w0*first_term*(Tdir*(secnd_term1 - secnd_term2) - secnd_term3)
+
+        ! Absorption by vegetation...whatever is not transmitted or reflected 
+        ! must be absorbed
+        AbsVgt = (un- (Tdif+Tdir) - AlbBS)
+     ENDIF ! first_term .eq. 0.0
+  ELSE IF (w0 .eq. 0.) THEN
+     !BLACK CANOPY
+     AlbBS = zero
+     Tdif  = zero
+     AbsVgt = un - Tdir
+  ELSE
+     !CONSERATIVE SCATTERING...Eq. 24 in Meador and Weaver
+     AlbBS =  (un/(un + gamma1*tau))*(gamma1*tau + (gamma3-gamma1*mu0)*&
+          (un-exp(-tau/mu0)));
+     Tdif   = un - AlbBS - Tdir;
+     AbsVgt = zero;
+  ENDIF ! w0 .ne. 1.0 .AND. w0 .ne. 0.0
+
+! not sure what the purpose of this flag is, as it will always be set to true here
+  dhrT1 = .true.
+
+END FUNCTION dhrT1
+
+!! ============================================================================\n
+!! FUNCTION     : TBarreUncoll_exact
+!!
+!>\BRIEF          Computes the transmission of the diffuse black canopy light
+!!
+!! DESCRIPTION : Taken directly from the Fortan code provided by Pinty et al for their \n
+!!               two-stream model.  The only changes are the REAL types.  This appears
+!!               to be solving Eq. 16 in Pinty 2006, which is the transmission which
+!!               does not collide with the canopy
+!!
+!! RECENT CHANGE(S): None\n
+!!
+!! RETURN VALUE : TBarreUncoll_exact
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!_ =============================================================================
+
+FUNCTION TBarreUncoll_exact(tau)
+
+
+  !! 0. Variables and parameter declaration
+
+  !! 0.1 Input variables
+  REAL(r_std), INTENT(IN) :: tau ! Effective LAI * G(theta)
+  !! @tex $()$ @endtex      
+
+  !! 0.2 Output variables
+  REAL(r_std) :: TBarreUncoll_exact ! the isotropic light transmission uncollided
+                                    ! with the canopy, between 0 and 1
+  !! @tex $()$ @endtex      
+
+
+  !! 0.3 Modified variables
+
+  !! 0.4 Local variables
+!  INTEGER :: j,ind
+!  REAL(r_std) :: iGammaloc
+!  INTEGER :: order
+
+!_ ================================================================================================================================
+
+  !+++++ CHECK +++++
+
+!!$  iGammaloc = zero
+!!$  order=20
+!!$
+!!$  ! in the case where tau is equal to zero, this crashes in the first loop where
+!!$  ! iGammaloc is also zero...quick fix, and might even be accurate
+!!$
+!!$  IF(tau .GT. 1e-10_r_std)THEN
+!!$
+!!$     DO j=0,order-1
+!!$        ind = order - j
+!!$        iGammaloc = ind / (un + ind/(tau+iGammaloc))
+!!$     END DO
+!!$     iGammaloc=un/(tau + iGammaloc)
+!!$  ENDIF
+!!$
+!!$  TBarreUncoll_exact = exp(-tau)*(un - tau + tau*tau*iGammaloc)
+
+  ! this is a change suggested by Bernard to improve the matching between the one
+  ! level and multilevel case
+
+  TBarreUncoll_exact = exp(-tau*2.0_r_std*0.705_r_std)
+  !++++++++++
+
+END FUNCTION TBarreUncoll_exact
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : gammas
+!!
+!>\BRIEF         Computes a set of gamma coefficients for use in the black background equations
+!!
+!! DESCRIPTION : Taken directly from the Fortan code provided by Pinty et al for their \n
+!!               two-stream model.  The only changes are the REAL types.  This calculates
+!!               the gamma coefficients based on Appendix A in the paper.  This seems to
+!!               make the assumption of the Ross's G function and a spherical leaf
+!!               angle distribution.
+!!
+!! RECENT CHANGE(S): None\n
+!!
+!! MAIN OUTPUT VARIABLE(S): gammaCoeff
+!!
+!! REFERENCE(S) :  B. Pinty, T. Lavergne, R.E. Dickinson, J-L. Widlowski, N. Gobron and M. M. Verstraete (2006).
+!! Simplifying the Interaction of Land Surfaces with Radiation for Relating Remote Sensing Products to Climate Models.
+!! Journal of Geophysical Research. Vol 111, D02116.
+!!
+!! FLOWCHART    : None
+!_ ================================================================================================================================
+
+SUBROUTINE gammas(rl, tl, mu0, gammaCoeff)
+
+
+  !! 0. Variables and parameter declaration
+  !! 0.1 Input variables
+  REAL(r_std), INTENT(IN) :: rl  ! the effective reflectance of a single scatterer, between 0 and 1
+  !! @tex $()$ @endtex      
+  REAL(r_std), INTENT(IN) :: tl  ! the effective transmittance of a single scatterer, between 0 and 1
+  !! @tex $()$ @endtex      
+  REAL(r_std), INTENT(IN) :: mu0 ! the cosine of the solar zenith angle, between 0 and 1
+  !! @tex $()$ @endtex      
+
+  !! 0.2 Output variables
+  REAL(r_std), DIMENSION(1:4), INTENT(OUT) :: gammaCoeff ! the set of gamma coefficients in the above reference
+  !! @tex $()$ @endtex      
+
+  !! 0.3 Modified variables
+
+  !! 0.4 Local variables
+  REAL(r_std) :: wd,w0,w0half,wdsixth
+
+!_ ================================================================================================================================
+
+
+  w0      = rl+tl
+  wd      = rl-tl
+  w0half  = w0*0.5_r_std
+  wdsixth = wd/6.0_r_std
+
+  gammaCoeff(1)=2._r_std*(un - w0half + wdsixth)
+  gammaCoeff(2)=2._r_std*(w0half + wdsixth)
+  gammaCoeff(3)=2._r_std*(w0half*0.5_r_std + mu0*wdsixth)/w0
+  gammaCoeff(4)=un-gammaCoeff(3)
+
+END SUBROUTINE gammas
+
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : calculate_snow_albedo
+!!
+!>\BRIEF         Computes some of the information needed to calculate the effect of the snow albedo
+!!               on the background reflectance in the two stream model.  Right now, this can be done
+!!               with the old snow albedo scheme from Krinner et al 2005 as well as the snow albedo
+!!               scheme from Community Land Model 3 (CLM3). The calculation of
+!!               snow cover fraction is taken from Yang et al. 1997
+!!
+!! DESCRIPTION : In order to compute the background albedo in Pinty's two stream model, we have to take
+!!               into account any snow that has fallen through the canopy and landed on the ground.  In particular,
+!!               we need the amount of ground covered by the snow and the albedo of this snow.  Both of these
+!!               quantities are calculated here, using a function that changes the albedo of the snow based on
+!!               its age.  This is done in two ways, but the model of CLM3 is better suited to be used with Pinty's
+!!               albedo scheme, as it divides the radiation into VIS and NIR light. The calculation of snow cover 
+!!               fraction depends on roughness lenght.
+!!
+!! RECENT CHANGE(S): None\n
+!!
+!! MAIN OUTPUT VARIABLE(S): ::snowa_veg, ::frac_snow_veg, ::albedo_snow
+!!
+!! REFERENCE(S) :  "Technical description of the community land model CLM)", K. W. Oleson, Y. Dai, G. Bonan, M. Bosilovich, et al.,
+!!                 NCAR Technical Note, May 2004.
+!!
+!!                 Yang Z, Dickinson R, Robock A, Vinnikov K (1997) Validation of the snow submodel of the 
+!!                 biosphere-atmosphere transfer scheme with Russian 
+!!                 snow cover and meteorological observational data. Journal of Climate, 10, 353â373.
+!!
+!! FLOWCHART    : None
+!_ ================================================================================================================================
+
+SUBROUTINE calculate_snow_albedo(npts,  sinang,  snow,  snow_nobio, &
+           snow_age,  snow_nobio_age,  frac_nobio,  albedo_snow, &
+           snowa_veg,  frac_snow_veg,  snowa_nobio,  frac_snow_nobio, &
+           veget_max, z0_veg)
+
+  !! 0. Variables and parameter declaration
+  !! 0.1 Input variables
+  INTEGER,INTENT(IN)          :: npts !! Domain size - Number of land pixels  (unitless) 
+  REAL(r_std), DIMENSION(npts), INTENT(in)      :: sinang        !!  cosine of the solar zenith angle, between 0 and 1
+                                                                     !! @tex $()$ @endtex 
+   REAL(r_std),DIMENSION (npts), INTENT(in)        :: snow            !! Snow mass in vegetation (kg m^{-2})           
+   REAL(r_std),DIMENSION (npts,nnobio), INTENT(in) :: snow_nobio      !! Snow mass on continental ice, lakes, etc. (kg m^{-2})      
+   REAL(r_std),DIMENSION (npts), INTENT(in)        :: snow_age        !! Snow age (days)        
+   REAL(r_std),DIMENSION (npts,nnobio), INTENT(in) :: snow_nobio_age  !! Snow age on continental ice, lakes, etc. (days)    
+   REAL(r_std),DIMENSION (npts,nnobio), INTENT(in) :: frac_nobio      !! Fraction of non-vegetative surfaces, i.e. 
+                                                                          !! continental ice, lakes, etc. (unitless)     
+   REAL(r_std), DIMENSION(npts,nvm), INTENT(in)    :: veget_max       !! PFT coverage fraction of a PFT (= ind*cn_ind) 
+                                                                          !! (m^2 m^{-2})
+   REAL(r_std), DIMENSION(npts), INTENT(in)        :: z0_veg          !! Roughness height of vegetated part (m)
+
+
+  !! 0.2 Output variables
+  REAL(r_std), DIMENSION(npts),INTENT(OUT) :: albedo_snow           !! the averaged snow albedo for a given grid cell
+  REAL(r_std), DIMENSION(npts,nvm,n_spectralbands),INTENT(OUT) :: snowa_veg  !! the albedo of snow...this is seperated into
+                                                                                 !! PFT types, even though the calculation is identical
+                                                                                 !! for all PFTs right now
+  REAL(r_std), DIMENSION(npts,nvm),INTENT(OUT) :: frac_snow_veg              !! the fraction of the surface for each PFT covered by snow
+  REAL(r_std), DIMENSION(npts,nnobio,n_spectralbands),INTENT(OUT) :: snowa_nobio !! the albedo of snow on nonbiological land types
+  REAL(r_std), DIMENSION(npts,nnobio),INTENT(OUT) :: frac_snow_nobio    !! the fraction of nonbiological land types covered by snow
+
+
+  !! 0.3 Modified variables
+
+  !! 0.4 Local variables
+  REAL(r_std) :: agefunc,agefunc_nobio,snow_alb_direct, snow_alb_diffuse,f_mu
+  REAL(r_std),DIMENSION(n_spectralbands)            :: c_albedo,alb_snow_0 ! parameter values, taken directly from CLM3
+
+  INTEGER :: ipts,ks,ivm,jv ! indices
+  
+  !_ ================================================================================================================================
+
+  
+  ! initialize the output
+  albedo_snow=val_exp
+  snowa_veg=val_exp
+  frac_snow_veg=val_exp
+  snowa_nobio=val_exp
+  frac_snow_nobio=val_exp  
+
+  ! set some values for the new snow albedo
+  alb_snow_0(ivis)=0.95_r_std
+  alb_snow_0(inir)=0.65_r_std
+  c_albedo(ivis)=0.2_r_std
+  c_albedo(inir)=0.5_r_std
+
+
+  DO ipts = 1, npts ! loop over all the grid squares
+
+
+     ! calculate the snow cover fraction...right now this doesn't depend on PFT
+     ! snow fraction calculated following Yang et al 1997, eq. 32  
+     frac_snow_veg(ipts,:) = TANH((snow(ipts)/sn_dens)/ &
+          MAX((2.5_r_std*z0_veg(ipts)), &
+          min_sechiba)) 
+
+     DO ivm=1,nvm ! loop over all the PFTs
+
+
+        IF(veget_max(ipts,ivm) == zero)THEN
+            ! this vegetation type is not present, so no reason to do the 
+            ! calculation
+            CYCLE
+        ENDIF
+
+
+        DO ks=1,n_spectralbands ! loop over spectra
+
+           IF (ABS(fixed_snow_albedo - undef_sechiba) .GT. &
+                EPSILON(undef_sechiba)) THEN
+              snowa_veg(ipts,ivm,ks) = fixed_snow_albedo
+           ELSE
+
+              IF(control%do_new_snow_albedo)THEN
+                 ! first we calculate diffuse albedo
+                 ! NOTE: The difference between these two methods has not been 
+                 ! tested.  The only constraint is that it must be dimensionless
+                 agefunc = un - EXP(-snow_age(ipts)/tcst_snowa) ! already in ORCHIDEE
+                 !agefunc = zero
+
+                 ! using the constant from CLM3 conveted into days**-1
+                 !agefunc=un-un/(un+snow_age(ipts)*0.864_r_std)
+                 !agefunc=un/(un+snow_age(ipts)*0.864_r_std)     
+                 snow_alb_diffuse=(un-c_albedo(ks)*agefunc)*alb_snow_0(ks)
+
+                 ! now the direct albedo
+                 IF(sinang(ipts) .GT. 0.5_r_std)THEN
+                    f_mu=zero
+                 ELSE
+                    ! substituting b=2.0 into the equation...recommended by CLM3
+                    f_mu=(3.0_r_std)/(un+sinang(ipts))-2.0_r_std 
+                 ENDIF
+
+                 snow_alb_direct=snow_alb_diffuse+0.4_r_std*f_mu*&
+                      (un-snow_alb_diffuse)
+
+                 ! assume that the total snow albedo is a mix of 
+                 ! 50% direct and 50% diffuse
+                 snowa_veg(ipts,ivm,ks)=(snow_alb_direct+snow_alb_diffuse)&
+                      /2.0_r_std
+
+              ELSE
+                 ! calculate the age of the snow for this grid square
+                 agefunc = EXP(-snow_age(ipts)/tcst_snowa)
+
+                 ! now the albedo...use only the bare soil snow decay parameters, 
+                 ! since the true albedo is calculated
+                 ! by the PFT-dependent two-stream solver
+                 snowa_veg(ipts,ivm,ks) = snowa_aged(1)+snowa_dec(1)*agefunc 
+
+              ENDIF ! control%do_new_snow_albedo
+           ENDIF ! prescribe or calculate albedo
+
+
+
+           ! Notice that the fraction of nobio land is included in veget_max.
+           ! We have to average by the number of spectras, too, for this array, 
+           ! because it doesn't distinguish between PFTs or spectra
+           albedo_snow(ipts) = albedo_snow(ipts) + &
+                frac_snow_veg(ipts,ivm) * veget_max(ipts,ivm) * &
+                snowa_veg(ipts,ivm,ks)/REAL(n_spectralbands,r_std)
+
+        ENDDO ! ks=1,n_spectralbands 
+
+     ENDDO ! ivm=1,nvm 
+
+     ! there is no distinction between NIR and VIS for non bio surfaces
+     IF (ABS(fixed_snow_albedo - undef_sechiba) .GT. EPSILON(undef_sechiba)) THEN
+        snowa_nobio(:,:,:) = fixed_snow_albedo
+     ELSE
+
+        DO jv = 1, nnobio 
+           ! calculate the snow age
+           agefunc_nobio = EXP(-snow_nobio_age(ipts,jv)/tcst_snowa)
+
+           ! and the albedo due to snow of this age on this nonbio surface
+           snowa_nobio(ipts,jv,:) = ( snowa_aged(1) + snowa_dec(1) * agefunc_nobio ) 
+        ENDDO
+     ENDIF ! prescribe or calculate
+
+     DO jv = 1, nnobio 
+        ! calculate the fraction of the surface covered by snow
+        ! snow fraction calculated following Yang et al 1997, eq. 32
+        frac_snow_nobio(ipts,jv) = TANH((snow_nobio(ipts,jv)/sn_dens)/ &
+      MAX((2.5_r_std*z0_ice), &
+             min_sechiba))
+
+        ! For some reason, occasionally snow_nobio is negative.  This is driver
+        ! data that we cannot control, but it should not influence our snowcover, so
+        ! set it equal to zero in that case.
+        IF(snow_nobio(ipts,jv) .LT. zero) frac_snow_nobio(ipts,jv)=zero
+
+        albedo_snow(ipts) = albedo_snow(ipts) + &
+             ( frac_nobio(ipts,jv) ) * ( frac_snow_nobio(ipts,jv) ) * &
+             snowa_nobio(ipts,jv,1) ! not sensitive to the spectral band.  
+        ! Don't need to average here since we are outside the loop over the bands
+
+     ENDDO ! jv = 1, nnobio 
+     
+  ENDDO ! ipts = 1, npts 
+
+
+
+
+END SUBROUTINE CALCULATE_SNOW_ALBEDO
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : optimize_albedo_values
+!!
+!>\BRIEF         Follow the radiation scattered through the canopy in the 
+!!               case of multiple levels.
+!!
+!! DESCRIPTION : Right now, we know that using Pintys method in the case of a 
+!!               single canopy level will result in different top of the canopy
+!!               albedos than iwhat is found if we use multiple canopy levels.
+!!               We trust that the single level case gives the 'true' values.
+!!
+!!               This algorithm follows light as it scatters through multiple
+!!               levels in the canopy.  At each level, the scattering 
+!!               solution is found by solving Pinty's two stream model.  This
+!!               means that light which enters a level can either be transmitted
+!!               without colliding with the vegetation, transmitted after
+!!               collision with the vegetation, reflecting off the vegetation,
+!!               or being absorbed.  We follow the fluxes until they get
+!!               really small.
+!!
+!! RECENT CHANGE(S): None\n
+!!
+!! MAIN OUTPUT VARIABLE(S): ::lconverged, ::Collim_Alb_Tot, ::Collim_Tran_Tot, 
+!!          ::Collim_Abs_Tot, ::Isotrop_Alb_Tot, ::Isotrop_Tran_Tot, ::Isotrop_Abs_Tot
+!!
+!! REFERENCE(S) :  B. Pinty, T. Lavergne, R.E. Dickinson, J-L. Widlowski, N. Gobron
+!!          and M. M. Verstraete (2006). Simplifying the Interaction of Land 
+!!          Surfaces with Radiation for Relating Remote Sensing Products to 
+!!          Climate Models. Journal of Geophysical Research. Vol 111, D02116.
+!!
+!! FLOWCHART    : None
+!_ ================================================================================================================================
+SUBROUTINE multilevel_albedo(nlevels_loc, cosine_sun_angle, leaf_single_scattering_albedo_start,&
+     leaf_psd_start, br_base_temp_collim,  br_base_temp_isotrop, &
+     laieff_collim_pft, laieff_isotrop_pft, lconverged, &
+     Collim_Alb_Coll, Collim_Tran_Coll, Collim_Abs_Tot, Isotrop_Alb_Coll, &
+     Isotrop_Tran_Coll, Isotrop_Abs_Tot, Collim_Tran_Uncoll, Isotrop_Tran_Uncoll, lprint)
+
+  !! 0. Variables and parameter declaration
+  !! 0.1 Input variables
+  INTEGER,INTENT(IN)        :: nlevels_loc 
+  REAL(r_std), INTENT(IN)    :: cosine_sun_angle            !! cosine of the solar zenith angle, between 0 and 1
+  !! @tex $()$ @endtex 
+  REAL(r_std), INTENT(IN)    :: leaf_single_scattering_albedo_start           !! cosine of the solar zenith angle, between 0 and 1
+  REAL(r_std), INTENT(IN)    :: leaf_psd_start            !! cosine of the solar zenith angle, between 0 and 1
+  REAL(r_std), INTENT(IN)    :: br_base_temp_collim           !! cosine of the solar zenith angle, between 0 and 1
+  REAL(r_std), INTENT(IN)    :: br_base_temp_isotrop            !! cosine of the solar zenith angle, between 0 and 1
+  REAL(r_std),DIMENSION(:),INTENT(IN)        :: laieff_collim_pft                 !! Effective lai for a single pixel and pft to be 
+  REAL(r_std),DIMENSION(:),INTENT(IN)        :: laieff_isotrop_pft                 !! Effective lai for a single pixel and pft to be 
+  LOGICAL,INTENT(IN)        :: lprint                 !! A flag to print some debug statements
+  !!  used in the two stream approach...every level
+
+  !! 0.2 Output variables
+  LOGICAL,INTENT(OUT) :: lconverged                     !! did the optimization converge?
+  REAL(r_std),DIMENSION(:),INTENT(OUT)          :: Collim_Alb_Coll   !! collimated total albedo for the converged case
+  !! unitless, between 0 and 1
+  REAL(r_std),DIMENSION(:),INTENT(OUT)          :: Collim_Tran_Coll  !! collimated total transmission
+  !! unitless, between 0 and 1
+  REAL(r_std),DIMENSION(:),INTENT(OUT)          :: Collim_Abs_Tot   !! collimated total absorption
+  !! unitless, between 0 and 1
+  REAL(r_std),DIMENSION(:),INTENT(OUT)          :: Isotrop_Alb_Coll  !! isotropic total albedo
+  !! unitless, between 0 and 1
+  REAL(r_std),DIMENSION(:),INTENT(OUT)          :: Isotrop_Tran_Coll !! isotropic total transmission
+  !! unitless, between 0 and 1
+  REAL(r_std),DIMENSION(:),INTENT(OUT)          :: Isotrop_Abs_Tot  !! isotropic total absorption
+  !! unitless, between 0 and 1
+  REAL(r_std),DIMENSION(:),INTENT(OUT)          :: Collim_Tran_Uncoll  !! collimated uncollided transmission
+  !! unitless, between 0 and 1
+  REAL(r_std),DIMENSION(:),INTENT(OUT)          :: Isotrop_Tran_Uncoll  !! isotropic uncollided transmission
+  !! unitless, between 0 and 1
+
+  !! 0.3 Modified variables
+
+  !! 0.4 Local variables
+  ! use an extra level here...this is basically to store the transmission from the sun, which is normalized to 1.0
+  REAL(r_std),DIMENSION(nlevels_loc)            :: Collim_Abs_Coll_Unscaled
+  REAL(r_std),DIMENSION(nlevels_loc)            :: Collim_Alb_Coll_Unscaled
+  REAL(r_std),DIMENSION(nlevels_loc)            :: Collim_Tran_Coll_Unscaled
+  REAL(r_std),DIMENSION(nlevels_loc)            :: Collim_Tran_UnColl_Unscaled
+  REAL(r_std),DIMENSION(nlevels_loc)            :: Isotrop_Abs_Coll_Unscaled
+  REAL(r_std),DIMENSION(nlevels_loc)            :: Isotrop_Alb_Coll_Unscaled
+  REAL(r_std),DIMENSION(nlevels_loc)            :: Isotrop_Tran_Coll_Unscaled
+  REAL(r_std),DIMENSION(nlevels_loc)            :: Isotrop_Tran_UnColl_Unscaled
+  REAL(r_std),DIMENSION(nlevels_loc)            :: Collim_Tran_Tot
+  REAL(r_std),DIMENSION(nlevels_loc)            :: Isotrop_Tran_Tot
+
+  REAL(r_std),DIMENSION(0:nlevels_loc+1)            :: &
+       collim_down_cs,isotrop_down_cs,isotrop_up_cs
+
+  INTEGER                                   :: istep,ilevel
+
+  REAL(r_std)                               :: leaf_reflectance
+  REAL(r_std)                               :: leaf_transmittance
+
+  LOGICAL :: lexit
+  LOGICAL :: ok
+  REAL(r_std), DIMENSION(4)                           :: gammaCoeffs
+  REAL(r_std), DIMENSION(4)                           :: gammaCoeffs_star
+  REAL(r_std)                                         :: sun_zenith_angle_radians
+  REAL(r_std), PARAMETER                              :: isotropic_cosine_constant=0.5/0.705
+
+  INTEGER,SAVE :: icalls=0
+  !_ ================================================================================================================================
+
+  
+  icalls=icalls+1
+
+  ! convet the sun angle
+  sun_zenith_angle_radians = acos(cosine_sun_angle)
+
+
+
+  ! initialize some values that are used in the optimization loop
+  istep=0
+  lexit=.FALSE.
+  lconverged=.FALSE.
+
+  ! calculate the albedo at our starting point
+
+  leaf_transmittance = leaf_single_scattering_albedo_start/ & 
+       ( leaf_psd_start+un)
+  leaf_reflectance =  leaf_psd_start * &
+       leaf_transmittance
+
+  ! some debugging stuff
+  !  DO ilevel=1,nlevels_loc
+
+  !     CALL print_debugging_albedo_info(ilevel,cosine_sun_angle,leaf_reflectance,&
+  !          leaf_transmittance,&
+  !          laieff_collim_pft(ilevel),laieff_isotrop_pft(ilevel), &
+  !          reflectance_collim(ilevel-1),reflectance_isotrop(ilevel-1),&
+  !          Collim_Alb_Tot_temp(ilevel),Collim_Tran_Tot_temp(ilevel),&
+  !          Collim_Abs_Tot_temp(ilevel),&
+  !          Isotrop_Alb_Tot_temp(ilevel),Isotrop_Tran_Tot_temp(ilevel),&
+  !          Isotrop_Abs_Tot_temp(ilevel))
+  !  ENDDO
+
+
+  ! calculate the gamma coefficients used in the case of the black background 
+  call gammas(leaf_reflectance, leaf_transmittance, cosine_sun_angle, gammaCoeffs)
+  call gammas(leaf_reflectance,leaf_transmittance,isotropic_cosine_constant,&
+       gammaCoeffs_star)
+
+
+
+  !************************** step one ****** !
+  ! compute all the unscaled quantities
+  DO ilevel=nlevels_loc,1,-1
+
+     Collim_Tran_UnColl_Unscaled(ilevel)=exp( - 0.5_r_std*&
+          laieff_collim_pft(ilevel)/cosine_sun_angle)
+
+     Isotrop_Tran_UnColl_Unscaled(ilevel)= &
+          TBarreUncoll_exact(0.5_r_std*laieff_isotrop_pft(ilevel))
+
+
+     !	/* 1) collimated source */
+     ok=dhrT1(leaf_reflectance,leaf_transmittance,&
+          gammaCoeffs(1),gammaCoeffs(2),gammaCoeffs(3),gammaCoeffs(4),&
+          sun_zenith_angle_radians, 0.5_r_std*laieff_collim_pft(ilevel),&
+          Collim_Alb_Coll_Unscaled(ilevel),Collim_Tran_Coll_Unscaled(ilevel),&
+          Collim_Abs_Coll_Unscaled(ilevel))
+
+     ! 	/* 2) isotropic source */
+     ok=dhrT1(leaf_reflectance,leaf_transmittance,&
+          gammaCoeffs_star(1),gammaCoeffs_star(2),gammaCoeffs_star(3),gammaCoeffs_star(4),&
+          acos(isotropic_cosine_constant),0.5_r_std*laieff_isotrop_pft(ilevel),&
+          Isotrop_Alb_Coll_Unscaled(ilevel),Isotrop_Tran_Coll_Unscaled(ilevel),&
+          Isotrop_Abs_Coll_Unscaled(ilevel))
+
+     !     Collim_Tran_OneWay_Unscaled(ilevel)=Collim_Tran_Coll_Unscaled(ilevel)+&
+     !              Collim_Tran_UnColl_Unscaled(ilevel)
+     !     Isotrop_Tran_OneWay_Unscaled(ilevel)=Isotrop_Tran_Coll_Unscaled(ilevel)+&
+     !              Isotrop_Tran_UnColl_Unscaled(ilevel)
+
+     !     WRITE(6,'(A,I5,3F10.6)') 'unscaled ',ilevel,Collim_Tran_UnColl_Unscaled(ilevel),&
+     !          Collim_Tran_Coll_Unscaled(ilevel),&
+     !          Collim_Alb_Coll_Unscaled(ilevel)
+  ENDDO ! ilevel=nlevels_loc,1,-1
+
+
+
+
+  ! Following the fate of the light at every step
+
+  ! The downwelling array indicates the quantity of light flowing into this level
+  ! from above therefore, to start our system for collimated light, we give a 
+  ! unit of light coming into the top level from a collimated source.
+  ! The upwelling array is light entering this level from below.
+  ! cs is the current step, while ns is the next step for the iteration.
+  ! Level 0 is the background. Light can enter this level from above but not below
+  ! Level nlevels_loc+1 is the atomosphere. Light can enter this level from below 
+  ! but not above.
+  collim_down_cs(:)=zero
+  collim_down_cs(nlevels_loc)=un
+  isotrop_down_cs(:)=zero
+  isotrop_up_cs(:)=zero
+
+  CALL propagate_fluxes(nlevels_loc, collim_down_cs, isotrop_down_cs, isotrop_up_cs, &
+       Collim_Tran_UnColl_Unscaled, Collim_Tran_Coll_Unscaled, &
+       Collim_Alb_Coll_Unscaled, Isotrop_Tran_UnColl_Unscaled, &
+       Isotrop_Tran_Coll_Unscaled, Isotrop_Alb_Coll_Unscaled, &
+       br_base_temp_collim, br_base_temp_isotrop, .FALSE., &
+       Collim_Tran_Uncoll, Collim_Tran_Coll, Collim_Alb_Coll, lconverged, lprint)
+
+  ! Now for the isotropic light
+  collim_down_cs(:)=zero
+  isotrop_down_cs(:)=zero
+  isotrop_down_cs(nlevels_loc)=un
+  isotrop_up_cs(:)=zero
+
+  ! The colliminated light is never used here, but it's passed to keep things 
+  ! clean between the two cases. Might have to redo this if we are having 
+  ! peformance issues.
+  CALL propagate_fluxes(nlevels_loc, collim_down_cs, isotrop_down_cs, isotrop_up_cs, &
+       Collim_Tran_UnColl_Unscaled, Collim_Tran_Coll_Unscaled, &
+       Collim_Alb_Coll_Unscaled, Isotrop_Tran_UnColl_Unscaled, &
+       Isotrop_Tran_Coll_Unscaled, Isotrop_Alb_Coll_Unscaled, &
+       br_base_temp_collim, br_base_temp_isotrop, .TRUE., &
+       Isotrop_Tran_Uncoll, Isotrop_Tran_Coll, Isotrop_Alb_Coll, lconverged, lprint)
+
+  ! Calculate the absorption profile
+  Collim_Tran_Tot(:)=Collim_Tran_Coll(:)+Collim_Tran_Uncoll(:)
+  Isotrop_Tran_Tot(:)=Isotrop_Tran_Coll(:)+Isotrop_Tran_Uncoll(:)
+
+  ! bottom level
+  Collim_Abs_Tot(1)=Collim_Tran_Tot(1+1)+Collim_Tran_Tot(1)*br_base_temp_collim&
+       -Collim_Tran_Tot(1)-Collim_Alb_Coll(1)
+  Isotrop_Abs_Tot(1)=Isotrop_Tran_Tot(1+1)+Isotrop_Tran_Tot(1)*br_base_temp_isotrop&
+       -Isotrop_Tran_Tot(1)-Isotrop_Alb_Coll(1)
+
+  ! all middle levels
+  DO ilevel=2,nlevels_loc-1
+     Collim_Abs_Tot(ilevel)=Collim_Tran_Tot(ilevel+1)+Collim_Alb_Coll(ilevel-1)&
+          -Collim_Tran_Tot(ilevel)-Collim_Alb_Coll(ilevel)
+     Isotrop_Abs_Tot(ilevel)=Isotrop_Tran_Tot(ilevel+1)+Isotrop_Alb_Coll(ilevel-1)&
+          -Isotrop_Tran_Tot(ilevel)-Isotrop_Alb_Coll(ilevel)
+  ENDDO
+
+  ! top level
+  Collim_Abs_Tot(nlevels_loc)=un+Collim_Alb_Coll(nlevels_loc-1)&
+       -Collim_Tran_Tot(nlevels_loc)-Collim_Alb_Coll(nlevels_loc)
+  Isotrop_Abs_Tot(nlevels_loc)=un+Isotrop_Alb_Coll(nlevels_loc-1)&
+       -Isotrop_Tran_Tot(nlevels_loc)-Isotrop_Alb_Coll(nlevels_loc)
+
+
+
+END SUBROUTINE multilevel_albedo
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : print_debugging_albedo_info
+!!
+!>\BRIEF         Prints out some albedo information in a nice format.  
+!!               Should only be used for debugging, never for production runs.
+!!
+!! DESCRIPTION : 
+!!
+!! RECENT CHANGE(S): None\n
+!!
+!! MAIN OUTPUT VARIABLE(S): None.
+!!
+!! REFERENCE(S) :  
+!!
+!! FLOWCHART    : None
+!_ ================================================================================================================================
+SUBROUTINE print_debugging_albedo_info(ilevel, cosine_sun_angle, &
+     leaf_reflectance, leaf_transmittance, laieff_collim_temp, laieff_isotrop_temp, &
+     br_base_temp_collim, br_base_temp_isotrop, Collim_Alb_Tot, &
+     Collim_Tran_Tot, Collim_Abs_Tot, Isotrop_Alb_Tot, Isotrop_Tran_Tot, Isotrop_Abs_Tot)
+
+  !! 0. Variables and parameter declaration
+  !! 0.1 Input variables
+  INTEGER,INTENT(IN)      :: ilevel
+  REAL(r_std), INTENT(IN)    :: cosine_sun_angle            !! cosine of the solar zenith angle, between 0 and 1
+                                                             !! @tex $()$ @endtex 
+   REAL(r_std), INTENT(IN)    :: laieff_collim_temp           !! cosine of the solar zenith angle, between 0 and 1
+   REAL(r_std), INTENT(IN)    :: laieff_isotrop_temp           !! cosine of the solar zenith angle, between 0 and 1
+   REAL(r_std), INTENT(IN)    :: leaf_reflectance           !! cosine of the solar zenith angle, between 0 and 1
+   REAL(r_std), INTENT(IN)    :: leaf_transmittance            !! cosine of the solar zenith angle, between 0 and 1
+   REAL(r_std), INTENT(IN)    :: br_base_temp_collim           !! cosine of the solar zenith angle, between 0 and 1
+   REAL(r_std), INTENT(IN)    :: br_base_temp_isotrop            !! cosine of the solar zenith angle, between 0 and 1
+   REAL(r_std),INTENT(IN)          :: Collim_Alb_Tot
+   REAL(r_std),INTENT(IN)          :: Collim_Tran_Tot
+   REAL(r_std),INTENT(IN)          :: Collim_Abs_Tot
+   REAL(r_std),INTENT(IN)          :: Isotrop_Alb_Tot
+   REAL(r_std),INTENT(IN)          :: Isotrop_Tran_Tot
+   REAL(r_std),INTENT(IN)          :: Isotrop_Abs_Tot
+
+  !! 0.2 Output variables
+
+  !! 0.3 Modified variables
+
+  !! 0.4 Local variables
+
+  !_ ================================================================================================================================
+   
+1223 FORMAT(I5,I3,7(F14.7))
+
+     WRITE (6,'(8(11A))') '   Level   ','   Angle   ','  laieff_c  ','  laieff_i  ',&
+          '   rleaf   ','   tleaf   ','   rbgd_c   ','   rbgd_i   '
+
+     WRITE(6,FMT='(I6,5X,7(F11.6))') &
+          ilevel,180/pi*ACOS(cosine_sun_angle),&
+          laieff_collim_temp,laieff_isotrop_temp,&
+          leaf_reflectance,leaf_transmittance,br_base_temp_collim,&
+          br_base_temp_isotrop
+
+
+     WRITE (6,'(10X,6(11A))') ' Rtot(sun) ',' Ttot(sun) ',&
+          ' Atot(sun) ',' Rtot(iso) ',' Ttot(iso) ',' Atot(iso) '
+     WRITE(6,FMT='(10X,6(F11.6))') &
+          Collim_Alb_Tot,Collim_Tran_Tot,Collim_Abs_Tot,&
+          Isotrop_Alb_Tot,Isotrop_Tran_Tot,Isotrop_Abs_Tot
+
+
+END SUBROUTINE print_debugging_albedo_info
+
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : propagate_fluxes
+!!
+!>\BRIEF         Propogates the radiation fluxes through each level of the
+!!               canopy.
+!!
+!! DESCRIPTION : This is an algorithm to follow radition fluxes through the
+!!     canopy.  At each level, the path probabilities are determined by the
+!!     raditional transfer scheme of Pinty et al (2006).  Notice that
+!!     the fluxes given by this routine are all cumulative fluxes, not per
+!!     level.
+!!
+!! RECENT CHANGE(S): None\n
+!!
+!! MAIN OUTPUT VARIABLE(S): ::Tran_Uncoll_Tot, ::Tran_Coll_Tot, ::Alb_Coll_Tot
+!!
+!! REFERENCE(S) :  
+!!
+!! FLOWCHART    : None
+!_ ================================================================================================================================
+SUBROUTINE propagate_fluxes(nlevels_loc, collim_down_cs, isotrop_down_cs, isotrop_up_cs, &
+     Collim_Tran_UnColl_Unscaled, Collim_Tran_Coll_Unscaled, &
+     Collim_Alb_Coll_Unscaled, Isotrop_Tran_UnColl_Unscaled, &
+     Isotrop_Tran_Coll_Unscaled, Isotrop_Alb_Coll_Unscaled, br_base_temp_collim, &
+     br_base_temp_isotrop, lisotrop, Tran_Uncoll_Tot, Tran_Coll_Tot, &
+     Alb_Coll_Tot, lconverged, lprint)
+
+  !! 0. Variables and parameter declaration
+  !! 0.1 Input variables
+  INTEGER,INTENT(IN)        :: nlevels_loc 
+  REAL(r_std), DIMENSION(nlevels_loc),INTENT(IN)        :: Collim_Tran_UnColl_Unscaled
+  REAL(r_std), DIMENSION(nlevels_loc),INTENT(IN)        :: Collim_Tran_Coll_Unscaled
+  REAL(r_std), DIMENSION(nlevels_loc),INTENT(IN)        :: Collim_Alb_Coll_Unscaled
+  REAL(r_std), DIMENSION(nlevels_loc),INTENT(IN)        :: Isotrop_Tran_UnColl_Unscaled
+  REAL(r_std), DIMENSION(nlevels_loc),INTENT(IN)        :: Isotrop_Tran_Coll_Unscaled
+  REAL(r_std), DIMENSION(nlevels_loc),INTENT(IN)        :: Isotrop_Alb_Coll_Unscaled
+  REAL(r_std), INTENT(IN)    :: br_base_temp_collim           !! cosine of the solar zenith angle, between 0 and 1
+  REAL(r_std), INTENT(IN)    :: br_base_temp_isotrop            !! cosine of the solar zenith angle, between 0 and 1
+  LOGICAL, INTENT(IN)    :: lisotrop            !! are we dealing with an isotropic source?  only needed for correct partitioning
+                                                !! of the collided and uncollided transmitted light...the total is not affected
+  LOGICAL, INTENT(IN)    :: lprint              !! a flag to print
+
+  !! 0.2 Output variables
+  REAL(r_std), DIMENSION(nlevels_loc),INTENT(OUT)        :: Tran_Uncoll_Tot
+  REAL(r_std), DIMENSION(nlevels_loc),INTENT(OUT)        :: Tran_Coll_Tot
+  REAL(r_std), DIMENSION(nlevels_loc),INTENT(OUT)        :: Alb_Coll_Tot
+  LOGICAL,INTENT(OUT)                                :: lconverged
+
+  !! 0.3 Modified variables
+  REAL(r_std), DIMENSION(0:nlevels_loc+1),INTENT(INOUT)    :: collim_down_cs
+  REAL(r_std), DIMENSION(0:nlevels_loc+1),INTENT(INOUT)    :: isotrop_down_cs
+  REAL(r_std), DIMENSION(0:nlevels_loc+1),INTENT(INOUT)    :: isotrop_up_cs
+
+  !! 0.4 Local variables
+  INTEGER :: istep,ilevel
+  REAL(r_std),DIMENSION(0:nlevels_loc+1)            :: collim_down_ns,isotrop_down_ns,&
+       isotrop_up_ns,Tran_Uncoll_Tot_temp
+  
+  !_ ================================================================================================================================
+
+  Tran_Uncoll_Tot(:)=zero
+  Tran_Coll_Tot(:)=zero
+  Alb_Coll_Tot(:)=zero
+
+  Tran_Uncoll_Tot_temp(:)=un
+
+  istep=0
+  DO
+
+     istep=istep+1
+
+     lconverged=.TRUE.
+
+     ! Zero out the counters for the next step
+     collim_down_ns(:)=zero
+     isotrop_down_ns(:)=zero
+     isotrop_up_ns(:)=zero
+
+
+     ! Now we need to loop over all levels and see what light is entering the 
+     ! level, and how it will propagate in the next step
+     DO ilevel=1,nlevels_loc
+
+        ! For collimated downwelling light into the level, it can be scattered 
+        ! up, down, or pass through uncollided
+        IF(collim_down_cs(ilevel) .GT. zero)THEN
+           collim_down_ns(ilevel-1)=collim_down_ns(ilevel-1)+&
+                collim_down_cs(ilevel)*Collim_Tran_UnColl_Unscaled(ilevel)
+
+           ! This statement checks to see if this light has been previously
+           ! scattered or not.  This term is only present in level nlevels_loc
+           ! for the first step, level nlevels_loc-1 for the second step, 
+           ! level nlevels_loc-2 for the third step, etc., and it only happens
+           ! in the case of a collimated light source.
+           IF(ilevel == nlevels_loc-istep+1 .AND. .NOT. lisotrop) THEN
+              Tran_Uncoll_Tot_temp(ilevel)=Tran_Uncoll_Tot_temp(ilevel+1)*&
+                   Collim_Tran_UnColl_Unscaled(ilevel)
+           ENDIF
+
+           isotrop_down_ns(ilevel-1)=isotrop_down_ns(ilevel-1)+&
+                collim_down_cs(ilevel)*Collim_Tran_Coll_Unscaled(ilevel)
+           isotrop_up_ns(ilevel+1)=isotrop_up_ns(ilevel+1)+&
+                collim_down_cs(ilevel)*Collim_Alb_Coll_Unscaled(ilevel)
+        ENDIF ! collim_down_cs(ilevel) .GT. zero
+
+        ! For isotropic downwelling light, it can also be scattered up, down,
+        ! or pass through uncollided
+        IF(isotrop_down_cs(ilevel) .GT. zero)THEN
+           isotrop_down_ns(ilevel-1)=isotrop_down_ns(ilevel-1)+&
+                isotrop_down_cs(ilevel)*Isotrop_Tran_UnColl_Unscaled(ilevel)
+
+           ! This is the same check as above, but this time the light has
+           ! an isotropic source and not a collimated source
+           IF(ilevel == nlevels_loc-istep+1 .AND. lisotrop) THEN
+              Tran_Uncoll_Tot_temp(ilevel)=Tran_Uncoll_Tot_temp(ilevel+1)&
+                   *Isotrop_Tran_UnColl_Unscaled(ilevel)
+           ENDIF
+
+           isotrop_down_ns(ilevel-1)=isotrop_down_ns(ilevel-1)+&
+                isotrop_down_cs(ilevel)*Isotrop_Tran_Coll_Unscaled(ilevel)
+           isotrop_up_ns(ilevel+1)=isotrop_up_ns(ilevel+1)+&
+                isotrop_down_cs(ilevel)*Isotrop_Alb_Coll_Unscaled(ilevel)
+        ENDIF ! isotrop_down_cs(ilevel) .GT. zero
+
+        ! Isotropic upwelling light can pass through upwards collided or 
+        ! uncollided with vegetation in this level, or it can be reflected downwards
+        IF(isotrop_up_cs(ilevel) .GT. zero)THEN
+           isotrop_up_ns(ilevel+1)=isotrop_up_ns(ilevel+1)+isotrop_up_cs(ilevel)&
+                *Isotrop_Tran_UnColl_Unscaled(ilevel)
+           isotrop_up_ns(ilevel+1)=isotrop_up_ns(ilevel+1)+isotrop_up_cs(ilevel)&
+                *Isotrop_Tran_Coll_Unscaled(ilevel)
+           isotrop_down_ns(ilevel-1)=isotrop_down_ns(ilevel-1)+&
+                isotrop_up_cs(ilevel)*Isotrop_Alb_Coll_Unscaled(ilevel)
+        ENDIF
+
+        ! there can be no collimated upwards light, since upwards light must 
+        ! always have reflected off something
+
+
+     ENDDO ! ilevel=1,nlevels_loc
+
+     ! The background is a bit special. there is no transmission, but there is 
+     ! reflection, which leads to a source term to the bottom level from below.
+     isotrop_up_ns(1)=isotrop_up_ns(1)+collim_down_cs(0)*br_base_temp_collim
+     isotrop_up_ns(1)=isotrop_up_ns(1)+isotrop_down_cs(0)*br_base_temp_isotrop
+
+
+     ! Now we add the light generated here to our cumulative counters to track
+     ! the total amount that leaves the canopy, either through being absorbed
+     ! by the background or being reflected back into the atmosphere.
+     ! We keep track of the uncoll above, so here we track the total light that
+     ! is transmitted to the soil, and then at the end we taken the difference 
+     ! to get the collided radation.
+     Tran_Coll_Tot(1:nlevels_loc)=Tran_Coll_Tot(1:nlevels_loc)+&
+          isotrop_down_ns(0:nlevels_loc-1)+collim_down_ns(0:nlevels_loc-1)
+     Alb_Coll_Tot(1:nlevels_loc)=Alb_Coll_Tot(1:nlevels_loc)+isotrop_up_ns(2:nlevels_loc+1)
+
+     ! now we update the light we are currently tracking
+     collim_down_cs(:)=collim_down_ns(:)
+     isotrop_down_cs(:)=isotrop_down_ns(:)
+     isotrop_up_cs(:)=isotrop_up_ns(:)
+
+
+
+
+     ! check for convegence...if all the values of light are currently below a 
+     ! threshold, we're probably good assuming the threshold is low enough.
+     IF(MAXVAL(collim_down_cs,1) .GT. alb_threshold) lconverged=.FALSE.
+     IF(MAXVAL(isotrop_down_cs,1) .GT. alb_threshold) lconverged=.FALSE.
+     IF(MAXVAL(isotrop_up_cs,1) .GT. alb_threshold) lconverged=.FALSE.
+
+     IF(lconverged)THEN
+        IF(lprint) WRITE(numout,*) 'Converged after this many steps: ',istep
+        EXIT
+     ENDIF
+
+     ! This number here could also be externalized.
+     IF(istep .GE. 1000)THEN
+        WRITE(numout,*) '*********************************************************'
+        WRITE(numout,'(A,I6,F14.10)') 'Albedo not converging!',istep,alb_threshold
+        WRITE(numout,'(A)') '                  collim_down_cs ' // &
+             'isotrop_down_cs  isotrop_up_cs'
+        DO ilevel=0,nlevels_loc+1
+           WRITE(numout,'(I4,3F14.10)') ilevel, &
+                collim_down_cs(ilevel),isotrop_down_cs(ilevel),isotrop_up_cs(ilevel)
+        ENDDO
+        WRITE(numout,*) 'You should increase either the number' // &
+             'of steps or the alb_threshold.'
+        WRITE(numout,*) '*********************************************************'
+        EXIT
+     ENDIF ! istep .GE. 1000
+  ENDDO ! convergence loop
+
+
+  ! now separate the collided from the uncollided light.  Notice that
+  ! this is not really needed for any purposes other than debugging, as the
+  ! important quantity is the total amount of light striking the ground.
+  Tran_UnColl_Tot(1:nlevels_loc)=Tran_UnColl_Tot_temp(1:nlevels_loc)
+  Tran_Coll_Tot(1:nlevels_loc)=Tran_Coll_Tot(1:nlevels_loc)-Tran_UnColl_Tot(1:nlevels_loc)
+
+  ! Some debugging information
+  IF(lprint)THEN
+     WRITE(numout,'(A)') '      Tran_Uncoll_Tot   Tran_Coll_Tot  Alb_Coll_Tot'
+     DO ilevel=nlevels_loc,1,-1
+        WRITE(numout,'(I4,3F10.6)') ilevel, &
+             Tran_Uncoll_Tot(ilevel),Tran_Coll_Tot(ilevel),Alb_Coll_Tot(ilevel)
+     ENDDO
+  ENDIF
+
+END SUBROUTINE propagate_fluxes
+
+
+END MODULE albedo
Index: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/condveg.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/condveg.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/condveg.f90	(revision 7236)
@@ -0,0 +1,1452 @@
+! ===============================================================================================================================
+! MODULE       : condveg
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        Initialise, compute and update the surface parameters emissivity,
+!! roughness and albedo. 
+!!
+!! \n DESCRIPTION : The module uses 3 settings to control its flow:\n
+!! 1. :: z0cdrag_ave to choose between two methods to calculate the grid average of 
+!!    the roughness height. If set to true: the grid average is calculated by the drag coefficients 
+!!    per PFT. If set to false: the grid average is calculated by the logarithm of the 
+!!    roughness height per PFT.\n
+!! 2. :: impaze for choosing surface parameters. If set to false, the values for the 
+!!    soil albedo, emissivity and roughness height are set to default values which are read from 
+!!    the run.def. If set to true, the user imposes its own values, fixed for the grid point. 
+!!    This is useful if one performs site simulations, however, 
+!!    it is not recommended to do so for spatialized simulations.
+!!    roughheight_scal imposes the roughness height in (m) , 
+!!    same for emis_scal (in %), albedo_scal (in %), zo_scal (in m)                       
+!!    Note that these values are only used if 'impaze' is true.\n
+!! 3. :: alb_bare_model for choosing values of bare soil albedo. If set to TRUE bare 
+!!    soil albedo depends on soil wetness. If set to FALSE bare soil albedo is the mean 
+!!    values of wet and dry soil albedos.\n
+!!    The surface fluxes are calculated between two levels: the atmospheric level reference and the effective roughness height 
+!!    defined as the difference between the mean height of the vegetation and the displacement height (zero wind 
+!!    level). Over bare soils, the zero wind level is equal to the soil roughness. Over vegetation, the zero wind level
+!!    is increased by the displacement height
+!!    which depends on the height of the vegetation. For a grid point composed of different types of vegetation, 
+!!    an effective surface roughness has to be calculated
+
+!! RECENT CHANGE(S) : None
+!!
+!! REFERENCES(S)    : None
+!!
+!! SVN              :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE condveg
+  !
+  USE ioipsl
+  USE xios_orchidee
+  !
+  ! modules used :
+  USE constantes
+  USE constantes_soil
+  USE pft_parameters
+  USE interpol_help
+  USE ioipsl_para
+  USE albedo
+  USE slowproc
+
+  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
+!$OMP THREADPRIVATE(l_first_condveg)
+  REAL(r_std), ALLOCATABLE, SAVE    :: soilalb_dry(:,:)                 !! Albedo values for the dry bare soil (unitless)
+!$OMP THREADPRIVATE(soilalb_dry)
+  REAL(r_std), ALLOCATABLE, SAVE    :: soilalb_wet(:,:)                 !! Albedo values for the wet bare soil (unitless)
+!$OMP THREADPRIVATE(soilalb_wet)
+  REAL(r_std), ALLOCATABLE, SAVE    :: soilalb_moy(:,:)                 !! Albedo values for the mean bare soil (unitless)
+!$OMP THREADPRIVATE(soilalb_moy)
+  REAL(r_std), ALLOCATABLE, SAVE    :: alb_bare(:,:)                    !! Mean bare soil albedo for visible and near-infrared 
+                                                                        !! range (unitless) 
+!$OMP THREADPRIVATE(alb_bare)
+  REAL(r_std), ALLOCATABLE, SAVE    :: alb_veget(:,:)                   !! Mean vegetation albedo for visible and 
+                                                                        !! near-infrared range (unitless) 
+!$OMP THREADPRIVATE(alb_veget)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)  :: albedo_snow         !! Mean snow albedo over visible and near-infrared 
+                                                                        !! range (unitless) 
+!$OMP THREADPRIVATE(albedo_snow)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)  :: albedo_glob         !! Mean surface albedo over visible and 
+                                                                        !! near-infrared range (unitless)
+!$OMP THREADPRIVATE(albedo_glob)
+CONTAINS
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : condveg_main
+!!
+!>\BRIEF        Calls the subroutines to initialise the variables, update the variables
+!! and write out data and restart files. 
+!!
+!!
+!! MAIN OUTPUT VARIABLE(S):  emis (emissivity), albedo (albedo of 
+!! vegetative PFTs in visible and near-infrared range), z0 (surface roughness height),
+!! roughheight (grid effective roughness height), soil type (fraction of soil types) 
+!! 
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!!
+!! REVISION(S)  : None
+!!
+!_ ================================================================================================================================
+
+  SUBROUTINE condveg_main (kjit, kjpindex, dtradia, 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,  emis, albedo, z0, roughheight, &
+       rest_id, hist_id, hist2_id, lai, &
+       sinang, circ_class_biomass, circ_class_n, &
+       lai_split,z0_veg, Isotrop_Abs_Tot_p, Isotrop_Tran_Tot_p, &
+       laieff_fit, albedo_pft, frac_snow_nobio, frac_snow_veg)
+
+     !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables  
+
+    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_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,nvm), INTENT(in)    :: lai            !! Leaf area index (m^2 m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)        :: sinang        !! the sine of the solar angle from the horizon (unitless)
+    REAL(r_std), DIMENSION(kjpindex,nvm,ncirc,nparts,nelements), &
+                                   INTENT(IN)           :: circ_class_biomass !! Stem diameter 
+                                                                                          !! @tex $(m)$ @endtex
+    REAL(r_std), DIMENSION(kjpindex,nvm,ncirc), &
+                                   INTENT(IN)           :: circ_class_n       !! Number of trees within each circumference
+    REAL(r_std),DIMENSION(nlevels),INTENT(IN)           :: lai_split !!!!temp
+    TYPE(laieff_type),DIMENSION (:,:,:),INTENT(in)      :: laieff_fit      !! Fitted parameters for the effective LAI
+
+    !! 0.2 Output variables
+
+    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), INTENT(out)       :: z0_veg           !! Roughness height of vegetated part (m)
+    REAL(r_std),DIMENSION (:,:,:), &
+                                        INTENT (out)    :: Isotrop_Abs_Tot_p !! Absorbed radiation per level for photosynthesis
+    REAL(r_std),DIMENSION (:,:,:), &
+                                        INTENT (out)    :: Isotrop_Tran_Tot_p !! Transmitted radiation per level for photosynthesis
+    REAL(r_std), DIMENSION(kjpindex,nvm,n_spectralbands), &
+                                    INTENT (out)        :: albedo_pft       !! Albedo (two stream radiation transfer model)
+                                                                            !! for visible and near-infrared range 
+                                                                            !! for each PFT (unitless)
+    REAL(r_std), DIMENSION(kjpindex,nnobio), INTENT(out):: frac_snow_nobio  !! Fraction of snow on continental ice, lakes, etc. 
+                                                                            !! (unitless ratio)
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)   :: frac_snow_veg    !! the fraction of ground covered with snow, between 0 and 1
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables   
+
+    CHARACTER(LEN=80)                                   :: var_name         !! To store variables names for I/O
+!_ ================================================================================================================================
+  
+    !! 1. Call subroutines to start initialisation
+    ! Is TRUE if condveg is called the first time
+    IF (l_first_condveg) THEN
+       ! Document what the programm is doing
+        IF (long_print) WRITE (numout,*) ' l_first_condveg : call condveg_init '
+
+        ! Call the subroutine 'condveg_init' to allocate local array
+        CALL condveg_init (kjit, kjpindex, index, veget, &
+                           lalo, neighbours, resolution, contfrac, rest_id)
+
+        ! Call the subroutine 'condveg_var_init' to initialise local array
+        ! Reads in map for soil albedo
+         CALL condveg_var_init (kjpindex, veget, veget_max, frac_nobio, &
+              totfrac_nobio, drysoil_frac, zlev, height, &
+              circ_class_biomass, circ_class_n, emis, albedo, &
+              z0, roughheight, lai, sinang, &
+              snow, snow_age, snow_nobio, snow_nobio_age, albedo_snow, &
+              albedo_glob, lai_split, z0_veg, Isotrop_Abs_Tot_p,&
+              Isotrop_Tran_Tot_p, laieff_fit, albedo_pft, frac_snow_nobio,&
+              frac_snow_veg)
+
+
+        RETURN
+
+    ENDIF
+
+    !! 2. Call subroutines to update fields
+
+    ! Call the routine 'condveg_var_update' to update the fields of albedo, emissivity and roughness
+    CALL condveg_var_update (kjpindex, veget, veget_max, frac_nobio, &
+         totfrac_nobio, drysoil_frac, zlev, height,  &
+         circ_class_biomass, circ_class_n, emis, albedo, &
+         z0, roughheight, lai, sinang, &
+         snow, snow_age, snow_nobio, snow_nobio_age, albedo_snow, &
+         albedo_glob, lai_split,z0_veg, Isotrop_Abs_Tot_p, Isotrop_Tran_Tot_p, &
+         laieff_fit, albedo_pft, frac_snow_nobio, frac_snow_veg)
+
+    !! 3. Call subroutines to write restart files and data
+
+    ! To write restart files for soil albedo variables
+    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 this logical flag is set to true, the model
+    ! will output all its data according to the ALMA 
+    ! convention. 
+    ! To facilitate the exchange of forcing data for land-surface schemes and the results produced by these schemes, 
+    ! ALMA (Assistance for Land-surface Modelling activities) proposes to establish standards. 
+    ! http://www.lmd.jussieu.fr/~polcher/ALMA/
+    CALL xios_orchidee_send_field("soilalb_vis",alb_bare(:,1))
+    CALL xios_orchidee_send_field("soilalb_nir",alb_bare(:,2))
+    CALL xios_orchidee_send_field("vegalb_vis",alb_veget(:,1))
+    CALL xios_orchidee_send_field("vegalb_nir",alb_veget(:,2))
+    CALL xios_orchidee_send_field("albedo_alma",albedo_glob)
+    CALL xios_orchidee_send_field("SAlbedo",albedo_snow)
+    
+    ! These variables are NOT written out in the ALMA convention.  
+    ! At least, they are not declared this way in intersurf.
+    IF( .NOT. almaoutput)THEN
+       CALL histwrite_p(hist_id, 'soilalb_vis', kjit, alb_bare(:,1), kjpindex, index)
+       CALL histwrite_p(hist_id, 'soilalb_nir', kjit, alb_bare(:,2), kjpindex, index)
+       CALL histwrite_p(hist_id, 'vegalb_vis',  kjit, alb_veget(:,1), kjpindex, index)
+       CALL histwrite_p(hist_id, 'vegalb_nir',  kjit, alb_veget(:,2), kjpindex, index)
+       CALL histwrite_p(hist2_id, 'soilalb_vis', kjit, alb_bare(:,1), kjpindex, index)
+       CALL histwrite_p(hist2_id, 'soilalb_nir', kjit, alb_bare(:,2), kjpindex, index)
+       CALL histwrite_p(hist2_id, 'vegalb_vis',  kjit, alb_veget(:,1), kjpindex, index)
+       CALL histwrite_p(hist2_id, 'vegalb_nir',  kjit, alb_veget(:,2), kjpindex, index)
+    ENDIF
+
+    IF (long_print) WRITE (numout,*)' condveg_main done '
+
+
+  END SUBROUTINE condveg_main
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : condveg_init
+!!
+!>\BRIEF        Dynamic allocation of the variables, the dimensions of the 
+!! variables are determined by user-specified settings.
+!!
+!! DESCRIPTION  : The domain size (:: kjpindex) is used to allocate the correct 
+!! dimensions to all variables in condveg.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): Strictly speaking the subroutine has no output 
+!! variables. However, the routine allocates memory and builds new indexing 
+!! variables for later use.
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    :  None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE condveg_init  (kjit, kjpindex, index, veget, &
+                            lalo, neighbours, resolution, contfrac, rest_id)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1. Input variables  
+
+    INTEGER(i_std), INTENT(in)                       :: kjit             !! Time step number (unitless)          
+    INTEGER(i_std), INTENT(in)                       :: kjpindex         !! Domain size - Number of land pixels  (unitless)
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index            !! Index for the points on the map (unitless)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in):: veget            !! PFT coverage fraction of a PFT (= ind*cn_ind) 
+                                                                         !! (m^2 m^{-2}) 
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (in)  :: lalo             !! Geographical coordinates (degree)
+    INTEGER(i_std),DIMENSION (kjpindex,8), INTENT(in):: neighbours       !! Neighbouring land grid cell
+    REAL(r_std), DIMENSION (kjpindex,2), INTENT(in)  :: resolution       !! Size of grid in x and y direction (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 
+
+    !! 0.2. Output variables
+
+    !! 0.3 Modified variables          
+  
+    !! 0.4 Local variables
+ 
+    INTEGER(i_std)                                  :: ji               !! Index
+    INTEGER(i_std)                                  :: ier              !! Check errors in memory allocation
+    CHARACTER(LEN=80)                               :: var_name         !! To store variables names for I/O 
+
+!_ ================================================================================================================================
+  
+    !! 1. Choice of calculation of snow albedo and soil albedo
+
+    ! Is TRUE if condveg is called the first time
+    IF (l_first_condveg) THEN 
+       !       
+       l_first_condveg=.FALSE.
+
+    !! 2. Allocate all albedo variables
+       
+       ! Dry soil albedo
+       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
+
+       ! Wet soil albedo
+       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
+
+       ! Mean soil albedo
+       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
+
+       ! Snow albedo of vegetative PFTs
+       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
+       
+       ! Mean vegetation albedo over visible and near-infrared range 
+       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
+       
+       ! Mean bare soil albedo
+       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
+
+       ! Mean vegetation albedo
+       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
+
+       
+    !! 3. Initialise bare soil albedo
+       
+       ! dry soil albedo
+       var_name= 'soilalbedo_dry'
+       CALL ioconf_setatt_p('UNITS', '-')
+       CALL ioconf_setatt_p('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)
+
+       ! wet soil albedo
+       var_name= 'soilalbedo_wet'
+       CALL ioconf_setatt_p('UNITS', '-')
+       CALL ioconf_setatt_p('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)
+
+       ! mean soil aledo
+       var_name= 'soilalbedo_moy'
+       CALL ioconf_setatt_p('UNITS', '-')
+       CALL ioconf_setatt_p('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)
+       
+       ! check if we have real values and not only missing values
+       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
+
+    IF (long_print) WRITE (numout,*) ' condveg_init done '
+
+  END SUBROUTINE condveg_init
+
+!! ==============================================================================================================================
+!! SUBROUTINE 	: condveg_clear
+!!
+!>\BRIEF        Deallocate albedo variables
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): None 
+!!
+!! REFERENCES	: None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE condveg_clear  ()
+
+      l_first_condveg=.TRUE.
+       
+      ! Dry soil albedo
+       IF (ALLOCATED (soilalb_dry)) DEALLOCATE (soilalb_dry)
+       ! Wet soil albedo
+       IF (ALLOCATED(soilalb_wet))  DEALLOCATE (soilalb_wet)
+       ! Mean soil albedo
+       IF (ALLOCATED(soilalb_moy))  DEALLOCATE (soilalb_moy)
+       ! Mean snow albedo
+       IF (ALLOCATED(albedo_snow))  DEALLOCATE (albedo_snow)
+       ! Mean albedo
+       IF (ALLOCATED(albedo_glob))  DEALLOCATE (albedo_glob)
+       ! Mean albedo of bare soil
+       IF (ALLOCATED(alb_bare))  DEALLOCATE (alb_bare)
+       ! Mean vegetation albedo
+       IF (ALLOCATED(alb_veget))  DEALLOCATE (alb_veget)
+
+  END SUBROUTINE condveg_clear
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : condveg_var_init
+!!
+!>\BRIEF        Initialisation of local array and calculation of emissivity,
+!! albedo and roughness height.
+!!
+!! DESCRIPTION : None
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n 
+!_ ================================================================================================================================
+
+  SUBROUTINE condveg_var_init  (kjpindex, veget, veget_max, frac_nobio, &
+       totfrac_nobio, drysoil_frac, zlev, height,  &
+       circ_class_biomass, circ_class_n, emis, albedo, &
+       z0, roughheight, lai, sinang, &
+       snow, snow_age, snow_nobio, snow_nobio_age, albedo_snow, &
+       albedo_glob, lai_split,z0_veg, Isotrop_Abs_Tot_p, &
+       Isotrop_Tran_Tot_p, laieff_fit, albedo_pft, frac_snow_nobio,&
+       frac_snow_veg)
+
+    !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                          :: kjpindex         !! Domain size - Number of land pixels  (unitless)  
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in)    :: veget            !!  PFT coverage fraction of a PFT (= ind*cn_ind)
+                                                                            !! (m^2 m^{-2})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in)    :: veget_max        !! PFT "Maximal" coverage fraction of a PFT 
+                                                                            !! (= ind*cn_ind) (m^2/m^{-2})  
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: frac_nobio       !! Fraction of non-vegetative surfaces, i.e. 
+                                                                            !! continental ice, lakes, etc. (unitless)  
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)        :: totfrac_nobio    !! Total fraction of non-vegetative surfaces, i.e. 
+                                                                            !! continental ice, lakes, etc. (unitless) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)        :: drysoil_frac     !! Fraction of dry soil in visible range (unitless)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: zlev             !! Height of first layer (m)   
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in)    :: height           !! Vegetation height (m)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)   :: lai              !! Leaf area index (m^2 m^{-2})
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in)        :: sinang           !! the sine of the solar angle from the horizon (unitless)
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)        :: snow             !! Snow mass in vegetation (kg m^{-2})           
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: snow_nobio       !! Snow mass on continental ice, lakes, etc. (kg m^{-2})      
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)        :: snow_age         !! Snow age (days)        
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: snow_nobio_age   !! Snow age on continental ice, lakes, etc. (days) 
+    REAL(r_std), DIMENSION(kjpindex,nvm,ncirc,nparts,nelements), &
+                                               INTENT(IN)           :: circ_class_biomass !! Stem diameter 
+                                                                                          !! @tex $(m)$ @endtex
+    REAL(r_std), DIMENSION(kjpindex,nvm,ncirc), INTENT(IN)           :: circ_class_n       !! Number of trees within each circumference
+    REAL(r_std),DIMENSION(nlevels),INTENT(IN)           :: lai_split
+    TYPE(laieff_type),DIMENSION (:,:,:),INTENT(in)      :: laieff_fit      !! Fitted parameters for the effective LAI
+
+    !! 0.2 Output varialbes
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: emis             !! Surface emissivity (unitless) 
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (out)    :: albedo           !! Albedo of vegetative PFTs in visible and 
+                                                                            !! near-infrared range   
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: z0               !! Soil roughness height (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: roughheight      !!  Grid effective roughness height (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: albedo_snow      !! Snow albedo (unitless ratio)     
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: albedo_glob      !! Mean albedo (unitless ratio)
+    REAL(r_std),DIMENSION (:,:,:), &
+                                           INTENT (out) :: Isotrop_Abs_Tot_p !! Absorbed radiation per level for photosynthesis
+    REAL(r_std),DIMENSION (:,:,:), &
+                                           INTENT (out) :: Isotrop_Tran_Tot_p !! Transmitted radiation per level for photosynthesis
+
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)       :: z0_veg           !! Roughness height of vegetated part (m)
+    REAL(r_std), DIMENSION(kjpindex,nvm,n_spectralbands), &
+                                    INTENT (out)        :: albedo_pft       !! Albedo (two stream radiation transfer model)
+                                                                            !! for visible and near-infrared range 
+    REAL(r_std), DIMENSION(kjpindex,nnobio), INTENT(out):: frac_snow_nobio  !! Fraction of snow on continental ice, lakes, etc. 
+                                                                            !! (unitless ratio)
+   REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: frac_snow_veg    !! the fraction of ground covered with snow, between 0 and 1
+                                                                            !! for each PFT (unitless)
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                      :: ier              !! Check errors 
+    INTEGER(i_std)                                      :: jv               !! Index
+
+!_ ================================================================================================================================   
+
+
+    !! 1. Choice of parameter setting
+    
+    ! This switch is for choosing surface parameters.
+    ! If it is set to true, the values for the soil roughness, emissivity
+    ! and albedo are set to default values which are read in from the run.def.
+    ! This is useful if one performs a single site simulations, 
+    ! it is not recommended to do so for global simulations.
+    
+
+    !! 2. Calculate emissivity
+    
+    ! If TRUE read in default values for emissivity
+    
+    IF ( impaze ) THEN
+       !
+       emis(:) = emis_scal
+       !
+    ! If FALSE set emissivity to 1.
+    ELSE
+       emis_scal = un
+       emis(:) = emis_scal
+    ENDIF
+
+    !! 3. Calculate roughness height
+    
+    ! Chooses between two methods to calculate the grid average of the roughness.
+    ! If set to true:  The grid average is calculated by averaging the drag coefficients over PFT.
+    ! If set to false: The grid average is calculated by averaging the logarithm of the roughness length per PFT.
+
+    !  TRUE read in default values for roughness height
+    IF ( impaze ) THEN
+      
+      z0(:) = z0_scal
+      roughheight(:) = roughheight_scal
+
+    ! If FALSE calculate roughness height
+    ELSE
+
+       IF ( z0cdrag_ave ) THEN
+          CALL condveg_z0cdrag(kjpindex, veget, veget_max, frac_nobio, totfrac_nobio, zlev, &
+               &               height, z0, roughheight, z0_veg)
+       ELSE
+          CALL condveg_z0logz(kjpindex, veget, veget_max, frac_nobio, totfrac_nobio, height, &
+               &              z0, roughheight, z0_veg)
+       ENDIF
+
+    ENDIF
+
+    !! 4. Calculate albedo
+
+    ! If TRUE read in default values for albedo
+    IF ( impaze ) THEN
+       !
+       albedo(:,ivis) = albedo_scal(ivis)
+       albedo(:,inir) = albedo_scal(inir)
+       !
+    ELSE
+
+    ! check to see which type of albedo we are using
+       SELECTCASE (albedo_type)
+       CASE ('standard')
+          CALL albedo_calc (kjpindex, drysoil_frac, veget,&
+               soilalb_dry, soilalb_wet, soilalb_moy, tot_bare_soil, alb_veget, alb_bare, albedo)
+          ! Initialize these variables here. They are only computed in the two_stream model.
+          Isotrop_Abs_Tot_p(:,:,:)=undef_sechiba
+          Isotrop_Tran_Tot_p(:,:,:)=undef_sechiba
+          frac_snow_nobio(:,:)=undef_sechiba
+          frac_snow_veg(:,:)=undef_sechiba
+
+       CASE ('pinty')
+          ! We need to initialize albedo here to give a realistic guess to the coupled
+          ! model.
+           CALL albedo_two_stream(kjpindex, nlevels_tot, drysoil_frac, lai, veget_max, &
+               sinang, soilalb_dry, soilalb_wet, frac_nobio, soilalb_moy, &
+               alb_bare, albedo, snow, snow_age, snow_nobio, &
+               snow_nobio_age, albedo_snow, albedo_glob, &
+               circ_class_biomass, circ_class_n,&
+               lai_split, z0_veg, Isotrop_Abs_Tot_p, Isotrop_Tran_Tot_p, &
+               laieff_fit, albedo_pft, frac_snow_nobio, frac_snow_veg)
+
+
+       CASE DEFAULT
+          WRITE(numout,*) "Unsupported albedo type. This should have been caught in intersurf!"
+          STOP 'condveg'
+       END SELECT
+
+ 
+    ENDIF
+
+    !! Calculate snow albedo.  This is tricky because the new scheme requires information about snow to be
+    !! passed to it, while the old scheme uses existing albedo data
+    SELECTCASE (albedo_type)
+    CASE ('standard')
+       CALL calculate_surface_albedo_with_snow(kjpindex, veget, veget_max, frac_nobio, totfrac_nobio, &
+            snow, snow_age, snow_nobio, snow_nobio_age, tot_bare_soil, albedo, albedo_snow, albedo_glob)
+    CASE ('pinty')
+    CASE DEFAULT
+       WRITE(numout,*) "Unsupported albedo type. This should have been caught in intersurf!"
+       STOP 'condveg'
+    END SELECT
+
+    IF (long_print) WRITE (numout,*) ' condveg_var_init done '
+
+  END SUBROUTINE condveg_var_init
+
+  
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : condveg_var_update
+!!
+!>\BRIEF        Update emissivity, albedo and roughness height.
+!!
+!! DESCRIPTION  : None
+!!
+!! MAIN OUTPUT VARIABLE(S): \n
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE condveg_var_update  (kjpindex, veget, veget_max, frac_nobio, &
+       totfrac_nobio, drysoil_frac, zlev, height, &
+       circ_class_biomass, circ_class_n, emis, albedo, &
+       z0, roughheight, lai, sinang, &
+       snow, snow_age, snow_nobio, snow_nobio_age, albedo_snow, &
+       albedo_glob, lai_split, z0_veg, Isotrop_Abs_Tot_p, Isotrop_Tran_Tot_p, &
+       laieff_fit, albedo_pft, frac_snow_nobio, frac_snow_veg)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                          :: kjpindex         !! Domain size - Number of land pixels  (unitless) 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in)    :: veget            !! PFT coverage fraction of a PFT (= ind*cn_ind)
+                                                                            !! (m^2 m^{-2})  
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in)    :: veget_max        !! PFT "Maximal" coverage fraction of a PFT 
+                                                                            !! (= ind*cn_ind) (m^2 m^{-2})  
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: frac_nobio       !! Fraction of non-vegetative surfaces, i.e. 
+                                                                            !! continental ice, lakes, etc. (unitless)  
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)        :: totfrac_nobio    !! Total fraction of non-vegetative surfaces, i.e. 
+                                                                            !! continental ice, lakes, etc. (unitless)   
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)        :: drysoil_frac     !! Fraction of dry soil in visible range (unitless)   
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: zlev             !! Height of first layer (m)       
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in)    :: height           !! Vegetation height (m)         
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)   :: lai              !! Leaf area index (m^2 m^{-2})
+    REAL(r_std),DIMENSION(kjpindex), INTENT(in)         :: sinang           !! the sine of the solar angle from the horizon (unitless)
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)        :: snow             !! Snow mass in vegetation (kg m^{-2})           
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: snow_nobio       !! Snow mass on continental ice, lakes, etc. (kg m^{-2})      
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)        :: snow_age         !! Snow age (days)        
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: snow_nobio_age   !! Snow age on continental ice, lakes, etc. (days) 
+    REAL(r_std), DIMENSION(kjpindex,nvm,ncirc,nparts,nelements), &
+                                   INTENT(IN)           :: circ_class_biomass !! Stem diameter 
+                                                                                          !! @tex $(m)$ @endtex
+    REAL(r_std), DIMENSION(kjpindex,nvm,ncirc), INTENT(IN)           :: circ_class_n       !! Number of trees within each circumference
+    REAL(r_std),DIMENSION(nlevels),INTENT(IN)           :: lai_split
+    TYPE(laieff_type),DIMENSION (:,:,:),INTENT(in)      :: laieff_fit      !! Fitted parameters for the effective LAI
+
+
+    !! 0.2 Output variables   
+       
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: emis              !! Emissivity (unitless)            
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (out)    :: albedo            !! Albedo of vegetative PFTs in visible and 
+                                                                             !! near-infrared range  
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: z0                !! Roughness height (m)              
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: roughheight       !! Grid effective roughness height (m)     
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: albedo_snow       !! Snow albedo (unitless ratio)     
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: albedo_glob       !! Mean albedo (unitless ratio)
+    REAL(r_std),DIMENSION (:,:,:), &
+                                           INTENT (out) :: Isotrop_Abs_Tot_p !!Absorbed radiation per level for photosynthesis
+    REAL(r_std),DIMENSION (:,:,:), &
+                                           INTENT (out) :: Isotrop_Tran_Tot_p !!Transmitted radiation per level for photosynthesis
+
+    REAL(r_std), DIMENSION(kjpindex), INTENT (out)      :: z0_veg            !! Roughness height of vegetated part (m)
+    REAL(r_std), DIMENSION(kjpindex,nvm,n_spectralbands), &
+                                    INTENT (out)        :: albedo_pft       !! Albedo (two stream radiation transfer model)
+                                                                            !! for visible and near-infrared range 
+                                                                            !! for each PFT (unitless)
+   REAL(r_std), DIMENSION(kjpindex,nnobio), INTENT(out) :: frac_snow_nobio    !! Fraction of snow on continental ice, lakes, etc. 
+                                                                            !! (unitless ratio)
+   REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: frac_snow_veg      !! the fraction of ground covered with snow, between 0 and 1
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                      :: ji, jv           !! Indeces
+!_ ================================================================================================================================
+
+    !! 1. Calculate emissivity
+    
+    emis(:) = emis_scal
+    
+    !! 2. Calculate roughness height
+    
+    ! If TRUE read in prescribed values for roughness height
+    IF ( impaze ) THEN
+
+       DO ji = 1, kjpindex
+         z0(ji) = z0_scal
+         roughheight(ji) = roughheight_scal
+      ENDDO
+
+    ! Calculate roughness height
+    ELSE
+     
+       IF ( z0cdrag_ave ) THEN
+          CALL condveg_z0cdrag (kjpindex, veget, veget_max, frac_nobio, totfrac_nobio, zlev, height, &
+               &                z0, roughheight, z0_veg)
+       ELSE
+          CALL condveg_z0logz (kjpindex, veget, veget_max, frac_nobio, totfrac_nobio, height, &
+               &               z0, roughheight, z0_veg)
+       ENDIF
+     
+    ENDIF
+
+    !! 3. Calculate albedo
+    ! This has to be done after the calculation of the roughness height, since it uses
+    ! the roughness height for calculating the snow coverage fraction.
+
+    ! If TRUE read in prescribed values for albedo
+    IF ( impaze ) THEN
+
+       albedo(:,ivis) = albedo_scal(ivis)
+       albedo(:,inir) = albedo_scal(inir)
+
+    ! If FALSE calculate albedo from ORCHIDEE default values
+    ELSE
+
+       ! check to see which type of albedo we are using
+       SELECTCASE (albedo_type)
+       CASE ('standard')
+          CALL albedo_calc (kjpindex, drysoil_frac, veget,&
+               soilalb_dry, soilalb_wet, soilalb_moy, tot_bare_soil,alb_veget, alb_bare, albedo)
+          ! Initialize these variables here. They are only computed in the two_stream model.
+          Isotrop_Abs_Tot_p(:,:,:)=undef_sechiba
+          Isotrop_Tran_Tot_p(:,:,:)=undef_sechiba
+          frac_snow_nobio(:,:)=undef_sechiba
+          frac_snow_veg(:,:)=undef_sechiba
+       CASE ('pinty')
+
+          
+          CALL albedo_two_stream(kjpindex, nlevels_tot, drysoil_frac, lai, veget_max, &
+               sinang, soilalb_dry, soilalb_wet, frac_nobio, soilalb_moy, &
+               alb_bare, albedo, snow, snow_age, snow_nobio, &
+               snow_nobio_age, albedo_snow, albedo_glob, &
+               circ_class_biomass, circ_class_n,  lai_split, z0_veg, Isotrop_Abs_Tot_p,&
+               Isotrop_Tran_Tot_p, laieff_fit, albedo_pft, frac_snow_nobio,&
+               frac_snow_veg)
+
+
+       CASE DEFAULT
+          WRITE(numout,*) "Unsupported albedo type. This should have been caught in intersurf!"
+          STOP 'condveg'
+       END SELECT
+
+    ENDIF
+    
+    !! Calculate snow albedo.  
+    ! The scheme of Pinty et al calculates the snow albedo in the albedo_two_stream routine,
+    ! since it changes the background albedo.  The old scheme calculates it separately.
+    SELECTCASE (albedo_type)
+    CASE ('standard')
+       CALL calculate_surface_albedo_with_snow(kjpindex, veget, veget_max, frac_nobio, totfrac_nobio, &
+            snow, snow_age, snow_nobio, snow_nobio_age, tot_bare_soil, albedo, albedo_snow, albedo_glob)
+    CASE ('pinty')
+    CASE DEFAULT
+       WRITE(numout,*) "Unsupported albedo type. This should have been caught in intersurf!"
+       STOP 'condveg'
+    END SELECT
+
+    IF (long_print) WRITE (numout,*) ' condveg_var_update done '
+
+  END SUBROUTINE condveg_var_update
+
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : condveg_soilalb
+!!
+!>\BRIEF        This subroutine calculates the albedo of soil (without snow).
+!!
+!! DESCRIPTION  This subroutine reads the soil colour maps in 1 x 1 deg resolution 
+!! from the Henderson-Sellers & Wilson database. These values are interpolated to 
+!! the model's resolution and transformed into 
+!! dry and wet albedos.\n
+!!
+!! If the soil albedo is calculated without the dependence of soil moisture, the
+!! soil colour values are transformed into mean soil albedo values.\n 
+!!
+!! The calculations follow the assumption that the grid of the data is regular and 
+!! it covers the globe. The calculation for the model grid are based on the borders 
+!! of the grid of the resolution.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):    soilalb_dry for visible and near-infrared range,
+!!                             soilalb_wet for visible and near-infrared range, 
+!!                             soilalb_moy for visible and near-infrared range 
+!!
+!! REFERENCE(S) : 
+!! -Wilson, M.F., and A. Henderson-Sellers, 1985: A global archive of land cover and
+!!  soils data for use in general circulation climate models. J. Clim., 5, 119-143.
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE condveg_soilalb(nbpt, lalo, neighbours, resolution, contfrac, soilalb_dry,soilalb_wet)
+  
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                    :: nbpt                  !! Number of points for which the data needs to be 
+                                                                           !! interpolated (unitless)             
+    REAL(r_std), INTENT(in)                       :: lalo(nbpt,2)          !! Vector of latitude and longitudes (degree)        
+    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 of each grid cell in X and Y (m)
+    REAL(r_std), INTENT(in)                       :: contfrac(nbpt)        !! Fraction of land in each grid cell (unitless)   
+    REAL(r_std), INTENT(inout)                    :: soilalb_dry(nbpt,2)   !! Albedo of the dry bare soil (unitless)
+    REAL(r_std), INTENT(inout)                    :: soilalb_wet(nbpt,2)   !! Albedo of the wet dry soil (unitless)
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                :: nbvmax                !! nbvmax for interpolation (unitless). It is the 
+                                                                           !! dimension of the variables in which we store the list
+                                                                           !! of points of the source grid which fit into one grid 
+                                                                           !! box of the target. 
+    CHARACTER(LEN=80)                             :: filename              !! Filename of soil colour map
+    INTEGER(i_std)                                :: iml, jml, lml, &
+                      &tml, fid, ib, ip, jp, fopt, ilf, lastjp, nbexp      !! Indices
+    REAL(r_std)                                   :: lev(1), date, dt      !! Help variables to read in file data
+    INTEGER(i_std)                                :: itau(1)               !! Help variables to read in file data
+    REAL(r_std)                                   :: sgn                   !! Help variable to compute average bare soil albedo 
+    REAL(r_std)                                   :: coslat                !! [DISPENSABLE]
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lat_rel               !! Help variable to read file data and allocate memory
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lon_rel               !! Help variable to read file data and allocate memory
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: soilcol               !! Help variable to read file data and allocate memory
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: sub_area              !! Help variable to read file data and allocate memory
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: sub_index             !! Help variable to read file data and allocate memory
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: mask                  !! Help variable to read file data and allocate memory
+    CHARACTER(LEN=30)                             :: callsign              !! Help variable to read file data and allocate memory
+    LOGICAL                                       :: ok_interpol = .FALSE. !! Optional return of aggregate_2d
+    INTEGER                                       :: ALLOC_ERR             !! Help varialbe to count allocation error
+!_ ================================================================================================================================
+  
+  !! 1. Open file and allocate memory
+
+  ! Open file with soil colours 
+
+  !Config Key   = SOILALB_FILE
+  !Config Desc  = Name of file from which the bare soil albedo
+  !Config Def   = soils_param.nc
+  !Config If    = NOT(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.
+  !Config Units = [FILE]
+  !
+  filename = 'soils_param.nc'
+  CALL getin_p('SOILALB_FILE',filename)
+  
+  ! Read data from file
+  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 memory for latitudes
+  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
+
+  ! Allcoate memory for longitude
+  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
+
+  ! Allocate memory for mask
+  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
+
+  ! Allocate memory for soil data
+  ALLOC_ERR=-1
+  ALLOCATE(soilcol(iml,jml), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+     WRITE(numout,*) "ERROR IN ALLOCATION of soiltext : ",ALLOC_ERR
+     STOP 
+  ENDIF
+  
+  ! Set values
+  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)
+  
+  ! Create mask with values of soil colour
+  mask(:,:) = zero
+  DO ip=1,iml
+     DO jp=1,jml
+        IF (soilcol(ip,jp) > min_sechiba) THEN
+           mask(ip,jp) = un
+        ENDIF
+     ENDDO
+  ENDDO
+  
+  ! Set nbvmax to 200 for interpolation
+  ! This number is the dimension of the variables in which we store 
+  ! the list of points of the source grid which fit into one grid box of the target. 
+  nbvmax = 200
+  
+  callsign = 'Soil color map'
+  
+  ! Start with interpolation
+  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
+         WRITE(numout,*) "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
+        WRITE(numout,*) "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
+  
+  ! Check how many points with soil information are found
+  nbexp = 0
+
+  soilalb_dry(:,:) = zero
+  soilalb_wet(:,:) = zero
+  soilalb_moy(:,:) = zero
+
+  DO ib=1,nbpt ! Loop over domain size
+
+     fopt =  COUNT(sub_area(ib,:) > zero)
+
+     !! 3. Compute the average bare soil albedo parameters
+     
+     IF ( fopt .EQ. 0) THEN      ! If no points were interpolated
+        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
+        soilalb_moy(ib,ivis) = SUM(albsoil_vis)/classnb
+        soilalb_moy(ib,inir) = SUM(albsoil_nir)/classnb
+     ELSE
+        sgn = zero
+
+        DO ilf = 1,fopt         ! If points were interpolated
+           
+           ip = sub_index(ib,ilf,1)
+           jp = sub_index(ib,ilf,2)
+           
+           ! Weighted albedo values by interpolation area
+           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)
+              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
+           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
+           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
+!!
+!>\BRIEF        Computation of grid average of roughness height by averaging  the 
+!! logarithm of the roughness height of each grid box components fracbio and fracnobio.
+!!
+!! DESCRIPTION  : Calculates mean roughness height
+!!  over the grid cell. The mean roughness height is derived from the vegetation 
+!! height which is scaled by the roughness parameter. The sum of the logarithm of the 
+!! roughness times the fraction per grid cell gives the average roughness height per 
+!! grid cell for the vegetative PFTs. The roughness height for the non-vegetative PFTs 
+!! is calculated in a second step. \n
+!!
+!! To compute the fluxes,  
+!! the difference between the height of the vegetation and the zero plane displacement height
+!! is needed and called roughheight .\n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): roughness height (z0), grid effective roughness height (roughheight)
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE condveg_z0logz (kjpindex, veget, veget_max, frac_nobio, totfrac_nobio, height, &
+       &                     z0, roughheight, z0_veg)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+    
+    INTEGER(i_std), INTENT(in)                          :: kjpindex      !! Domain size - Number of land pixels  (unitless) 
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in)    :: veget         !! PFT coverage fraction of a PFT (= ind*cn_ind) 
+                                                                         !! (m^2 m^{-2})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in)    :: veget_max     !! PFT "Maximal" coverage fraction of a PFT 
+                                                                         !! (= ind*cn_ind) (m^2 m^{-2})
+    REAL(r_std), DIMENSION(kjpindex,nnobio), INTENT(in) :: frac_nobio    !! Fraction of non-vegetative surfaces, 
+                                                                         !! i.e. continental ice, lakes, etc. (unitless)
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in)        :: totfrac_nobio !! Total fraction of non-vegetative surfaces, 
+                                                                         !! i.e. continental ice, lakes, etc. (unitless)
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in)    :: height        !! Vegetation height (m)
+    
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)       :: z0            !! Soil roughness height (m) 
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)       :: roughheight   !! Grid effective roughness height (m) 
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)       :: z0_veg        !! Roughness height of vegetated part (m)
+    
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    
+    INTEGER(i_std)                                      :: jv            !! Loop index over PFTs (unitless)
+    REAL(r_std), DIMENSION(kjpindex)                    :: sumveg        !! Fraction of bare soil (unitless) 
+    REAL(r_std), DIMENSION(kjpindex)                    :: ave_height    !! Average vegetation height (m)
+    REAL(r_std), DIMENSION(kjpindex)                    :: d_veg         !! PFT coverage of vegetative PFTs 
+                                                                         !! (= ind*cn_ind) (m^2 m^{-2})
+    REAL(r_std), DIMENSION(kjpindex)                    :: zhdispl       !! Zero plane displacement height (m)
+    REAL(r_std)                                         :: z0_nobio      !! Roughness of non-vegetative fraction (m),  
+                                                                         !! i.e. continental ice, lakes, etc. 
+!_ ================================================================================================================================
+    
+    !! 1. Preliminary calculation
+
+    ! Calculate the roughness (m) of bare soil, z0_bare
+    ! taken from constantes_veg.f90    
+    z0(:) = tot_bare_soil(:) * LOG(z0_bare)
+
+    ! Define fraction of bare soil
+    sumveg(:) = tot_bare_soil(:)
+
+    ! Set average vegetation height to zero
+    ave_height(:) = zero
+
+    !! 2. Calculate the mean roughness length 
+    
+    ! Calculate the mean roughness height of
+    ! vegetative PFTs over the grid cell
+    DO jv = 2, nvm !Loop over # vegetative PFTs
+
+       ! In the case of forest, use parameter veget_max because 
+       ! tree trunks influence the roughness even when there are no leaves
+       IF ( is_tree(jv) ) THEN
+          d_veg(:) = veget_max(:,jv)
+       ELSE
+
+          ! In the case of grass, use parameter veget because grasses 
+          ! only influence the roughness during the growing season
+          d_veg(:) = veget(:,jv)
+       ENDIF
+       
+       ! Calculate the average roughness over the grid cell:
+       ! The roughness for vegetative PFTs is calculated by
+       ! the vegetation height per PFT multiplied by the roughness 
+       ! parameter 'z0_over_height= 1/16'. If this scaled value is 
+       ! lower than 0.01 than the value for the roughness length 
+       ! of bare soil (0.01) is used. The sum of the logarithm of 
+       ! the roughness times the fraction per grid cell gives the 
+       ! logarithm of roughness length per grid cell for the vegetative
+       ! PFTs.
+       z0(:) = z0(:) + d_veg(:) * &
+            LOG( MAX(height(:,jv)*z0_over_height,z0_bare) )
+       ! Sum of bare soil and fraction vegetated fraction 
+       sumveg(:) = sumveg(:) + d_veg(:)
+
+       ! Weighted height of vegetation with maximal cover fraction
+       ave_height(:) = ave_height(:) + veget_max(:,jv)*height(:,jv)
+       
+    ENDDO !Loop over # vegetative PFTs
+    
+    !! 3. Calculate the mean roughness length of non-vegetative surfaces \n
+
+    ! Search for pixels with vegetated part to normalise 
+    ! roughness length
+    WHERE ( sumveg(:) > zero ) z0(:) = z0(:) / sumveg(:)
+    
+    ! Calculate fraction of roughness for vegetated part 
+    z0(:) = (un - totfrac_nobio(:)) * z0(:)   
+    ! Save roughness of vegetated part for calculation of snow fraction    
+    z0_veg(:) = z0(:)
+    
+    DO jv = 1, nnobio ! Loop over # of non-vegative surfaces
+    
+       ! Set rougness for ice 
+       IF ( jv .EQ. iice ) THEN
+          z0_nobio = z0_ice
+       ELSE
+          WRITE(numout,*) 'jv=',jv
+          STOP 'DO NOT KNOW ROUGHNESS OF THIS SURFACE TYPE'
+       ENDIF
+       
+       ! Sum of vegetative roughness length and non-vegetative
+       ! roughness length
+       z0(:) = z0(:) + frac_nobio(:,jv) * LOG(z0_nobio)
+    
+
+
+    ENDDO ! loop over # of non-vegative surfaces
+    
+    !! 4. Calculate the zero plane displacement height and effective roughness length
+
+    !  Take the exponential of the roughness length 
+    z0(:) = EXP( z0(:) )
+
+    ! Compute the zero plane displacement height which
+    ! is an equivalent height of the vegetation for the absorption of momentum
+    zhdispl(:) = ave_height(:) * height_displacement
+
+    ! Then we compute what we call the grid effective roughness height.
+    ! This is the height over which the roughness acts. It combines the
+    ! zero plane displacement height and the vegetation height.  This 
+    ! effective value is the difference between the height of the 
+    ! vegetation and the zero plane displacement height.
+    roughheight(:) = ave_height(:) - zhdispl(:)
+
+
+  END SUBROUTINE condveg_z0logz
+
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : condveg_z0cdrag
+!!
+!>\BRIEF        Computation of grid average of roughness length by calculating 
+!! the drag coefficient.
+!!
+!! DESCRIPTION  : This routine calculates the mean roughness height and mean 
+!! effective roughness height over the grid cell. The mean roughness height (z0) 
+!! is computed by averaging the drag coefficients  \n
+!!
+!! \latexonly 
+!! \input{z0cdrag1.tex}
+!! \endlatexonly
+!! \n 
+!!
+!! where C is the drag coefficient at the height of the vegetation, kappa is the 
+!! von Karman constant, z (Ztmp) is the height at which the fluxes are estimated and z0 the roughness height. 
+!! The reference level for z needs to be high enough above the canopy to avoid 
+!! singularities of the LOG. This height is set to  minimum 10m above ground. 
+!! The drag coefficient increases with roughness height to represent the greater 
+!! turbulence generated by rougher surfaces. 
+!! The roughenss height is obtained by the inversion of the drag coefficient equation.\n
+!!
+!! The roughness height for the non-vegetative surfaces is calculated in a second step. 
+!! In order to calculate the transfer coefficients the 
+!! effective roughness height is calculated. This effective value is the difference
+!! between the height of the vegetation and the zero plane displacement height.\nn
+!!
+!! RECENT CHANGE(S): None
+!! 
+!! MAIN OUTPUT VARIABLE(S):  :: roughness height(z0) and grid effective roughness height(roughheight)
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE condveg_z0cdrag (kjpindex,veget,veget_max,frac_nobio,totfrac_nobio,zlev, height, &
+       &                      z0, roughheight,z0_veg)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+   
+    INTEGER(i_std), INTENT(in)                          :: kjpindex      !! Domain size - Number of land pixels  (unitless)
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in)    :: veget         !! PFT coverage fraction of a PFT (= ind*cn_ind) 
+                                                                         !! (m^2 m^{-2})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in)    :: veget_max     !! PFT "Maximal" coverage fraction of a PFT 
+                                                                         !! (= ind*cn_ind) (m^2 m^{-2})
+    REAL(r_std), DIMENSION(kjpindex,nnobio), INTENT(in) :: frac_nobio    !! Fraction of non-vegetative surfaces, 
+                                                                         !! i.e. continental ice, lakes, etc. (unitless)
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in)        :: totfrac_nobio !! Total fraction of non-vegetative surfaces, 
+                                                                         !! i.e. continental ice, lakes, etc. (unitless)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: zlev          !! Height of first layer (m)           
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in)    :: height        !! Vegetation height (m)    
+    
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)       :: z0            !! Roughness height (m)
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)       :: roughheight   !! Grid effective roughness height (m) 
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)       :: z0_veg        !! Roughness height of vegetated part (m)
+    
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                      :: jv            !! Loop index over PFTs (unitless)
+    REAL(r_std), DIMENSION(kjpindex)                    :: sumveg        !! Fraction of bare soil (unitless)
+    REAL(r_std), DIMENSION(kjpindex)                    :: ztmp          !! Max height of the atmospheric level (m)
+    REAL(r_std), DIMENSION(kjpindex)                    :: ave_height    !! Average vegetation height (m)
+    REAL(r_std), DIMENSION(kjpindex)                    :: d_veg         !! PFT coverage of vegetative PFTs 
+                                                                         !! (= ind*cn_ind) (m^2 m^{-2})
+    REAL(r_std), DIMENSION(kjpindex)                    :: zhdispl       !! Zero plane displacement height (m)
+    REAL(r_std)                                         :: z0_nobio      !! Roughness height of non-vegetative fraction (m),  
+                                                                         !! i.e. continental ice, lakes, etc. 
+!_ ================================================================================================================================
+    
+    !! 1. Preliminary calculation
+
+    ! Set maximal height of first layer
+    ztmp(:) = MAX(10., zlev(:))
+
+    ! Calculate roughness for non-vegetative surfaces
+    ! with the von Karman constant 
+    z0(:) = tot_bare_soil(:) * (ct_karman/LOG(ztmp(:)/z0_bare))**2
+
+    ! Fraction of bare soil
+    sumveg(:) = tot_bare_soil(:)
+
+    ! Set average vegetation height to zero
+    ave_height(:) = zero
+    
+    !! 2. Calculate the mean roughness height 
+    
+    ! Calculate the mean roughness height of
+    ! vegetative PFTs over the grid cell
+    DO jv = 2, nvm
+
+       ! In the case of forest, use parameter veget_max because 
+       ! tree trunks influence the roughness even when there are no leaves
+       IF ( is_tree(jv) ) THEN
+          ! In the case of grass, use parameter veget because grasses 
+          ! only influence the roughness during the growing season
+          d_veg(:) = veget_max(:,jv)
+       ELSE
+          ! grasses only have an influence if they are really there!
+          d_veg(:) = veget(:,jv)
+       ENDIF
+       
+       ! Calculate the average roughness over the grid cell:
+       ! The unitless drag coefficient is per vegetative PFT
+       ! calculated by use of the von Karman constant, the height 
+       ! of the first layer and the roughness. The roughness
+       ! is calculated as the vegetation height  per PFT 
+       ! multiplied by the roughness  parameter 'z0_over_height= 1/16'. 
+       ! If this scaled value is lower than 0.01 then the value for 
+       ! the roughness of bare soil (0.01) is used. 
+       ! The sum over all PFTs gives the average roughness 
+       ! per grid cell for the vegetative PFTs.
+       z0(:) = z0(:) + d_veg(:) * (ct_karman/LOG(ztmp(:)/MAX(height(:,jv)*z0_over_height,z0_bare)))**2
+
+       ! Sum of bare soil and fraction vegetated fraction
+       sumveg(:) = sumveg(:) + d_veg(:)
+       
+       ! Weigh height of vegetation with maximal cover fraction
+       ave_height(:) = ave_height(:) + veget_max(:,jv)*height(:,jv)
+       
+    ENDDO
+    
+    !! 3. Calculate the mean roughness height of vegetative PFTs over the grid cell
+    
+    !  Search for pixels with vegetated part to normalise 
+    !  roughness height
+    WHERE ( sumveg(:) .GT. zero ) z0(:) = z0(:) / sumveg(:)
+
+    ! Calculate fraction of roughness for vegetated part 
+    z0(:) = (un - totfrac_nobio(:)) * z0(:)
+    ! Save roughness of vegetated part for calculation of snow fraction    
+    z0_veg(:) = z0(:)
+
+
+    DO jv = 1, nnobio ! Loop over # of non-vegative surfaces
+
+       ! Set rougness for ice
+       IF ( jv .EQ. iice ) THEN
+          z0_nobio = z0_ice
+
+
+       ELSE
+          WRITE(numout,*) 'jv=',jv
+          STOP 'DO NOT KNOW ROUGHNESS OF THIS SURFACE TYPE'
+       ENDIF
+       
+       ! Sum of vegetative roughness length and non-vegetative
+       ! roughness length
+       z0(:) = z0(:) + frac_nobio(:,jv) * (ct_karman/LOG(ztmp(:)/z0_nobio))**2
+       
+    ENDDO ! Loop over # of non-vegative surfaces
+
+    
+    !! 4. Calculate the zero plane displacement height and effective roughness length
+
+    !  Take the exponential of the roughness 
+    z0(:) = ztmp(:) / EXP(ct_karman/SQRT(z0(:)))
+
+    ! Compute the zero plane displacement height which
+    ! is an equivalent height for the absorption of momentum
+    zhdispl(:) = ave_height(:) * height_displacement
+
+    ! In order to calculate the fluxes we compute what we call the grid 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
+
+
+END MODULE condveg
Index: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/diffuco.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/diffuco.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/diffuco.f90	(revision 7236)
@@ -0,0 +1,5343 @@
+! ================================================================================================================================
+!  MODULE       : diffuco
+!
+!  CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+!  LICENCE      : IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF   This module calculates the limiting coefficients, both aerodynamic
+!! and hydrological, for the turbulent heat fluxes.
+!!
+!!\n DESCRIPTION: The aerodynamic resistance R_a is used to limit
+!! the transport of fluxes from the surface layer of vegetation to the point in the atmosphere at which
+!! interaction with the LMDZ atmospheric circulation model takes place. The aerodynamic resistance is
+!! calculated either within the module r_aerod (if the surface drag coefficient is provided by the LMDZ, and 
+!! if the flag 'ldq_cdrag_from_gcm' is set to TRUE) or r_aero (if the surface drag coefficient must be calculated).\n
+!!
+!! Within ORCHIDEE, evapotranspiration is a function of the Evaporation Potential, but is modulated by a
+!! series of resistances (canopy and aerodynamic) of the surface layer, here represented by beta.\n
+!!
+!! DESCRIPTION	:
+!! \latexonly 
+!!     \input{diffuco_intro.tex}
+!! \endlatexonly
+!! \n
+!!
+!! This module calculates the beta for several different scenarios: 
+!! - diffuco_snow calculates the beta coefficient for sublimation by snow, 
+!! - diffuco_inter calculates the beta coefficient for interception loss by each type of vegetation, 
+!! - diffuco_bare calculates the beta coefficient for bare soil, 
+!! - diffuco_trans or diffuco_trans_co2 both calculate the beta coefficient for transpiration for each type
+!!   of vegetation. Those routines differ by the formulation used to calculate the canopy resistance (Jarvis in 
+!!   diffuco_trans, Farqhar in diffuco_trans_co2)
+!! - diffuco_inca calculates the beta coefficient for emissions of biogenic compounds \n
+!!
+!! Finally, the module diffuco_comb computes the combined $\alpha$ and $\beta$ coefficients for use 
+!! elsewhere in the module. \n
+
+!! RECENT CHANGE(S): Nathalie le 28 mars 2006 - sur proposition de Fred Hourdin, ajout
+!! d'un potentiometre pour regler la resistance de la vegetation (rveg is now in pft_parameters)
+!!
+!! REFERENCE(S)	: None
+!!
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_sechiba/diffuco.f90 $
+!! $Date: 2015-02-22 16:18:16 +0100 (Sun, 22 Feb 2015) $
+!! $Revision: 2555 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE diffuco
+
+  ! modules used :
+  USE constantes
+  USE function_library, ONLY : biomass_to_lai, biomass_to_coupled_lai
+  USE qsat_moisture
+  USE sechiba_io
+  USE ioipsl
+  USE pft_parameters
+  USE grid
+  USE ioipsl_para 
+  USE slowproc
+  USE xios_orchidee
+
+  IMPLICIT NONE
+
+  ! public routines :
+  ! diffuco_main only
+  PRIVATE
+  PUBLIC :: diffuco_main,diffuco_clear
+
+  !
+  ! variables used inside diffuco module : declaration and initialisation
+  !
+  LOGICAL, SAVE                                      :: l_first_diffuco = .TRUE.  !! Initialisation has to be done one time
+!$OMP THREADPRIVATE(l_first_diffuco)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: leaf_ci                   !! intercellular CO2 concentration (ppm)
+!$OMP THREADPRIVATE(leaf_ci)
+!  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: rstruct                   !! architectural resistance (s m^{-1})
+!!$OMP THREADPRIVATE(rstruct)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: raero                     !! Aerodynamic resistance (s m^{-1})
+!$OMP THREADPRIVATE(raero)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: qsatt                     !! Surface saturated humidity (kg kg^{-1})
+!$OMP THREADPRIVATE(qsatt)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: wind                      !! Wind module (m s^{-1})
+!$OMP THREADPRIVATE(wind)
+
+  ! variables used inside diffuco_inca module 
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:)     :: ok_siesta        !! Flag for controlling post-pulse period (true/false)
+!$OMP THREADPRIVATE(ok_siesta)
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:)     :: allow_pulse      !! Flag for controlling pulse period (true/false)
+!$OMP THREADPRIVATE(allow_pulse)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pulse            !! Pulse fonction 
+!$OMP THREADPRIVATE(pulse)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pulseday         !! Counter for pulse period
+!$OMP THREADPRIVATE(pulseday)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: siestaday        !! Counter for post-pulse period
+!$OMP THREADPRIVATE(siestaday)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: pulselim         !! Pulse period length
+!$OMP THREADPRIVATE(pulselim)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: siestalim        !! Post-pulse period length
+!$OMP THREADPRIVATE(siestalim)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: area2            !! Grid cell area (m^2)
+!$OMP THREADPRIVATE(area2)
+  REAL(r_std), SAVE                            :: nbre_precip 
+!$OMP THREADPRIVATE(nbre_precip)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: flx_co2_bbg_year !! CO2 emissions from bbg, 
+                                                                   !! read in a file (kgC.m^{-2}.year^{-1})
+!$OMP THREADPRIVATE(flx_co2_bbg_year)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: N_qt_WRICE_year  !! N fertilizers on wetland rice,
+                                                                   !! read in a file expressed in kgN/year/grid cell
+!$OMP THREADPRIVATE(N_qt_WRICE_year)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:) :: N_qt_OTHER_year  !! N fertilizers on other crops and grasses,
+                                                                   !! read in a file expressed in kgN/year/grid cell
+!$OMP THREADPRIVATE(N_qt_OTHER_year)
+
+REAL(r_std),SAVE, ALLOCATABLE,  DIMENSION (:,:)      :: vbeta3save           !! Beta for Transpiration (unitless)
+CONTAINS
+
+
+!! ================================================================================================================================
+!! SUBROUTINE    : diffuco_main
+!!
+!>\BRIEF	 The root subroutine for the module, which calls all other required
+!! subroutines.
+!! 
+!! DESCRIPTION   : 
+
+!! This is the root subroutine for the module. Following
+!! initialisation (if required) and preparation of the restart file, the module first of all calculates
+!! the surface drag coefficient (via a call to diffuco_aero), using available parameters to determine
+!! the stability of air in the surface layer by calculating the Richardson Nubmber. If a value for the 
+!! surface drag coefficient is passed down from the atmospheric model and and if the flag 'ldq_cdrag_from_gcm' 
+!! is set to TRUE, then the subroutine diffuco_aerod is called instead. This calculates the aerodynamic coefficient. \n
+!!
+!! Following this, an estimation of the saturated humidity at the surface is made (via a call
+!! to qsatcalc in the module qsat_moisture). Following this the beta coefficients for sublimation (via 
+!! diffuco_snow), interception (diffuco_inter), bare soil (diffuco_bare), and transpiration (via 
+!! diffuco_trans_co2 if co2 is considered, diffuco_trans otherwise) are calculated in sequence. Finally 
+!! the alpha and beta coefficients are combined (diffuco_comb). \n
+!!
+!! The surface drag coefficient is calculated for use within the module enerbil. It is required to to
+!! calculate the aerodynamic coefficient for every flux. \n
+!!
+!! The various beta coefficients are used within the module enerbil for modifying the rate of evaporation, 
+!! as appropriate for the surface. As explained in Chapter 2 of Guimberteau (2010), that module (enerbil) 
+!! calculates the rate of evaporation essentially according to the expression $E = /beta E_{pot}$, where
+!! E is the total evaporation and $E_{pot}$ the evaporation potential. If $\beta = 1$, there would be
+!! essentially no resistance to evaporation, whereas should $\beta = 0$, there would be no evaporation and
+!! the surface layer would be subject to some very stong hydrological stress. \n
+!!
+!! ATTENTION ::valpha [DISPOSABLE] is not used anymore ! Its value is always 1.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): humrel, q_cdrag, vbeta, valpha, vbeta1, vbeta4,
+!! vbeta2, vbeta3, rveget, cimean   
+!!
+!! REFERENCE(S) :				        
+!! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+!! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+!! Circulation Model. Journal of Climate, 6, pp.248-273.
+!! - de Rosnay, P, 1999. ReprÃ©sentation des interactions sol-plante-atmosphÃšre dans le modÃšle de circulation gÃ©nÃ©rale
+!! du LMD, 1999. PhD Thesis, UniversitÃ© Paris 6, available (25/01/12): 
+!! http://www.ecmwf.int/staff/patricia_de_rosnay/publications.html#8
+!! - Ducharne, A, 1997. Le cycle de l'eau: modÃ©lisation de l'hydrologie continentale, Ã©tude de ses interactions avec 
+!! le climat, PhD Thesis, UniversitÃ© Paris 6
+!! - Guimberteau, M, 2010. ModÃ©lisation de l'hydrologie continentale et influences de l'irrigation
+!! sur le cycle de l'eau, PhD Thesis, available (25/01/12):
+!! http://www.sisyphe.upmc.fr/~guimberteau/docs/manuscrit_these.pdf
+!! - LathiÃšre, J, 2005. Evolution des Ã©missions de composÃ©s organiques et azotÃ©s par la biosphÃšre continentale dans le 
+!! modÃšle LMDz-INCA-ORCHIDEE, UniversitÃ© Paris 6
+!!
+!! FLOWCHART	:
+!! \latexonly 
+!!     \includegraphics[scale=0.5]{diffuco_main_flowchart.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+
+! Main routine for *diffuco* module.
+! - called only one time for initialisation
+! - called every time step for calculations (also the first time step)
+! - called one more time at last time step for writing _restart_ file
+!
+! The following processes are calculated:
+! - 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, using Jarvis formula
+! - call diffuco_trans_co2 for partial beta coefficient: transpiration for each type of vegetation, using Farqhar's formula
+! - call diffuco_comb for alpha and beta coefficient
+! - call diffuco_inca for alpha and beta coefficients for biogenic emissions
+  SUBROUTINE diffuco_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, indexlai, u, v, &
+! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
+     & zlev, z0, roughheight, temp_sol, temp_air, temp_growth, rau, q_cdrag, qsurf, qair, q2m, t2m, pb, &
+     & rsol, evap_bare_lim, evapot, evapot_corr, snow, flood_frac, flood_res, frac_nobio, snow_nobio, totfrac_nobio, &
+     & swnet, swdown, sinang, ccanopy, humrel, vegstress, veget, veget_max, biomass, qsintveg, qsintmax, assim_param, &
+     & vbeta , valpha, vbeta1, vbeta2, vbeta3, vbeta3pot, vbeta4, vbeta5, gsmean, rveget, rstruct, cimean, gpp, &
+     & lalo, neighbours, resolution, ptnlev1, precip_rain, frac_age, &
+     & rest_id, hist_id, hist2_id, vbeta2sum, vbeta3sum, Isotrop_Abs_Tot_p, Isotrop_Tran_Tot_p,&
+     lai_per_level, lai, vbeta23, leaf_ci, gs_distribution, gs_diffuco_output, gstot_component, gstot_frac,&
+     warnings)
+
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    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 (s)
+    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),DIMENSION (kjpindex), INTENT (in)     :: index          !! Indeces of the points on the map (-)
+    INTEGER(i_std),DIMENSION (kjpindex*(nlai+1)), INTENT (in) :: indexlai  !! Indeces of the points on the 3D 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                !! Eastward Lowest level wind speed (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: v                !! Northward Lowest level wind speed (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: zlev             !! Height of first layer (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: z0               !! Surface roughness Length (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: roughheight      !! Effective height for roughness (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_sol         !! Skin temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_air         !! Lowest level temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_growth      !! Growth temperature (Â°C) - Is equal to t2m_month
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: rau              !! Air Density (kg m^{-3})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: qsurf            !! Near surface air specific humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: qair             !! Lowest level air specific humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: q2m              !! 2m air specific humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: t2m              !! 2m air temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: snow             !! Snow mass (kg)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: flood_frac       !! Fraction of floodplains
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: flood_res        !! Reservoir in floodplains (estimation to avoid over-evaporation)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: pb               !! Surface level pressure (hPa)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: rsol             !! Bare soil evaporation resistance (s m^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: evap_bare_lim    !! Limit to the bare soil evaporation when the 
+                                                                           !! 11-layer hydrology is used (-)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: evapot           !! Soil Potential Evaporation (mm day^{-1}) 
+                                                                           !! NdN This variable does not seem to be used at 
+                                                                           !! all in diffuco
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: evapot_corr      !! 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,... (kg m^{-2})
+    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 (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: swdown           !! Down-welling surface short-wave flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: sinang           !! Sinus of Solar Angle (as computed in read_dim2)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: ccanopy          !! CO2 concentration inside the canopy (ppm)
+    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(:,:,:,:), INTENT(in)        :: biomass          !! Stand level biomass @tex $(gC m^{-2})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: qsintveg         !! Water on vegetation due to interception (kg m^{-2})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: qsintmax         !! Maximum water on vegetation for interception 
+                                                                           !! (kg m^{-2})
+    REAL(r_std),DIMENSION (kjpindex,nvm,npco2), INTENT (in) :: assim_param !! min+max+opt temps, vcmax, vjmax
+                                                                           !! for photosynthesis (K ??)
+    REAL(r_std),DIMENSION (kjpindex,2),   INTENT (in)  :: lalo               !! Geographical coordinates
+    INTEGER(i_std),DIMENSION (kjpindex,8),INTENT (in)  :: neighbours         !! Vector of neighbours for each 
+                                                                             !! grid point (1=N, 2=E, 3=S, 4=W)
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT(in)     :: resolution         !! The size in m of each grid-box in X and Y
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: ptnlev1            !! 1st level of soil temperature (Kelvin)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: precip_rain        !! Rain precipitation expressed in mm/tstep
+    REAL(r_std),DIMENSION (kjpindex,nvm,nleafages), INTENT (in)  :: frac_age !! Age efficiency for isoprene emissions (from STOMATE)
+    REAL(r_std),DIMENSION (kjpindex, nvm), INTENT (in) :: vegstress          !! Relative Soil water content accounting for root profile (m3 m-3)
+    REAL(r_std),DIMENSION (:,:,:), INTENT (in)         :: Isotrop_Abs_Tot_p  !! Absorbed radiation per level for photosynthesis
+    REAL(r_std),DIMENSION (:,:,:), INTENT (in)         :: Isotrop_Tran_Tot_p !! Absorbed radiation per level for photosynthesis
+    REAL(r_std), DIMENSION(:,:,:), INTENT(IN)          :: lai_per_level      !! This is the LAI per vertical level
+                                                                             !! @tex $(m^{2} m^{-2})$
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: lai                !! PFT leaf area index (m^{2} m^{-2})
+
+    !! 0.2 Output variables
+
+    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), INTENT (out)     :: vbeta5           !! Beta for floodplains
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: gsmean           !! Mean stomatal conductance to CO2 (umol m-2 s-1)
+    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) :: vbeta3pot        !! Beta for potential transpiration
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: rveget           !! Stomatal resistance for the whole canopy (s m^{-1})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: rstruct        !! Structural resistance for the vegetation
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: cimean           !! Mean leaf Ci (ppm)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(inout):: gpp              !! Assimilation ((gC m^{-2} s^{-1}), total area)        
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbeta23          !! Beta for fraction of wetted foliage that will
+                                                                           !! transpire once intercepted water has evaporated (-)
+    REAL(r_std), DIMENSION (kjpindex,nvm,nlai), INTENT (out)  :: leaf_ci   !! intercellular CO2 concentration (ppm)
+
+    REAL(r_Std),DIMENSION (kjpindex,nvm,nlevels_tot), INTENT (out)       :: gs_distribution
+    REAL(r_Std),DIMENSION (kjpindex,nvm,nlevels_tot), INTENT (out)       :: gs_diffuco_output
+    REAL(r_Std),DIMENSION (kjpindex,nvm,nlevels_tot), INTENT (out)       :: gstot_component
+    REAL(r_Std),DIMENSION (kjpindex,nvm,nlevels_tot), INTENT (out)       :: gstot_frac
+
+
+
+    !! 0.3 Modified variables
+ 
+    REAL(r_std),DIMENSION (kjpindex, nvm), INTENT (inout) :: humrel        !! Soil moisture stress (within range 0 to 1)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)      :: q_cdrag       !! Product of drag coefficient and wind speed (m s^{-1})
+    REAL(r_std),DIMENSION(kjpindex,nvm,nwarns), INTENT(inout) &
+                                                           :: warnings     !! A warning counter
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                    :: ilai
+    CHARACTER(LEN=4)                                  :: laistring
+    CHARACTER(LEN=80)                                 :: var_name                  !! To store variables names for I/O
+    REAL(r_std), DIMENSION(kjpindex)                     :: vbeta2sum, vbeta3sum
+
+    ! Biogenic emissions
+    REAL(r_std),DIMENSION(kjpindex)          :: PAR                !! Photosynthetic active radiation, half of swdown
+                                                                   !! @tex ($\mu mol photons. m^{-2} s^{-1}$) @endtex
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: PARsun             !! PAR received by sun leaves
+                                                                   !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: PARsh              !! PAR received by shaded leaves 
+                                                                   !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: laisun             !! Leaf area index of Sun leaves (m^2.m^{-2})
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: laish              !! Leaf area index of Shaded leaves (m^2.m^{-2}) 
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: flx_iso            !! Biogenic isoprene emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: flx_mono           !! Biogenic monoterpene emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: flx_ORVOC          !! Biogenic ORVOC emission - (kgC.m^{-2}.s^{-1}) 
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: flx_MBO            !! Biogenic MBO emission -
+                                                                   !! MethylButanOl (kgC.m^{-2}.s^{-1})
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: flx_methanol       !! Biogenic methanol emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: flx_acetone        !! Biogenic acetone emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: flx_acetal         !! Biogenic Acetaldehyde emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: flx_formal         !! Biogenic Formaldehyde emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: flx_acetic         !! Biogenic Acetic Acid emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: flx_formic         !! Biogenic Formic Acid emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: flx_no_soil        !! Biogenic NO emission by soil (kgC.m^{-2}.s^{-1})               
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: flx_no             !! Biogenic net NO emission (kgC.m^{-2}.s^{-1})                 
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: CRF                !! Canopy reduction factor for net NO flux calculation    
+    REAL(r_std),DIMENSION(kjpindex,nvm)      :: flx_fertil_no      !! Biogenic NO emission due to N-fertilisation 
+                                                                   !! (kgC.m^{-2}.s^{-1})
+    REAL(r_std),DIMENSION(kjpindex)          :: Fdf                !! Diffuse Fraction of the radiation (0-1, unitless)
+    REAL(r_std),DIMENSION(kjpindex,nlai+1)   :: PARsuntab          !! PAR received by sun leaves 
+                                                                   !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+    REAL(r_std),DIMENSION(kjpindex,nlai+1)   :: PARshtab           !! PAR received by shaded leaves 
+                                                                   !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+    REAL(r_std),DIMENSION(kjpindex)          :: PARdf              !! Diffuse PAR
+                                                                   !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+    REAL(r_std),DIMENSION(kjpindex)          :: PARdr              !! Direct PAR 
+                                                                   !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+    REAL(r_std),DIMENSION(kjpindex)          :: Trans              !! Atmospheric Transmissivity (unitless)
+   
+    REAL(r_std),DIMENSION(kjpindex)          :: julian_diff_2d     !!
+    REAL(r_std),DIMENSION(kjpindex)          :: year_length_2d     !!
+    ! REAL(r_std),DIMENSION(kjpindex,nvm)      :: lai                !! Leaf area index (m^2 m^{-2})
+    INTEGER                                  :: ipts, jv           !! Indices (unitless)
+!_ ================================================================================================================================
+    
+    gs_distribution = 0.0d0
+    
+    !! 0. Calculate the LAI from the biomass. 
+    ! This is done to prevent passing an incorrect
+    ! LAI around, since LAI is diagnostic.
+    ! We can't do this if we use an LAI map! So this breaks DO_STOMATE=N
+!!$    DO jv = 1, nvm
+!!$       DO ipts = 1, kjpindex
+!!$          lai(ipts,jv) = biomass_to_lai(biomass(ipts,jv,ileaf,icarbon),jv)
+!!$       ENDDO
+!!$    ENDDO
+
+
+  !! 1. Perform initialisation, if required
+    
+    IF (l_first_diffuco) THEN
+
+IF (.NOT. ALLOCATED(vbeta3save)) ALLOCATE (vbeta3save(kjpindex,nvm))
+vbeta3save(:,:)=1000
+
+
+        !Config Key   = CDRAG_FROM_GCM
+        !Config Desc  = Keep cdrag coefficient from gcm.
+        !Config If    = OK_SECHIBA
+        !Config Def   = y
+        !Config Help  = Set to .TRUE. if you want q_cdrag coming from GCM (if q_cdrag on initialization is non zero).
+        !Config         Keep cdrag coefficient from gcm for latent and sensible heat fluxes.
+        !Config Units = [FLAG]
+        IF ( ABS(MAXVAL(q_cdrag)) .LE. EPSILON(q_cdrag)) THEN
+           ldq_cdrag_from_gcm = .FALSE.
+        ELSE
+           ldq_cdrag_from_gcm = .TRUE.
+        ENDIF
+        
+        !?? 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, rstruct, gpp)
+
+        WRITE(numout,*) "control%ok_inca:",control%ok_inca
+        IF ( control%ok_inca ) CALL diffuco_inca_init(kjpindex, lalo, neighbours, resolution, dtradia)
+
+        RETURN
+
+    ENDIF
+    
+  !! 2. Prepare the 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
+          IF ( control%stomate_watchout  ) 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
+
+        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
+    
+    wind(:) = SQRT (u(:)*u(:) + v(:)*v(:))
+
+    
+  !! 3. Calculate the different coefficients
+
+    ! WRITE(*,*) '181113 test, pre call to diffuco_aero temp_sol is: ', temp_sol
+
+    IF (.NOT.ldq_cdrag_from_gcm) THEN
+        ! Case 3a)
+       CALL diffuco_aero (kjpindex, kjit, u, v, zlev, z0, roughheight, temp_sol, temp_air, &
+            &             qsurf, qair, q_cdrag)
+    ENDIF
+
+    ! Case 3b)
+    CALL diffuco_raerod (kjpindex, u, v, q_cdrag, raero)
+
+  !! 4. Make an estimation of the saturated humidity at the surface
+
+    ! WRITE(*,*) '181113a test, pre call to qsatcalc diffuco line 462; temp_sol is: ', temp_sol
+
+    CALL qsatcalc (kjpindex, temp_sol, pb, qsatt)
+
+  !! 5. Calculate the beta coefficient for sublimation
+  
+    CALL diffuco_snow (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, &
+         & snow, frac_nobio, totfrac_nobio, snow_nobio, vbeta1)
+
+
+    CALL diffuco_flood (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, evapot, evapot_corr, &
+         & flood_frac, flood_res, vbeta5)
+
+  !! 6. Calculate the 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) 
+!AD090715 tzj_wb: adding humrel to the arguments
+    CALL diffuco_inter (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, humrel, veget, &
+       & qsintveg, qsintmax, rstruct, vbeta2, vbeta23) 
+
+  !! 8. Calculate the beta coefficient for transpiration
+
+    IF ( control%ok_co2 ) THEN
+
+      ! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
+      ! case 8a)
+       IF(control%ok_functional_allocation)THEN   
+  ! tzj_wb add humrel in args 
+          CALL diffuco_trans_co2 (kjpindex, dtradia, swdown, temp_sol, pb, qsurf, q2m, t2m, &
+               temp_growth, rau, u, v, q_cdrag, humrel, vegstress, &
+               assim_param, ccanopy, &
+               veget_max, qsintveg, qsintmax, vbeta3, vbeta3pot, &
+               rveget, rstruct, cimean, gsmean, gpp, vbeta23, Isotrop_Abs_Tot_p,&
+               Isotrop_Tran_Tot_p, lai_per_level, gs_distribution, gs_diffuco_output, &
+               gstot_component, gstot_frac, veget, biomass, warnings)
+          
+       ELSE
+ 
+          CALL ipslerr(3,'diffuco.f90',&
+               'Using control%ok_co2 but not control%ok_functional_allocation',&
+               'control%ok_stomate does not work!','')
+       ENDIF ! (control%ok_functional_allocation)
+
+    ELSE
+
+      ! Correction Nathalie - Juin 2006 - introduction d'un terme vbeta23
+      ! case 8b) 
+      CALL diffuco_trans (kjpindex, dtradia, swnet, temp_air, pb, qair, rau, u, v, q_cdrag, humrel, &
+           & veget, veget_max, lai, qsintveg, qsintmax, vbeta3, vbeta3pot, rveget, rstruct, cimean, &
+           & gsmean, vbeta23)
+
+      IF ( control%stomate_watchout ) THEN
+         gpp(:,:) = zero
+      ENDIF
+    ENDIF ! ( control%ok_co2 )
+
+    
+    !
+    !biogenic emissions
+    !
+    IF ( control%ok_inca ) THEN
+       CALL diffuco_inca (kjpindex, dtradia, swdown, sinang, temp_air, temp_sol, ptnlev1, precip_rain, humrel, &
+                        veget_max, lai, frac_age, &
+                        lalo, &
+                        PAR, PARsun, PARsh, laisun, laish, &
+                        flx_iso, flx_mono, flx_ORVOC, flx_MBO, flx_methanol, flx_acetone, flx_acetal, &
+                        flx_formal, flx_acetic, flx_formic, &
+                        flx_no_soil, flx_no,CRF, flx_fertil_no, Fdf, PARsuntab, PARshtab, PARdf, PARdr, Trans)
+    ENDIF
+    !
+    ! combination of coefficient : alpha and beta coefficient
+    ! beta coefficient for bare soil
+    !
+
+    CALL diffuco_bare (kjpindex, dtradia, u, v, q_cdrag, rsol, evap_bare_lim, humrel, &
+         veget, veget_max, vbeta2, vbeta3, vbeta4) 
+
+  !! 9. Combine the alpha and beta coefficients
+
+    ! 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, vbeta2sum, vbeta3sum)    
+
+    julian_diff_2d(:) = julian_diff
+    year_length_2d(:) = year_length
+
+    CALL xios_orchidee_send_field("cdrag",q_cdrag)
+    CALL xios_orchidee_send_field("raero",raero)
+    CALL xios_orchidee_send_field("Wind",wind)
+    CALL xios_orchidee_send_field("qsatt",qsatt)
+    CALL xios_orchidee_send_field("PAR",PAR)
+    CALL xios_orchidee_send_field("PARsun",PARsun)
+    CALL xios_orchidee_send_field("PARsh",PARsh)
+    CALL xios_orchidee_send_field("laisun",laisun)
+    CALL xios_orchidee_send_field("laish",laish)
+    CALL xios_orchidee_send_field("Fdf",Fdf)
+    CALL xios_orchidee_send_field("PARsuntab",PARsuntab)
+    CALL xios_orchidee_send_field("PARshtab",PARshtab)
+    CALL xios_orchidee_send_field("PARdf",PARdf)
+    CALL xios_orchidee_send_field("PARdr",PARdr)
+    CALL xios_orchidee_send_field("Trans",Trans)
+    CALL xios_orchidee_send_field("Day",julian_diff_2d)
+    CALL xios_orchidee_send_field("Year_length",year_length_2d)
+    CALL xios_orchidee_send_field("flx_fertil_no",flx_fertil_no)
+    CALL xios_orchidee_send_field("CRF",CRF)
+    IF ( control%ok_bbgfertil_Nox ) THEN
+       CALL xios_orchidee_send_field("flx_co2_bbg_year",flx_co2_bbg_year)
+    END IF
+    IF ( control%ok_cropsfertil_Nox ) THEN
+       CALL xios_orchidee_send_field("N_qt_WRICE_year",N_qt_WRICE_year)
+       CALL xios_orchidee_send_field("N_qt_OTHER_year",N_qt_OTHER_year)
+    END IF
+    CALL xios_orchidee_send_field("ptnlev1",ptnlev1)
+    CALL xios_orchidee_send_field("flx_iso",flx_iso)
+    CALL xios_orchidee_send_field("flx_mono",flx_mono)
+    CALL xios_orchidee_send_field("flx_ORVOC",flx_ORVOC)
+    CALL xios_orchidee_send_field("flx_MBO",flx_MBO)
+    CALL xios_orchidee_send_field("flx_methanol",flx_methanol)
+    CALL xios_orchidee_send_field("flx_acetone",flx_acetone)
+    CALL xios_orchidee_send_field("flx_acetal",flx_acetal)
+    CALL xios_orchidee_send_field("flx_formal",flx_formal)
+    CALL xios_orchidee_send_field("flx_acetic",flx_acetic)
+    CALL xios_orchidee_send_field("flx_formic",flx_formic)
+    CALL xios_orchidee_send_field("flx_no_soil",flx_no_soil)
+    CALL xios_orchidee_send_field("flx_no",flx_no)
+
+    IF ( .NOT. almaoutput ) THEN
+       CALL histwrite_p(hist_id, 'raero', kjit, raero, kjpindex, index)
+       ! Ajouts Nathalie - novembre 2006
+       CALL histwrite_p(hist_id, 'cdrag', kjit, q_cdrag, kjpindex, index)
+       CALL histwrite_p(hist_id, 'Wind', kjit, wind, kjpindex, index)
+       ! Fin ajouts Nathalie
+       CALL histwrite_p(hist_id, 'qsatt', kjit, qsatt, kjpindex, index)
+
+       IF ( control%ok_inca ) THEN
+          CALL histwrite_p(hist_id, 'PAR', kjit, PAR, kjpindex, index)
+          IF ( control%ok_radcanopy ) THEN
+             CALL histwrite_p(hist_id, 'PARsun', kjit, PARsun, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist_id, 'PARsh', kjit, PARsh, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist_id, 'laisun', kjit, laisun, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist_id, 'laish', kjit, laish, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist_id, 'Fdf', kjit, Fdf, kjpindex, index)
+             IF (control%ok_multilayer) THEN 
+                CALL histwrite_p(hist_id, 'PARsuntab', kjit, PARsuntab, kjpindex*(nlai+1), indexlai)
+                CALL histwrite_p(hist_id, 'PARshtab', kjit, PARshtab, kjpindex*(nlai+1), indexlai)
+             ENDIF
+             CALL histwrite_p(hist_id, 'PARdf', kjit, PARdf, kjpindex, index)
+             CALL histwrite_p(hist_id, 'PARdr', kjit, PARdr, kjpindex, index)
+             CALL histwrite_p(hist_id, 'Trans', kjit, Trans, kjpindex, index)
+             CALL histwrite_p(hist_id, 'Day', kjit, julian_diff_2d,kjpindex,index)
+             CALL histwrite_p(hist_id, 'Year_length', kjit, year_length_2d,kjpindex,index)
+
+          END IF
+          CALL histwrite_p(hist_id, 'flx_fertil_no', kjit, flx_fertil_no, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'CRF', kjit, CRF, kjpindex*nvm, indexveg)
+          IF ( control%ok_bbgfertil_Nox ) THEN
+             CALL histwrite_p(hist_id, 'flx_co2_bbg_year', 1, flx_co2_bbg_year, kjpindex, index)
+          ENDIF
+          IF ( control%ok_cropsfertil_Nox ) THEN
+             CALL histwrite_p(hist_id, 'N_qt_WRICE_year', 1, N_qt_WRICE_year, kjpindex, index)
+             CALL histwrite_p(hist_id, 'N_qt_OTHER_year', 1, N_qt_OTHER_year, kjpindex, index)
+          ENDIF
+          CALL histwrite_p(hist_id, 'ptnlev1', kjit, ptnlev1, kjpindex, index)
+          CALL histwrite_p(hist_id, 'flx_iso', kjit, flx_iso, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'flx_mono', kjit, flx_mono, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'flx_ORVOC', kjit, flx_ORVOC, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'flx_MBO', kjit, flx_MBO, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'flx_methanol', kjit, flx_methanol, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'flx_acetone', kjit, flx_acetone, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'flx_acetal', kjit, flx_acetal, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'flx_formal', kjit, flx_formal, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'flx_acetic', kjit, flx_acetic, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'flx_formic', kjit, flx_formic, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'flx_no_soil', kjit, flx_no_soil, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'flx_no', kjit, flx_no, kjpindex*nvm, indexveg)
+       END IF
+
+       IF ( hist2_id > 0 ) THEN
+          CALL histwrite_p(hist2_id, 'raero', kjit, raero, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'cdrag', kjit, q_cdrag, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'Wind', kjit, wind, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'qsatt', kjit, qsatt, kjpindex, index)
+
+          IF ( control%ok_inca ) THEN
+             CALL histwrite_p(hist2_id, 'PAR', kjit, PAR, kjpindex, index)
+             IF ( control%ok_radcanopy ) THEN
+                CALL histwrite_p(hist2_id, 'PARsun', kjit, PARsun, kjpindex*nvm, indexveg)
+                CALL histwrite_p(hist2_id, 'PARsh', kjit, PARsh, kjpindex*nvm, indexveg)
+                CALL histwrite_p(hist2_id, 'laisun', kjit, laisun, kjpindex*nvm, indexveg)
+                CALL histwrite_p(hist2_id, 'laish', kjit, laish, kjpindex*nvm, indexveg)
+             ENDIF
+             CALL histwrite_p(hist2_id, 'flx_fertil_no', kjit, flx_fertil_no, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'CRF', kjit, CRF, kjpindex*nvm, indexveg)
+             IF ( control%ok_bbgfertil_Nox ) THEN
+                CALL histwrite_p(hist2_id, 'flx_co2_bbg_year', 1, flx_co2_bbg_year, kjpindex, index)
+             ENDIF
+             IF ( control%ok_cropsfertil_Nox ) THEN
+                CALL histwrite_p(hist2_id, 'N_qt_WRICE_year', 1, N_qt_WRICE_year, kjpindex, index)
+                CALL histwrite_p(hist2_id, 'N_qt_OTHER_year', 1, N_qt_OTHER_year, kjpindex, index)
+             ENDIF
+             CALL histwrite_p(hist2_id, 'ptnlev1', kjit, ptnlev1, kjpindex, index)
+             CALL histwrite_p(hist2_id, 'flx_iso', kjit, flx_iso, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'flx_mono', kjit, flx_mono, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'flx_ORVOC', kjit, flx_ORVOC, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'flx_MBO', kjit, flx_MBO, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'flx_methanol', kjit, flx_methanol, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'flx_acetone', kjit, flx_acetone, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'flx_acetal', kjit, flx_acetal, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'flx_formal', kjit, flx_formal, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'flx_acetic', kjit, flx_acetic, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'flx_formic', kjit, flx_formic, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'flx_no_soil', kjit, flx_no_soil, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'flx_no', kjit, flx_no, kjpindex*nvm, indexveg)
+          ENDIF
+       ENDIF
+    ELSE
+
+    ENDIF
+
+    IF (long_print) WRITE (numout,*) ' diffuco_main done '
+
+  END SUBROUTINE diffuco_main
+
+
+!! ================================================================================================================================
+!! SUBROUTINE		 			: diffuco_init
+!!
+!>\BRIEF					Dynamic allocation algorithm for local arrays 
+!!
+!! DESCRIPTION				        : Housekeeping module to allocate local arrays
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S)	                : q_cdrag
+!!
+!! REFERENCE(S)				        : None
+!!
+!! FLOWCHART                                    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE diffuco_init(kjit, ldrestart_read, kjpindex, index, rest_id, q_cdrag, rstruct, gpp)
+
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    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 (-)
+
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: rstruct           !! STOMATE: architectural resistance
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: gpp              !! Assimilation ((gC m^{-2} s^{-1}), total area)      
+    !! 0.3 Modified variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)  :: q_cdrag            !! Product of Surface drag and wind speed (m s^{-1})
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                    :: ier, jv
+    INTEGER(i_std)                                    :: ilai
+    CHARACTER(LEN=4)                                  :: laistring
+    REAL(r_std),DIMENSION (kjpindex)                  :: temp
+    CHARACTER(LEN=80)                                 :: var_name            !! To store variables names for I/O
+!_ ================================================================================================================================
+    
+  !! 1. Initialisation
+    
+    IF (l_first_diffuco) THEN 
+        l_first_diffuco=.FALSE.
+    ELSE 
+        WRITE (numout,*) ' l_first_diffuco false . we stop '
+        CALL ipslerr(3,'diffuco.f90','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
+          CALL ipslerr(3,'diffuco.f90','diffuco_init','','')
+      END IF
+
+    ENDIF
+
+    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
+        CALL ipslerr(3,'diffuco.f90','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
+        CALL ipslerr(3,'diffuco.f90','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
+        CALL ipslerr(3,'diffuco.f90','diffuco_init','','')
+    END IF
+
+    ! Just in case ldreadstart_read is not true, we should have a value for the INTENT(OUT)
+    rstruct(:,:)=zero
+
+    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_p('UNITS', 's/m')
+        CALL ioconf_setatt_p('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_p('UNITS', 's/m')
+        CALL ioconf_setatt_p('LONG_NAME','Aerodynamic resistance')
+        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
+       
+        var_name='qsatt' ;
+        CALL ioconf_setatt_p('UNITS', 'g/g')
+        CALL ioconf_setatt_p('LONG_NAME','Surface saturated humidity')
+        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
+        
+        ! the following variable is read only if CO2 is calculated
+        IF ( control%ok_co2 ) THEN
+
+           CALL ioconf_setatt_p('UNITS', 'ppm')
+           CALL ioconf_setatt_p('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 If    = OK_SECHIBA
+           !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.
+           !Config Units = [ppm]
+           ! If we don't give this a value here, it crashes in setvar_p with
+           ! the NAG compiler, since it compares values of this array
+           ! to val_exp to decide if they need to be replaced or not.
+           leaf_ci(:,:,:) = val_exp
+           CALL setvar_p (leaf_ci, val_exp,'DIFFUCO_LEAFCI', 233._r_std)
+
+           IF ( control%stomate_watchout ) 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_p('UNITS', 'gC/m**2/time step')
+              CALL ioconf_setatt_p('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
+
+        ENDIF
+        
+        IF (.NOT.ldq_cdrag_from_gcm) THEN
+           var_name= 'cdrag'
+           CALL ioconf_setatt_p('LONG_NAME','Drag coefficient for LE and SH')
+           CALL ioconf_setatt_p('UNITS', '-')
+           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
+
+    WRITE(numout,*) 'DANS DIFFUCO_INIT , RVEG_PFT=',rveg_pft
+
+    IF (long_print) WRITE (numout,*) ' diffuco_init done '
+
+  END SUBROUTINE diffuco_init
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : diffuco_inca_init
+!!
+!>\BRIEF         This subroutine initializes diffuco_inca-related state variables
+!!
+!! DESCRIPTION  : Some of the variables and flags used in diffuco_inca are allocated and initialised here.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!_ ================================================================================================================================
+
+  SUBROUTINE diffuco_inca_init(kjpindex, lalo, neighbours, resolution, dtradia)
+    
+    !! 0. Variables and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                         :: kjpindex         !! Domain size (unitless) 
+    REAL(r_std), DIMENSION(kjpindex,2), INTENT (in)    :: lalo             !! Geographical coordinates
+    INTEGER(i_std), DIMENSION(kjpindex,8), INTENT (in) :: neighbours       !! Vector of neighbours for each 
+                                                                           !! grid point (1=N, 2=E, 3=S, 4=W)
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT(in)     :: resolution       !! The size in m of each grid-box in X and Y
+    REAL(r_std), INTENT(in)                            :: dtradia          !! Time step in seconds
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    LOGICAL                             :: allow_weathergen, density
+    CHARACTER(LEN=80)                   :: filename, filename2, fieldname
+    INTEGER(i_std)                      :: iml, jml, lml, tml, force_id
+    INTEGER(i_std)                      :: ier
+
+!_ ================================================================================================================================
+
+    ALLOCATE (pulse(kjpindex),stat=ier)
+    IF (ier /= 0) THEN
+       WRITE (numout,*) ' error in pulse allocation. We stop. We need kjpindex words = ',kjpindex
+       CALL ipslerr(3,'diffuco.f90','diffuco_inca_init','','') 
+    END IF
+    pulse(:) = un
+
+    ! If we acount for NOx pulse emissions
+    IF (control%ok_pulse_NOx) THEN
+
+       ALLOCATE (ok_siesta(kjpindex),stat=ier)
+       IF (ier /= 0) THEN
+          WRITE (numout,*) ' error in ok_siesta allocation. We stop. We need kjpindex words = ',kjpindex
+          CALL ipslerr(3,'diffuco.f90','diffuco_inca_init','','') 
+       END IF
+       ok_siesta(:) = .FALSE.
+
+       ALLOCATE (allow_pulse(kjpindex),stat=ier)
+       IF (ier /= 0) THEN
+          WRITE (numout,*) ' error in allow_pulse allocation. We stop. We need kjpindex words = ',kjpindex
+          CALL ipslerr(3,'diffuco.f90','diffuco_inca_init','','') 
+       END IF
+       allow_pulse(:) = .FALSE.
+
+       ALLOCATE (pulseday(kjpindex),stat=ier)
+       IF (ier /= 0) THEN
+          WRITE (numout,*) ' error in pulseday allocation. We stop. We need kjpindex words = ',kjpindex
+          CALL ipslerr(3,'diffuco.f90','diffuco_inca_init','','') 
+       END IF
+       pulseday(:) = zero
+
+       ALLOCATE (siestaday(kjpindex),stat=ier)
+       IF (ier /=0 ) THEN
+          WRITE (numout,*) ' error in siestaday allocation. We stop. We need kjpindex words = ',kjpindex
+          CALL ipslerr(3,'diffuco.f90','diffuco_inca_init','','') 
+       END IF
+       siestaday(:) = zero
+
+       ALLOCATE (pulselim(kjpindex),stat=ier)
+       IF (ier /= 0) THEN
+          WRITE (numout,*) ' error in pulselim allocation. We stop. We need kjpindex words = ',kjpindex
+          CALL ipslerr(3,'diffuco.f90','diffuco_inca_init','','') 
+       END IF
+       pulselim(:) = zero
+
+       ALLOCATE (siestalim(kjpindex),stat=ier)
+       IF (ier /= 0) THEN
+          WRITE (numout,*) ' error in siestalim allocation. We stop. We need kjpindex words = ',kjpindex
+          CALL ipslerr(3,'diffuco.f90','diffuco_inca_init','','') 
+       END IF
+       siestalim(:) = zero
+
+    END IF ! (control%ok_pulse_NOx) 
+
+    ! If we acount for NOx emissions by N-fertilizers
+    IF (control%ok_cropsfertil_NOx) THEN
+
+       ALLOCATE (area2(kjpindex),stat=ier)
+       IF (ier /= 0) THEN
+          WRITE (numout,*) ' error in area2 allocation. We stop. We need kjpindex words = ',kjpindex
+          CALL ipslerr(3,'diffuco.f90','diffuco_inca_init','','') 
+       END IF
+       area2(:) = resolution(:,1)*resolution(:,2) 
+
+       ALLOCATE (N_qt_WRICE_year(kjpindex),stat=ier)  !! N fertilizers on wetland rice, read in file 
+       IF (ier /= 0) THEN
+          WRITE (numout,*) ' error in N_qt_WRICE_year allocation. We stop. We need kjpindex words = ',kjpindex
+          CALL ipslerr(3,'diffuco.f90','diffuco_inca_init','','') 
+       END IF
+       N_qt_WRICE_year(:) = zero
+    
+       ALLOCATE (N_qt_OTHER_year(kjpindex),stat=ier)  !! N fertilizers on other crops and grasses, read in file 
+       IF (ier /= 0) THEN
+          WRITE (numout,*) ' error in N_qt_OTHER_year allocation. We stop. We need kjpindex words = ',kjpindex
+          CALL ipslerr(3,'diffuco.f90','diffuco_inca_init','','') 
+       END IF
+       N_qt_OTHER_year(:) = zero
+
+       WRITE (numout,*) ' *********************** Interpolating N fertilizers files for NOx emissions... '
+       filename = 'orchidee_fertilizer_1995.nc'
+       filename2= 'N_FERTIL_FILE'
+       density  = .FALSE. 
+       fieldname= 'N_qt_WRICE_year'
+       CALL diffuco_inca_read (kjpindex, lalo, neighbours, resolution, N_qt_WRICE_year, filename, filename2, fieldname, density)
+       fieldname= 'N_qt_OTHER_year'
+       CALL diffuco_inca_read (kjpindex, lalo, neighbours, resolution, N_qt_OTHER_year, filename, filename2, fieldname, density)
+    END IF
+
+    ! If we acount for NOx emissions due to Biomass Burning
+    IF (control%ok_bbgfertil_NOx) THEN
+
+       ALLOCATE (flx_co2_bbg_year(kjpindex),stat=ier) !! CO2 emissions from bbg, read in file 
+       IF (ier /= 0) THEN
+          WRITE (numout,*) ' error in flx_co2_bbg_year allocation. We stop. We need kjpindex words = ',kjpindex
+          CALL ipslerr(3,'diffuco.f90','diffuco_inca_init','','') 
+       END IF
+       flx_co2_bbg_year(:) = zero    
+
+       WRITE (numout,*) ' *********************** Interpolating CO2 bbg files for NOx emissions... '
+       filename = 'orchidee_bbg_clim.nc'
+       filename2= 'CO2_BBG_FILE'
+       fieldname= 'flx_co2_bbg_year'
+       density  = .TRUE.
+       CALL diffuco_inca_read (kjpindex, lalo, neighbours, resolution, flx_co2_bbg_year,filename,filename2,fieldname,density)
+    END IF
+
+    IF ( OFF_LINE_MODE ) THEN
+
+       !-
+       !- What are the alowed options for the temportal interpolation
+       !-
+       !Config Key   = ALLOW_WEATHERGEN
+       !Config Desc  = Allow weather generator to create data
+       !Config If    = 
+       !Config Def   = n
+       !Config Help  = This flag allows the forcing-reader to generate
+       !Config         synthetic data if the data in the file is too sparse
+       !Config         and the temporal resolution would not be enough to
+       !Config         run the model.
+       !Config Units = [FLAG]
+       !-
+       allow_weathergen = .FALSE.
+       CALL getin_p('ALLOW_WEATHERGEN',allow_weathergen)
+       
+       !-
+       !Config Key   = FORCING_FILE
+       !Config Desc  = Name of file containing the forcing data
+       !Config If    = [-]
+       !Config Def   = forcing_file.nc
+       !Config Help  = This is the name of the file which should be opened
+       !Config         for reading the forcing data of the dim0 model.
+       !Config         The format of the file has to be netCDF and COADS
+       !Config         compliant.
+       !Config Units = [FILE] 
+       !-  
+       filename='forcing_file.nc'
+       ! Filename should be parameterized
+       ! To Be Updated
+       CALL getin_p('FORCING_FILE',filename)
+       CALL flininfo(filename,iml, jml, lml, tml, force_id)   
+       WRITE(*,*) 'Number of data per year in forcing file :', tml 
+       CALL flinclo(force_id)
+       WRITE(*,*) 'Forcing file closed in INCA'
+       
+       
+       IF ( allow_weathergen ) THEN
+          WRITE(*,*) '**INCA: Using weather generator, careful to precip division for NOx '
+          nbre_precip = un
+          WRITE(*,*) 'Division pour les precip, NOx:', nbre_precip
+       ELSE
+          WRITE(*,*) 'DTRADIA :', dtradia 
+          nbre_precip = (one_day/dtradia)/(tml/365.)
+          WRITE(*,*) 'Division pour les precip, NOx:', nbre_precip
+       END IF
+
+    ELSE ! (in coupled mode)
+
+       nbre_precip = un
+       
+    END IF  ! (OFF_LINE_MODE)
+
+       
+  END SUBROUTINE diffuco_inca_init
+
+
+!! ================================================================================================================================
+!! SUBROUTINE		 			: diffuco_clear
+!!
+!>\BRIEF					Housekeeping module to deallocate the variables
+!! leaf_ci, rstruct and raero
+!!
+!! DESCRIPTION				        : Housekeeping module to deallocate the variables
+!! leaf_ci, rstruct and raero
+!!
+!! RECENT CHANGE(S)                             : None
+!!
+!! MAIN OUTPUT VARIABLE(S)	                : None
+!!
+!! REFERENCE(S)				        : None
+!!
+!! FLOWCHART                                    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE diffuco_clear()
+
+    l_first_diffuco=.TRUE.
+
+    IF (ALLOCATED (leaf_ci)) DEALLOCATE (leaf_ci)
+    IF (ALLOCATED (raero)) DEALLOCATE (raero)
+
+  END SUBROUTINE diffuco_clear
+
+
+!! ================================================================================================================================
+!! SUBROUTINE	: diffuco_aero
+!!
+!>\BRIEF	This module first calculates the surface drag 
+!! coefficient, for cases in which the surface drag coefficient is NOT provided by the coupled 
+!! atmospheric model LMDZ or when the flag ldq_cdrag_from_gcm is set to FALSE 
+!!
+!! DESCRIPTION	: Computes the surface drag coefficient, for cases 
+!! in which it is NOT provided by the coupled atmospheric model LMDZ. The module first uses the 
+!! meteorolgical input to calculate the Richardson Number, which is an indicator of atmospheric 
+!! stability in the surface layer. The formulation used to find this surface drag coefficient is 
+!! dependent on the stability determined. \n
+!!
+!! Designation of wind speed
+!! \latexonly 
+!!     \input{diffucoaero1.tex}
+!! \endlatexonly
+!!
+!! Calculation of geopotential. This is the definition of Geopotential height (e.g. Jacobson 
+!! eqn.4.47, 2005). (required for calculation of the Richardson Number)
+!! \latexonly 
+!!     \input{diffucoaero2.tex}
+!! \endlatexonly
+!! 
+!! \latexonly 
+!!     \input{diffucoaero3.tex}
+!! \endlatexonly
+!!
+!! Calculation of the virtual air temperature at the surface (required for calculation
+!! of the Richardson Number)
+!! \latexonly 
+!!     \input{diffucoaero4.tex}
+!! \endlatexonly
+!!
+!! Calculation of the virtual surface temperature (required for calculation of th
+!! Richardson Number)
+!! \latexonly 
+!!     \input{diffucoaero5.tex}
+!! \endlatexonly
+!!
+!! Calculation of the squared wind shear (required for calculation of the Richardson
+!! Number)
+!! \latexonly 
+!!     \input{diffucoaero6.tex}
+!! \endlatexonly
+!! 
+!! Calculation of the Richardson Number. The Richardson Number is defined as the ratio 
+!! of potential to kinetic energy, or, in the context of atmospheric science, of the
+!! generation of energy by wind shear against consumption
+!! by static stability and is an indicator of flow stability (i.e. for when laminar flow 
+!! becomes turbulent and vise versa). It is approximated using the expression below:
+!! \latexonly 
+!!     \input{diffucoaero7.tex}
+!! \endlatexonly
+!!
+!! The Richardson Number hence calculated is subject to a minimum value:
+!! \latexonly 
+!!     \input{diffucoaero8.tex}
+!! \endlatexonly
+!! 
+!! 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.
+!! \latexonly 
+!!     \input{diffucoaero9.tex}
+!! \endlatexonly
+!! 
+!! For the stable case (i.e $R_i$ $\geq$ 0)
+!! \latexonly 
+!!     \input{diffucoaero10.tex}
+!! \endlatexonly
+!!
+!! \latexonly 
+!!     \input{diffucoaero11.tex}
+!! \endlatexonly
+!!          
+!! For the unstable case (i.e. $R_i$ < 0)
+!! \latexonly 
+!!     \input{diffucoaero12.tex}
+!! \endlatexonly
+!!
+!! \latexonly 
+!!     \input{diffucoaero13.tex}
+!! \endlatexonly
+!!               
+!! If the Drag Coefficient becomes too small than the surface may uncouple from the atmosphere.
+!! To prevent this, a minimum limit to the drag coefficient is defined as:
+!!
+!! \latexonly 
+!!     \input{diffucoaero14.tex}
+!! \endlatexonly
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): q_cdrag
+!!
+!! REFERENCE(S)	: 
+!! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+!! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+!! Circulation Model. Journal of Climate, 6, pp.248-273
+!! - Guimberteau, M, 2010. ModÃ©lisation de l'hydrologie continentale et influences de l'irrigation
+!! sur le cycle de l'eau, PhD Thesis, available from:
+!! http://www.sisyphe.upmc.fr/~guimberteau/docs/manuscrit_these.pdf
+!! - Jacobson M.Z., Fundamentals of Atmospheric Modeling (2nd Edition), published Cambridge 
+!! University Press, ISBN 0-521-54865-9
+!!
+!! FLOWCHART	:
+!! \latexonly 
+!!     \includegraphics[scale=0.5]{diffuco_aero_flowchart.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE diffuco_aero (kjpindex, kjit, u, v, zlev, z0, roughheight, temp_sol, temp_air, &
+       &                   qsurf, qair, q_cdrag)
+
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                          :: kjpindex, kjit   !! Domain size
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: u                !! Eastward Lowest level wind speed (m s^{-1}) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: v                !! Northward Lowest level wind speed (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: zlev             !! Height of first atmospheric layer (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: z0               !! Surface roughness Length (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: roughheight      !! Effective roughness height (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: temp_sol         !! Ground temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: temp_air         !! Lowest level temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: qsurf            !! near surface specific air humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: qair             !! Lowest level specific air humidity (kg kg^{-1})
+
+    !! 0.2 Output variables
+    
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)    :: q_cdrag          !! Product of Surface drag coefficient and wind speed 
+                                                                            !! (m s^{-1})
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                      :: ji, jv
+    REAL(r_std)                                         :: speed, zg, zdphi, ztvd, ztvs, zdu2
+    REAL(r_std)                                         :: zri, cd_neut, zscf, cd_tmp
+!_ ================================================================================================================================
+
+  !! 1. Initialisation
+
+    ! test if we have to work with q_cdrag or to calcul it
+    DO ji=1,kjpindex
+       
+       !! 1a).1 Designation of wind speed
+       !! \latexonly 
+       !!     \input{diffucoaero1.tex}
+       !! \endlatexonly
+       speed = wind(ji)
+    
+       !! 1a).2 Calculation of geopotentiel
+       !! This is the definition of Geopotential height (e.g. Jacobson eqn.4.47, 2005). (required
+       !! for calculation of the Richardson Number)
+       !! \latexonly 
+       !!     \input{diffucoaero2.tex}
+       !! \endlatexonly
+       zg = zlev(ji) * cte_grav
+      
+       !! \latexonly 
+       !!     \input{diffucoaero3.tex}
+       !! \endlatexonly
+       zdphi = zg/cp_air
+       
+       !! 1a).3 Calculation of the virtual air temperature at the surface 
+       !! required for calculation of the Richardson Number
+       !! \latexonly 
+       !!     \input{diffucoaero4.tex}
+       !! \endlatexonly
+       ztvd = (temp_air(ji) + zdphi / (un + rvtmp2 * qair(ji))) * (un + retv * qair(ji)) 
+       
+       !! 1a).4 Calculation of the virtual surface temperature 
+       !! required for calculation of the Richardson Number
+       !! \latexonly 
+       !!     \input{diffucoaero5.tex}
+       !! \endlatexonly
+       ztvs = temp_sol(ji) * (un + retv * qsurf(ji))
+     
+       !! 1a).5 Calculation of the squared wind shear 
+       !! required for calculation of the Richardson Number
+       !! \latexonly 
+       !!     \input{diffucoaero6.tex}
+       !! \endlatexonly
+       zdu2 = MAX(cepdu2,speed**2)
+       
+       !! 1a).6 Calculation of the Richardson Number
+       !!  The Richardson Number is defined as the ratio of potential to kinetic energy, or, in the 
+       !!  context of atmospheric science, of the generation of energy by wind shear against consumption
+       !!  by static stability and is an indicator of flow stability (i.e. for when laminar flow 
+       !!  becomes turbulent and vise versa).\n
+       !!  It is approximated using the expression below:
+       !!  \latexonly 
+       !!     \input{diffucoaero7.tex}
+       !! \endlatexonly
+       zri = zg * (ztvd - ztvs) / (zdu2 * ztvd)
+      
+       !! The Richardson Number hence calculated is subject to a minimum value:
+       !! \latexonly 
+       !!     \input{diffucoaero8.tex}
+       !! \endlatexonly       
+       zri = MAX(MIN(zri,5.),-5.)
+       
+       !! 1a).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.
+       !! \latexonly 
+       !!     \input{diffucoaero9.tex}
+       !! \endlatexonly
+       cd_neut = (ct_karman / LOG( (zlev(ji) + roughheight(ji)) / z0(ji) )) ** 2 
+       
+       !! 1a).7.1 - for the stable case (i.e $R_i$ $\geq$ 0)
+       IF (zri .GE. zero) THEN
+          
+          !! \latexonly 
+          !!     \input{diffucoaero10.tex}
+          !! \endlatexonly
+          zscf = SQRT(un + cd * ABS(zri))
+         
+          !! \latexonly 
+          !!     \input{diffucoaero11.tex}
+          !! \endlatexonly          
+          cd_tmp=cd_neut/(un + trois * cb * zri * zscf)
+       ELSE
+          
+          !! 1a).7.2 - for the unstable case (i.e. $R_i$ < 0)
+          !! \latexonly 
+          !!     \input{diffucoaero12.tex}
+          !! \endlatexonly
+          zscf = un / (un + trois * cb * cc * cd_neut * SQRT(ABS(zri) * &
+               & ((zlev(ji) + roughheight(ji)) / z0(ji))))
+          
+          !! \latexonly 
+          !!     \input{diffucoaero13.tex}
+          !! \endlatexonly               
+          cd_tmp=cd_neut * (un - trois * cb * zri * zscf)
+       ENDIF
+       
+       !! If the Drag Coefficient becomes too small than the surface may uncouple from the atmosphere.
+       !! To prevent this, a minimum limit to the drag coefficient is defined as:
+       
+       !! \latexonly 
+       !!     \input{diffucoaero14.tex}
+       !! \endlatexonly
+       !!
+       q_cdrag(ji) = MAX(cd_tmp, ra_max/MAX(speed,min_wind)) ! 1.5e-2 1.e-4
+       !write(*,*) 'q_cdrag',q_cdrag(ji)
+       !write(*,*) 'cd_tmp',cd_tmp
+       ! 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
+
+    ! JR this is to induce a very high drag coefficient as a test (over the mountains or something)
+
+    ! q_cdrag = q_cdrag * 400.0d0
+
+    IF (long_print) WRITE (numout,*) ' not ldqcdrag_from_gcm : diffuco_aero done '
+
+  END SUBROUTINE diffuco_aero
+
+
+!! ================================================================================================================================
+!! SUBROUTINE    : diffuco_snow
+!!
+!>\BRIEF         This subroutine computes the beta coefficient for snow sublimation.
+!!
+!! DESCRIPTION   : This routine computes beta coefficient for snow sublimation, which
+!! integrates the snow on both vegetation and other surface types (e.g. ice, lakes,
+!! cities etc.) \n
+!!
+!! A critical depth of snow (snowcri) is defined to calculate the fraction of each grid-cell
+!! that is covered with snow (snow/snowcri) while the remaining part is snow-free.
+!! We also carry out a first calculation of sublimation (subtest) to lower down the beta
+!! coefficient if necessary (if subtest > snow). This is a predictor-corrector test. 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::vbeta1 
+!!
+!! REFERENCE(S) :
+!! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+!! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+!! Circulation Model. Journal of Climate, 6, pp. 248-273
+!! - Guimberteau, M, 2010. ModÃ©lisation de l'hydrologie continentale et influences de l'irrigation
+!! sur le cycle de l'eau, PhD Thesis, available from:
+!! http://www.sisyphe.upmc.fr/~guimberteau/docs/manuscrit_these.pdf
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+  
+SUBROUTINE diffuco_snow (kjpindex, dtradia, qair, qsatt, rau, u, v,q_cdrag, &
+       & snow, frac_nobio, totfrac_nobio, snow_nobio, vbeta1)
+
+  !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+ 
+    INTEGER(i_std), INTENT(in)                           :: kjpindex       !! Domain size (-)
+    REAL(r_std), INTENT (in)                             :: dtradia        !! Time step in seconds (s)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: qair           !! Lowest level specific air humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: qsatt          !! Surface saturated humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: rau            !! Air density (kg m^{-3})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: u              !! Eastward Lowest level wind speed (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: v              !! Northward Lowest level wind speed (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: q_cdrag        !! Product of surface drag coefficient and wind speed (s m^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: snow           !! Snow mass (kg m^{-2})
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: frac_nobio     !! Fraction of ice, lakes, cities etc. (-)
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: snow_nobio     !! Snow on ice, lakes, cities etc. (-)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: totfrac_nobio  !! Total fraction of ice, lakes, cities etc. (-)
+    
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)       :: vbeta1         !! Beta for sublimation (dimensionless ratio) 
+    
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    REAL(r_std)                                          :: subtest        !! Sublimation for test (kg m^{-2})
+    REAL(r_std)                                          :: zrapp          !! Modified factor (ratio)
+    REAL(r_std)                                          :: speed          !! Wind speed (m s^{-1})
+    REAL(r_std)                                          :: vbeta1_add     !! Beta for sublimation (ratio)
+    INTEGER(i_std)                                       :: ji, jv         !! Indices (-)
+!_ ================================================================================================================================
+
+  !! 1. Calculate beta coefficient for snow sublimation on the vegetation\n
+
+    DO ji=1,kjpindex  ! Loop over # pixels - domain size
+
+       ! 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 demand. 
+       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 ! Loop over # pixels - domain size
+
+  !! 2. Add the beta coefficients calculated from other surfaces types (snow on ice,lakes, cities...)
+
+    DO jv = 1, nnobio ! Loop over # other surface types
+!!$      !
+!!$      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 ! Loop over # pixels - domain size
+
+           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))
+            
+            !!     Limitation of sublimation by the snow accumulated on the ground 
+            !!     A first approximation is obtained with the old values of
+            !!     qair and qsol_sat: function of temp-sol and pb. (see call of qsatcalc)
+           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 ! Loop over # pixels - domain size
+
+!!$      ENDIF
+      
+    ENDDO ! Loop over # other surface types
+
+    IF (long_print) WRITE (numout,*) ' diffuco_snow done '
+
+  END SUBROUTINE diffuco_snow
+
+
+!! ================================================================================================================================
+!! SUBROUTINE		 			: diffuco_flood 
+!!
+!>\BRIEF				       	This routine computes partial beta coefficient : floodplains
+!!
+!! DESCRIPTION				        : 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S)	                : vbeta5
+!!
+!! REFERENCE(S)				        : None
+!!
+!! FLOWCHART                                    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE diffuco_flood (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, evapot, evapot_corr, &
+       & flood_frac, flood_res, vbeta5)
+
+    ! 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)            :: flood_res  !! water mass in flood reservoir
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: flood_frac !! fraction of floodplains
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: evapot     !! Potential evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: evapot_corr!! Potential evaporation2
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: vbeta5     !! Beta for floodplains
+
+    ! local declaration
+    REAL(r_std)                                              :: subtest, zrapp, speed
+    INTEGER(i_std)                                           :: ji, jv
+
+!_ ================================================================================================================================
+    !
+    ! beta coefficient for sublimation for floodplains
+    !
+    DO ji=1,kjpindex
+       !
+       IF (evapot(ji) .GT. min_sechiba) THEN
+          vbeta5(ji) = flood_frac(ji) *evapot_corr(ji)/evapot(ji)
+       ELSE
+          vbeta5(ji) = flood_frac(ji)
+       ENDIF
+       !
+       ! -- Limitation of evaporation in case of water amounts smaller than
+       !    the atmospheric demand. 
+       
+       !
+       speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+       !
+       subtest = dtradia * vbeta5(ji) * speed * q_cdrag(ji) * rau(ji) * &
+               & ( qsatt(ji) - qair(ji) )
+       !  
+       IF ( subtest .GT. zero ) THEN
+          zrapp = flood_res(ji) / subtest
+          IF ( zrapp .LT. un ) THEN
+             vbeta5(ji) = vbeta5(ji) * zrapp
+          ENDIF
+       ENDIF
+       !
+    END DO
+
+    IF (long_print) WRITE (numout,*) ' diffuco_flood done '
+
+  END SUBROUTINE diffuco_flood
+
+
+!! ================================================================================================================================
+!! SUBROUTINE    : diffuco_inter
+!!
+!>\BRIEF	 This routine computes the partial beta coefficient
+!! for the interception for each type of vegetation
+!!
+!! DESCRIPTION   : We first calculate the dry and wet parts of each PFT (wet part = qsintveg/qsintmax).
+!! The former is submitted to transpiration only (vbeta3 coefficient, calculated in 
+!! diffuco_trans or diffuco_trans_co2), while the latter is first submitted to interception loss 
+!! (vbeta2 coefficient) and then to transpiration once all the intercepted water has been evaporated 
+!! (vbeta23 coefficient). Interception loss is also submitted to a predictor-corrector test, 
+!! as for snow sublimation. \n
+!!
+!! \latexonly 
+!!     \input{diffucointer1.tex}
+!! \endlatexonly
+!! Calculate the wet fraction of vegetation as  the ration between the intercepted water and the maximum water 
+!! on the vegetation. This ratio defines the wet portion of vegetation that will be submitted to interception loss.
+!!
+!! \latexonly 
+!!     \input{diffucointer2.tex}
+!! \endlatexonly
+!!
+!! Calculation of $\beta_3$, the canopy transpiration resistance
+!! \latexonly 
+!!     \input{diffucointer3.tex}
+!! \endlatexonly            
+!! 
+!! We here determine the limitation of interception loss by the water stored on the leaf. 
+!! A first approximation of interception loss is obtained using the old values of
+!! qair and qsol_sat, which are functions of temp-sol and pb. (see call of 'qsatcalc')
+!! \latexonly 
+!!     \input{diffucointer4.tex}
+!! \endlatexonly
+!!
+!! \latexonly
+!!     \input{diffucointer5.tex}
+!! \endlatexonly
+!!
+!! \latexonly 
+!!     \input{diffucointer6.tex}
+!! \endlatexonly
+!!
+!! Once the whole water stored on foliage has evaporated, transpiration can take place on the fraction
+!! 'zqsvegrap'.
+!! \latexonly 
+!!     \input{diffucointer7.tex}
+!! \endlatexonly
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::vbeta2, ::vbeta23
+!!
+!! REFERENCE(S) :
+!! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+!! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+!! Circulation Model. Journal of Climate, 6, pp. 248-273
+!! - Guimberteau, M, 2010. ModÃ©lisation de l'hydrologie continentale et influences de l'irrigation
+!! sur le cycle de l'eau, PhD Thesis, available from:
+!! http://www.sisyphe.upmc.fr/~guimberteau/docs/manuscrit_these.pdf
+!! - Perrier, A, 1975. Etude physique de l'Ã©vaporation dans les conditions naturelles. Annales 
+!! Agronomiques, 26(1-18): pp. 105-123, pp. 229-243
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE diffuco_inter (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, humrel, veget, &
+     & qsintveg, qsintmax, rstruct, vbeta2, vbeta23)
+    !AD090715 tzj_wb: adding humrel to the arguments
+   
+  !! 0 Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                           :: kjpindex   !! Domain size (-)
+    REAL(r_std), INTENT (in)                             :: dtradia    !! Time step (s)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: qair       !! Lowest level specific air humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: qsatt      !! Surface saturated humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: rau        !! Air Density (kg m^{-3})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: u          !! Eastward Lowest level wind speed (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: v          !! Northward Lowest level wind speed (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: q_cdrag    !! Product of Surface drag coefficient and wind 
+                                                                       !! speed (m s^{-1})
+! AD090715 tzj_wb
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: humrel     !! Soil moisture stress (within range 0 to 1)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: veget      !! vegetation fraction for each type (fraction)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: qsintveg   !! Water on vegetation due to interception (kg m^{-2})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: qsintmax   !! Maximum water on vegetation (kg m^{-2})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: rstruct    !! architectural resistance (s m^{-1})
+    
+    !! 0.2 Output variables
+    
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)   :: vbeta2     !! Beta for interception loss (-)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)   :: vbeta23    !! Beta for fraction of wetted foliage that will 
+                                                                       !! transpire (-)
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                       :: ji, jv                               !! (-), (-)
+    REAL(r_std)                                          :: zqsvegrap, ziltest, zrapp, speed     !!
+!_ ================================================================================================================================
+
+  !! 1. Initialize
+
+    vbeta2(:,:) = zero
+    vbeta23(:,:) = zero
+   
+  !! 2. The beta coefficient for interception by vegetation. 
+    
+    DO jv = 2,nvm
+
+      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
+
+            !! \latexonly 
+            !!     \input{diffucointer1.tex}
+            !! \endlatexonly
+            !!
+            !! We calculate the wet fraction of vegetation as  the ration between the intercepted water and the maximum water 
+            !! on the vegetation. This ratio defines the wet portion of vegetation that will be submitted to interception loss.
+            !!
+                zqsvegrap = MAX(zero, qsintveg(ji,jv) / qsintmax(ji,jv))
+            END IF
+
+            !! \latexonly 
+            !!     \input{diffucointer2.tex}
+            !! \endlatexonly
+            speed = MAX(min_wind, wind(ji))
+
+            !! Calculation of $\beta_3$, the canopy transpiration resistance
+            !! \latexonly 
+            !!     \input{diffucointer3.tex}
+            !! \endlatexonly
+            vbeta2(ji,jv) = veget(ji,jv) * zqsvegrap * (un / (un + speed * q_cdrag(ji) * rstruct(ji,jv)))
+            
+            !! We here determine the limitation of interception loss by the water stored on the leaf. 
+            !! A first approximation of interception loss is obtained using the old values of
+            !! qair and qsol_sat, which are functions of temp-sol and pb. (see call of 'qsatcalc')
+            !! \latexonly 
+            !!     \input{diffucointer4.tex}
+            !! \endlatexonly
+            ziltest = dtradia * vbeta2(ji,jv) * speed * q_cdrag(ji) * rau(ji) * &
+               & ( qsatt(ji) - qair(ji) )
+
+            IF ( ziltest .GT. zero ) THEN
+
+                !! \latexonly 
+                !!     \input{diffucointer5.tex}
+                !! \endlatexonly
+                zrapp = qsintveg(ji,jv) / ziltest
+                IF ( zrapp .LT. un ) THEN
+                   
+                    !! \latexonly 
+                    !!     \input{diffucointer6.tex}
+                    !! \endlatexonly
+                    !!
+		    !! Once the whole water stored on foliage has evaporated, transpiration can take place on the fraction
+                    !! 'zqsvegrap'.
+                    vbeta23(ji,jv) = MAX(vbeta2(ji,jv) - vbeta2(ji,jv) * zrapp, zero)
+! AD090715 tzj_wb: add dependence on humrel, as we don't want transpiration when the soil cannot deliver it
+                    IF ( humrel(ji,jv) .LT. min_sechiba ) THEN
+                       vbeta23(ji,jv) = zero
+                    ENDIF
+                    
+                    !! \latexonly 
+                    !!     \input{diffucointer7.tex}
+                    !! \endlatexonly
+                    vbeta2(ji,jv) = vbeta2(ji,jv) * zrapp
+                ENDIF
+            ENDIF
+        END IF
+!        ! Autre formulation possible pour l'evaporation permettant une transpiration sur tout le feuillage
+!        !commenter si formulation Nathalie sinon Tristan
+!        speed = MAX(min_wind, wind(ji))
+!        
+!        vbeta23(ji,jv) = MAX(zero, veget(ji,jv) * (un / (un + speed * q_cdrag(ji) * rstruct(ji,jv))) - vbeta2(ji,jv))
+
+      END DO
+
+    END DO
+
+    IF (long_print) WRITE (numout,*) ' diffuco_inter done '
+
+  END SUBROUTINE diffuco_inter
+
+
+!! ==============================================================================================================================
+!! SUBROUTINE      : diffuco_bare
+!!
+!>\BRIEF	   This routine computes the partial beta coefficient corresponding to
+!! bare soil
+!!
+!! DESCRIPTION	   : Bare soil evaporation is either limited by a soil resistance 
+!! (rsol) that is calculated in hydrolc.f90, when Choisnel hydrology is used or 
+!! submitted to a maximum possible flow (evap_bare_lim) if the 11-layer hydrology is used.\n
+!! 
+!! Calculation of wind speed
+!! \latexonly 
+!!     \input{diffucobare1.tex}
+!! \endlatexonly
+!!             
+!! The calculation of $\beta_4$
+!! \latexonly 
+!!     \input{diffucobare2.tex}
+!! \endlatexonly
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::vbeta4
+!!
+!! REFERENCE(S)	 :
+!! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+!! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+!! Circulation Model. Journal of Climate, 6, pp.248-273
+!! - Guimberteau, M, 2010. ModÃ©lisation de l'hydrologie continentale et influences de l'irrigation
+!! sur le cycle de l'eau, PhD Thesis, available from:
+!! http://www.sisyphe.upmc.fr/~guimberteau/docs/manuscrit_these.pdf
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE diffuco_bare (kjpindex, dtradia, u, v, q_cdrag, rsol, evap_bare_lim, humrel, &
+       & veget, veget_max, vbeta2, vbeta3, vbeta4)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+    INTEGER(i_std), INTENT(in)                         :: kjpindex       !! Domain size (-)
+    REAL(r_std), INTENT (in)                           :: dtradia        !! Time step (s)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: u              !! Eastward Lowest level wind speed (m s^{-1}) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: v              !! Northward Lowest level wind speed (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: q_cdrag        !! Product of Surface drag coefficient and wind speed 
+                                                                         !! (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: rsol           !! resistance for bare soil evaporation  (s m^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: evap_bare_lim  !! limiting factor for bare soil evaporation when the 
+                                                                         !! 11-layer hydrology is used (-)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: humrel         !! Soil moisture stress (within range 0 to 1)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget          !! Type of vegetation fraction (-)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget_max      !! Type of vegetation max fraction
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: vbeta2         !! Beta for Interception 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: vbeta3         !! Beta for Transpiration 
+
+    !! 0.2 Output variables
+    
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: vbeta4         !! Beta for bare soil evaporation (-)
+    
+    !! 0.3 Modified variables
+        
+    !! 0.4 Local variables
+    REAL(r_std)                                    :: humveg_prod
+
+    INTEGER(i_std)                                     :: ji, jv
+    REAL(r_std)                                        :: speed          !! Surface wind speed (m s^{-1})
+!_ ================================================================================================================================
+
+  !! 1. Calculation of the soil resistance and the beta (beta_4) for bare soil
+
+    IF ( .NOT. control%hydrol_cwrr ) THEN
+       DO ji = 1, kjpindex
+          
+          vbeta4(ji) = zero
+          !     
+          ! 1.   Soil resistance and beta for bare soil
+          !      note: tot_bare_soil contains the fraction of bare soil
+          !            see slowproc module
+          !
+          speed = MAX(min_wind, wind(ji))
+          !
+          humveg_prod = tot_bare_soil(ji) * humrel(ji,1)
+          !
+          DO jv = 2, nvm
+             humveg_prod = humveg_prod + veget(ji,jv) * humrel(ji,jv)
+          ENDDO
+            
+             !! \latexonly 
+             !!     \input{diffucobare1.tex}
+             !! \endlatexonly
+          IF (tot_bare_soil(ji) .GE. min_sechiba) THEN
+             
+             ! Correction Nathalie de Noblet - le 27 Mars 2006
+             ! Selon recommandation de Frederic Hourdin: supprimer humrel dans formulation vbeta4
+             !vbeta4(ji) = tot_bare_soil(ji) *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) = tot_bare_soil(ji) * (un / (un + speed * q_cdrag(ji) * rsol(ji)))
+             
+          ENDIF
+          !Commenter la ligne ci-dessous si calcul Nathalie sinon Tristan
+!          vbeta4(ji) = MIN(humveg_prod * (un / (un + speed * q_cdrag(ji) * rsol(ji))), &
+!               & un - SUM(vbeta2(ji,:)+vbeta3(ji,:)))
+          
+       END DO
+    ELSE
+       DO ji = 1, kjpindex
+
+          ! The limitation by 1-beta2-beta3 is due to the fact that evaporation under vegetation is possible
+          !! \latexonly 
+          !!     \input{diffucobare3.tex}
+          !! \endlatexonly
+          vbeta4(ji) = MIN(evap_bare_lim(ji), un - SUM(vbeta2(ji,:)+vbeta3(ji,:)))
+       END DO
+    ENDIF
+    
+    IF (long_print) WRITE (numout,*) ' diffuco_bare done '
+    
+  END SUBROUTINE diffuco_bare
+
+
+!! ================================================================================================================================
+!! SUBROUTINE	: diffuco_trans 
+!!
+!>\BRIEF        This routine computes the partial beta coefficient 
+!! corresponding to transpiration for each vegetation type.
+!!
+!! DESCRIPTION  : Beta coefficients for transpiration are calculated 
+!! here using Jarvis formulation for stomatal resistance and
+!! the structural resistance to represent the vertical gradient of 
+!! transpiration within the canopy. \n
+!!
+!! The Jarvis formulation as used here is derived by Lohanner et al. (1980) from Jarvis (1976). This formulation is
+!! semi-empirical: \n
+!!
+!! \latexonly 
+!!     \input{diffucotrans4.tex}
+!! \endlatexonly
+!! \n
+!!            
+!! where in this expression LAI is the single sided Leaf Area Index, R_{new}^{SW} the net shortwave radiation,
+!! R_{SO} the half light saturation factor, \delta c the water vapour concentration deficit, and a, k_0 and \lambda
+!! are all parameters that are derived from extensive measurement of surface layer vegetation. \n
+!!
+!! Structural resistance (or architectural resistance) is a function of vegetation type and is assigned based on the
+!! particular Plant Functional Type (PFT) in question. The range of values for the structural resistance are listed
+!! in the module 'pft_parameters', and are described in de Noblet-DucoudrÃ© et al (1993). \n
+!!
+!! vbetaco2 is here set to zero as this way to compute canopy resistances is only used 
+!! without STOMATE, and there is therefore no photosynthesis. \n
+!!
+!! Moisture concentration at the leaf level.
+!! \latexonly 
+!!     \input{diffucotrans1.tex}
+!! \endlatexonly
+!!   
+!! Calulation of the beta coefficient for vegetation transpiration, beta_3.
+!! \latexonly 
+!!     \input{diffucotrans2.tex}
+!! \endlatexonly
+!! \latexonly             
+!!     \input{diffucotrans3.tex}
+!! \endlatexonly
+!!
+!! \latexonly 
+!!     \input{diffucotrans4.tex}
+!! \endlatexonly            
+!!
+!! This is the formulation for beta_3.
+!! \latexonly 
+!!     \input{diffucotrans5.tex}
+!! \endlatexonly
+!!
+!! \latexonly 
+!!     \input{diffucotrans6.tex}
+!! \endlatexonly
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::vbeta3, ::rveget, ::cimean and ::vbetaco2
+!!
+!! REFERENCE(S) :
+!! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+!! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+!! Circulation Model. Journal of Climate, 6, pp.248-273
+!! - Guimberteau, M, 2010. ModÃ©lisation de l'hydrologie continentale et influences de l'irrigation
+!! sur le cycle de l'eau, PhD Thesis, available from:
+!! http://www.sisyphe.upmc.fr/~guimberteau/docs/manuscrit_these.pdf
+!! - Jarvis, PG, 1976. The interpretation of the variations in leaf water potential and stomatal
+!! conductance found in canopies in the fields. Philosophical Transactions of the Royal Society of
+!! London, Series B, 273, pp. 593-610
+!! - Lohammer T, Larsson S, Linder S & Falk SO, 1980. Simulation models of gaseous exchange in Scotch
+!! pine. Structure and function of Northern Coniferous Forest, Ecological Bulletin, 32, pp. 505-523
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE diffuco_trans (kjpindex, dtradia, swnet, temp_air, pb, qair, rau, u, v, q_cdrag, humrel, &
+                            veget, veget_max, lai, qsintveg, qsintmax, vbeta3, vbeta3pot, rveget, rstruct, &
+                            cimean, vbetaco2, vbeta23)  
+
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+    
+    INTEGER(i_std), INTENT(in)                         :: kjpindex   !! Domain size (-)
+    REAL(r_std), INTENT (in)                           :: dtradia    !! Time step (s)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: swnet      !! Short wave net flux at surface (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_air   !! Air temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: pb         !! Lowest level pressure (hPa)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: qair       !! Lowest level specific air humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: rau        !! Air Density (kg m^{-3})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: u          !! Eastward Lowest level wind speed (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: v          !! Northward Lowest level wind speed (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: q_cdrag    !! Product of Surface drag coefficient and wind speed 
+                                                                     !! (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: humrel     !! Soil moisture stress (within range 0 to 1)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget      !! Type of vegetation (-)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget_max  !! Max. vegetation fraction (LAI->infty) (fraction)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: lai        !! Leaf area index (m^2 m^{-2})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: qsintveg   !! Water on vegetation due to interception (kg m^{-2})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: qsintmax   !! Maximum water on vegetation (kg m^{-2})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: rstruct    !! Structural resistance (s m^{-1})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: vbeta23    !! Beta for wetted foliage fraction that will transpire (-)
+    
+    !! 0.2 Output variables
+    
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbeta3     !! Beta for Transpiration (-)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbeta3pot  !! Beta for Potential Transpiration
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: rveget     !! Stomatal resistance of the whole canopy (s m^{-1})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: cimean     !! STOMATE: mean intercellular ci (see enerbil) 
+                                                                     !! (\mumol m^{-2} s^{-1}) 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbetaco2   !! STOMATE: Beta for CO2 (-)
+
+    !! 0.3 Modified variables
+  
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                     :: ji, jv
+    REAL(r_std)                                        :: speed
+    REAL(r_std), DIMENSION(kjpindex)                   :: zdefconc, zqsvegrap
+    REAL(r_std), DIMENSION(kjpindex)                   :: qsatt
+    REAL(r_std),DIMENSION (kjpindex,nvm)               :: rveget_min           !! Minimal Surface resistance of vegetation
+!_ ================================================================================================================================
+
+
+  !! 1.  Moisture concentration at the leaf level.
+ 
+    ! WRITE(*,*) '181113a test, pre call to qsatcalc diffuco line 1980; temp_air is: ', temp_air
+   
+    CALL qsatcalc (kjpindex, temp_air, pb, qsatt)
+    
+    !! \latexonly 
+    !!     \input{diffucotrans1.tex}
+    !! \endlatexonly
+    zdefconc(:) = rau(:) * MAX( qsatt(:) - qair(:), zero )
+
+   
+  !! 2. Calulation of the beta coefficient for vegetation transpiration, beta_3.
+
+    rveget(:,:) = undef_sechiba
+    rveget_min(:,:) = undef_sechiba
+    vbeta3(:,:) = zero
+    vbeta3pot(:,:) = zero
+
+    DO jv = 2,nvm
+
+      zqsvegrap(:) = zero
+
+      DO ji = 1, kjpindex
+
+        IF(veget_max(ji,jv) == zero)THEN
+            ! this vegetation type is not present, so no reason to do the 
+            ! calculation
+            CYCLE
+        ENDIF
+
+         !! \latexonly 
+         !!     \input{diffucotrans2.tex}
+         !! \endlatexonly
+         speed = MAX(min_wind, wind(ji))
+
+         IF (qsintmax(ji,jv) .GT. min_sechiba) THEN
+        
+            !! \latexonly 
+            !!     \input{diffucotrans3.tex}
+            !! \endlatexonly
+            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
+
+            !! \latexonly 
+            !!     \input{diffucotrans4.tex}
+            !! \endlatexonly            
+            rveget(ji,jv) = (( swnet(ji) + rayt_cste ) / swnet(ji) ) &
+                 * ((defc_plus + (defc_mult * zdefconc(ji) )) / kzero(jv)) * (un / lai(ji,jv))
+
+            rveget_min(ji,jv) = (defc_plus / 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))))
+            !write(*,*) 'zqsvegrap',zqsvegrap(ji)
+            !write(*,*) 'humrel',humrel(ji,jv)
+            !write(*,*) 'rveget',rveget(ji,jv)
+            !write(*,*) 'rstruct',rstruct(ji,jv)
+            !write(*,*) 'q_cdrag_a',q_cdrag(ji) 
+            !! This is the formulation for $beta_3$.
+            !! \latexonly 
+            !!     \input{diffucotrans5.tex}
+            !! \endlatexonly
+            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
+
+            !! \latexonly 
+            !!     \input{diffucotrans6.tex}
+            !! \endlatexonly
+            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))))))
+            !write(*,*) 'vbeta3_diffuco_trans',vbeta3(ji,jv)
+            ! Fin ajout Nathalie
+            ! Autre possibilite permettant la transpiration sur toute la canopee
+            !Commenter si formulation Nathalie sinon Tristan
+!            vbeta3(ji,jv) = MAX(zero, MIN(vbeta23(ji,jv), &
+!                 & veget_max(ji,jv) * humrel(ji,jv) / &
+!                 & (un + speed * q_cdrag(ji) * (rveg_pft(jv)*(rveget(ji,jv) + rstruct(ji,jv))))))
+
+           ! vbeta3pot for computation of potential transpiration (needed for irrigation)
+            vbeta3pot(ji,jv) = &
+                 &  MAX(zero, veget_max(ji,jv) / &
+                 & (un + speed * q_cdrag(ji) * (rveg_pft(jv)*(rveget_min(ji,jv) + rstruct(ji,jv)))))
+            !write(*,*) 'vbeta3pot_diffuco_trans',vbeta3pot(ji,jv)
+         ENDIF
+
+      ENDDO
+
+    ENDDO
+
+    ! STOMATE
+    cimean(:,:) = zero
+    vbetaco2(:,:) = zero
+
+    IF (long_print) WRITE (numout,*) ' diffuco_trans done '
+
+  END SUBROUTINE diffuco_trans
+
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : diffuco_trans_co2
+!!
+!>\BRIEF        This subroutine computes carbon assimilation and stomatal 
+!! conductance, following respectively Farqhuar et al. (1980) and Ball et al. (1987) 
+!! and Yin X and Struik PC. 2009.
+!!
+!! DESCRIPTION  :\n
+!! *** General:\n 
+!! The equations are different depending on the photosynthesis mode (C3 versus C4).
+!! Based on the work of Farquhar, von Caemmerer and Berry who published in 1980 a
+!! biochemical model for C3 photosynthetic rates (the FvCB model), Yin and
+!! Struik 2009 propose an analytical algorithm that incorporates a gs model and uses gm as a
+!! temperature-dependent parameter for calculating assimilation based on the FvCB
+!! model for various environmental scenarios. Yin and Struik 2009 also propose a
+!! C4-equivalent version of the FvCB model and an associated analytical algorithm
+!! for this model. They believe that applying FvCB-type models to both C3 and C4
+!! crops is recommended to accurately predict the response of crop photosynthesis
+!! to multiple, interactive environmental variables.  \n
+!!
+!!  Besides an analytical solution for photosynthesis the scheme includes a
+!! modified Arrhenius function for the temperature dependence that accounts for a
+!! decrease of Vcmax and Jmax at high temperatures and a temperature dependent
+!! J max/Vcmax ratio (Kattge & Knorr 2007). The temperature response of Vcmax and
+!! J max was parametrized with values from reanalysed data in literature (Kattge &
+!! Knorr 2007), whereas Vcmax and Jmax at a reference temperature of 25Â° C were
+!! derived from observed species-specific values in the TRY database (Kattge et
+!! al. 2011).
+!!   
+!! In this version here we replace the old trunk assimilation and conductance 
+!! which were computed over 20 levels of LAI and then integrated at the canopy level. 
+!! These artificial LAI levels  were introduced in order to allow for a saturation of
+!! photosynthesis with LAI, but they have no physical meaning. The approach of
+!  the two stream radiation transfer model was extended for a multi-layer canopy.
+!! The use can choose the numbers of layers in the run.def and the available light at
+!! each layers decides about the numbers of layers used for the photosynthesis
+!! calculation.
+!!
+!! NOTE: The variable Isotrop_Abs_Tot_p is the amount of light abosrbed by the canopy,
+!!       according to the two stream albedo routine.  Notice that this is the absorption
+!!       profile for light coming from an isotropic source (e.g. clouds, and what little
+!!       light is scattered by the atmosphere on a sunny day).  The real absorbed light
+!!       should have both the incoming radiation from clouds and the incoming radiation
+!!       from the sun, not just a single number like we have now.  If that information
+!!       ever becomes available, Collim_Abs_Tot should be passed from the albedo routines
+!!       and used here as well.
+!!
+!! RECENT CHANGE(S): 
+!!
+!! MAIN OUTPUT VARIABLE(S): beta coefficients, resistances, CO2 intercellular 
+!! concentration
+!!
+!! REFERENCE(S) :
+!!
+!!     Yin X, Struik PC. C3 and C4 photosynthesis models: an overview from the
+!! perspective of crop modelling. NJAS-Wageningen Journal of Life Sciences 2009.
+!!     C.J. Bernacchi, A.R. Portis, H. Nakano, S. von Caemmerer, S.P. Long,
+!! Temperature response of mesophyll conductance. Implication for the determination
+!! of Rubisco enzyme kinetics and for limitations to photosynthesis in vivo, Plant
+!! Physiology 130 (2002) 1992â1998.
+!!     C.J. Bernacchi, E.L. Singsaas, C. Pimentel, A.R. Portis Jr., S.P. Long,
+!! Improved temperature response functions for models of Rubisco-limited
+!! photosynthesis, Plant, Cell and Environment 24 (2001) 253â259.
+!!     B.E. Medlyn, E. Dreyer, D. Ellsworth, M. Forstreuter, P.C. Harley, M.U.F.
+!! Kirschbaum, X. Le Roux, P. Montpied, J. Strassemeyer, A. Walcroft, K. Wang, D.
+!! Loustau, Temperature response of parameters of a biochemically based model of
+!! photosynthesis. II. A review of experimental data, Plant, Cell and Environ- ment
+!! 25 (2002) 1167â1179.
+!!     Kattge, J. and Knorr, W.: Temperature acclimation in a biochemical model of
+!! photosynthesis: a reanalysis of data from 36 species, Plant Cell Environ., 30
+!! (2007) 1176â1190.
+!!     Keenan, T., et al., Soil water stress and coupled photosynthesisâconductance
+!! models: Bridging the gap between conflicting reports on the relative roles of
+!! stomatal, mesophyll conductance and biochemical limitations to photosynthesis.
+!! Agric. Forest Meteorol. (2010) 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE diffuco_trans_co2 (kjpindex, dtradia, swdown, temp_sol, pb, qsurf, q2m, t2m, &
+                                temp_growth, rau, u, v, q_cdrag, humrel, vegstress, &
+                                assim_param, Ca, &
+                                veget_max, qsintveg, qsintmax, vbeta3, vbeta3pot, rveget, rstruct, &
+                                cimean, gsmean, gpp, vbeta23, Isotrop_Abs_Tot_p,&
+                                Isotrop_Tran_Tot_p, lai_per_level, gs_distribution, gs_diffuco_output, &
+                                gstot_component, gstot_frac, veget, biomass,  warnings)
+! tzj_wb add humrel ds les arguments
+!
+    !! 0. Variable and parameter declaration
+    !
+
+    !
+    !! 0.1 Input variables
+    !
+   
+    INTEGER(i_std), INTENT(in)                               :: kjpindex         !! Domain size (unitless)
+    REAL(r_std), INTENT (in)                                 :: dtradia          !! Time step (s)
+    REAL(r_std),DIMENSION (:), INTENT (in)                   :: swdown           !! Downwelling short wave flux 
+                                                                                 !! @tex ($W m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (:), INTENT (in)                   :: temp_sol         !! Skin temperature (K)
+    REAL(r_std),DIMENSION (:), INTENT (in)                   :: pb               !! Lowest level pressure (hPa)
+    REAL(r_std),DIMENSION (:), INTENT (in)                   :: qsurf            !! Near surface specific humidity 
+                                                                                 !! @tex ($kg kg^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q2m              !! 2m specific humidity 
+                                                                                 !! @tex ($kg kg^{-1}$) @endtex
+    ! In off-line mode q2m and qair are the same.
+    ! In off-line mode t2m and temp_air are the same.
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: t2m              !! 2m air temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_growth      !! Growth temperature (Â°C) - Is equal to t2m_month
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: rau              !! air density @tex ($kg m^{-3}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u                !! Lowest level wind speed 
+                                                                                 !! @tex ($m s^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: v                !! Lowest level wind speed 
+                                                                                 !! @tex ($m s^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q_cdrag          !! Surface drag 
+                                                                                 !! @tex ($m s^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: humrel           !! tzj_wb  Soil moisture stress (0-1,unitless) 
+    REAL(r_std),DIMENSION (:,:,:), INTENT (in)               :: assim_param      !! min+max+opt temps (K), vcmax, vjmax for 
+                                                                                 !! photosynthesis 
+                                                                                 !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: Ca               !! CO2 concentration inside the canopy
+                                                                                 !! @tex ($\mu mol mol^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: vegstress        !! Soil moisture stress (0-1,unitless) 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: veget_max        !! Maximum vegetation fraction of each PFT inside 
+                                                                                 !! the grid box (0-1, unitless) 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: qsintveg       !! Water on vegetation due to interception 
+                                                                                 !! @tex ($kg m^{-2}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: qsintmax         !! Maximum water on vegetation
+                                                                                 !! @tex ($kg m^{-2}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: vbeta23          !! Beta for fraction of wetted foliage that will 
+                                                                                 !! transpire (unitless) 
+    REAL(r_std),DIMENSION (:,:,:), INTENT (in)               :: Isotrop_Abs_Tot_p !! Absorbed radiation per level for photosynthesis
+    REAL(r_std),DIMENSION (:,:,:), INTENT (in)               :: Isotrop_Tran_Tot_p !! Transmitted radiation per level for photosynthesis
+    REAL(r_std), DIMENSION(:,:,:), INTENT (in)               :: lai_per_level    !! This is the LAI per vertical level
+                                                                                 !! @tex $(m^{2} m^{-2})$
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT (in)        :: veget
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT (in)             :: biomass          !! Stand level biomass @tex $(gC m^{-2})$ @endtex
+    
+    !
+    !! 0.2 Output variables
+    !
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: vbeta3           !! Beta for Transpiration (unitless)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: vbeta3pot        !! Beta for Potential Transpiration
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: rveget           !! stomatal resistance of vegetation 
+                                                                                 !! @tex ($s m^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: rstruct          !! structural resistance @tex ($s m^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: cimean           !! mean intercellular CO2 concentration 
+                                                                                 !! @tex ($\mu mol mol^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: gsmean           !! mean stomatal conductance to CO2 (umol m-2 s-1)
+    REAL(r_Std),DIMENSION (kjpindex,nvm), INTENT (out)       :: gpp              !! Photosynthesis
+
+    REAL(r_Std),DIMENSION (kjpindex,nvm,nlevels_tot), INTENT (out) &
+                                                             :: gs_distribution    
+    REAL(r_Std),DIMENSION (kjpindex,nvm,nlevels_tot), INTENT (out) &
+                                                             :: gs_diffuco_output
+    REAL(r_Std),DIMENSION (kjpindex,nvm,nlevels_tot), INTENT (out)       :: gstot_component
+    REAL(r_Std),DIMENSION (kjpindex,nvm,nlevels_tot), INTENT (out)       :: gstot_frac
+    
+ !! Assimilation ((gC m^{-2} s^{-1}), total area)
+    !
+    !! 0.3 Modified variables
+    !
+    REAL(r_std),DIMENSION(kjpindex,nvm,nwarns), INTENT(inout) &
+                                                             :: warnings         !! A warning counter
+ 
+    !
+    !! 0.4 Local variables
+    !
+    
+   ! REAL(r_std),SAVE, ALLOCATABLE,  DIMENSION (kjpindex,nvm)      :: vbeta3save           !! Beta for Transpiration (unitless)
+!    REAL(r_std),SAVE, ALLOCATABLE,  DIMENSION (:,:)      :: vbeta3save           !! Beta for Transpiration (unitless)
+!!!    !$OMP THREADPRIVATE(vbeta3save)    
+    REAL(r_std), DIMENSION(kjpindex, nvm)                    :: coupled_lai
+    REAL(r_std), DIMENSION(kjpindex, nvm)                    :: total_lai 
+    !
+    REAL(r_Std),DIMENSION (kjpindex,nvm,nlevels_tot)         :: gs_store
+    REAL(r_Std),DIMENSION (kjpindex,nvm)                     :: gs_column_total
+    REAL(r_Std),DIMENSION (kjpindex,nvm)                     :: gstot_store
+    !
+    !
+    REAL(r_std),DIMENSION(kjpindex,nvm,nlevels_tot)          :: Abs_light        !! fraction of absorbed light within each layer (just to check)
+    REAL(r_std),DIMENSION(kjpindex,nvm)                      :: Abs_light_can    !! fraction of absorbed light within the canopy (just to check)  
+    REAL(r_std),DIMENSION (kjpindex,nvm)                     :: vcmax            !! maximum rate of carboxylation 
+                                                                                 !! @tex ($\mu mol CO2 m^{-2} s^{-1}$) @endtex
+    INTEGER(i_std)                                           :: ji, jv, ilev     !! indices (unitless)
+    INTEGER(i_std)                                           :: limit_photo      !! indices (unitless)
+    REAL(r_std), DIMENSION(kjpindex)                         :: leaf_ci_lowest   !! intercellular CO2 concentration at the lowest 
+                                                                                 !! LAI level
+                                                                                 !! @tex ($\mu mol mol^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex)                         :: zqsvegrap        !! relative water quantity in the water 
+                                                                                 !! interception reservoir (0-1,unitless) 
+    REAL(r_std)                                              :: speed            !! wind speed @tex ($m s^{-1}$) @endtex
+    ! Assimilation
+    LOGICAL, DIMENSION(kjpindex)                             :: assimilate       !! where assimilation is to be calculated 
+                                                                                 !! (unitless) 
+    INTEGER(i_std)                                           :: nia,inia,nina    !! counter/indices (unitless)
+    INTEGER(i_std)                                           :: inina,iainia     !! counter/indices (unitless)
+    INTEGER(i_std), DIMENSION(kjpindex)                      :: index_assi       !! indices (unitless)
+    INTEGER(i_std), DIMENSION(kjpindex)                      :: index_non_assi   !! indices (unitless)
+    REAL(r_std), DIMENSION(kjpindex)                         :: vc2              !! rate of carboxylation (at a specific LAI level) 
+                                                                                 !! @tex ($\mu mol CO2 m^{-2} s^{-1}$) @endtex 
+
+    REAL(r_std), DIMENSION(kjpindex)                         :: vj2              !! rate of Rubisco regeneration (at a specific LAI 
+                                                                                 !! level) @tex ($\mu mol e- m^{-2} s^{-1}$) @endtex 
+    REAL(r_std), DIMENSION(kjpindex)                         :: assimi           !! assimilation (at a specific LAI level) 
+                                                                                 !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+                                                                                 !! (temporary variables)
+    REAL(r_std), DIMENSION(kjpindex)                         :: gstop            !! stomatal conductance to H2O at topmost level 
+                                                                                 !! @tex ($m s^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex)                         :: gs               !! stomatal conductance to CO2 
+                                                                                 !! @tex ($\mol m^{-2} s^{-1}$) @endtex
+
+
+    REAL(r_std), DIMENSION(kjpindex)                         :: gamma_star       !! CO2 compensation point (ppm)
+                                                                                 !! @tex ($\mu mol mol^{-1}$) @endtex
+
+    REAL(r_std), DIMENSION(kjpindex)                         :: air_relhum       !! air relative humidity at 2m 
+                                                                                 !! @tex ($kg kg^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex)                         :: VPD              !! Vapor Pressure Deficit (kPa)
+    REAL(r_std), DIMENSION(kjpindex)                         :: water_lim        !! water limitation factor (0-1,unitless)
+
+    REAL(r_std), DIMENSION(kjpindex)                         :: gstot            !! total stomatal conductance to H2O
+                                                                                 !! Final unit is
+                                                                                 !! @tex ($m s^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex)                         :: assimtot         !! total assimilation 
+                                                                                 !! @tex ($\mu mol CO2 m^{-2} s^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex)                         :: Rdtot            !! Total Day respiration (respiratory CO2 release other than by photorespiration) (mumol CO2 mâ2 sâ1) 
+    REAL(r_std), DIMENSION(kjpindex)                         :: gs_top           !! leaf stomatal conductance to H2O across all top levels
+                                                                                 !! @tex ($\mol H2O m^{-2} s^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex)                         :: qsatt                               !! surface saturated humidity at 2m (??) 
+                                                                                 !! @tex ($g g^{-1}$) @endtex
+                                                                                 !! levels (0-1,unitless)
+    REAL(r_std), DIMENSION(kjpindex)                         :: T_Vcmax          !! Temperature dependance of Vcmax (unitless)
+    REAL(r_std), DIMENSION(kjpindex)                         :: S_Vcmax_acclim_temp                 !! Entropy term for Vcmax 
+                                                                                 !! accounting for acclimation to temperature (J K-1 mol-1)
+    REAL(r_std), DIMENSION(kjpindex)                         :: T_Jmax           !! Temperature dependance of Jmax
+    REAL(r_std), DIMENSION(kjpindex)                         :: S_Jmax_acclim_temp                  !! Entropy term for Jmax 
+                                                                                 !! accounting for acclimation to temperature (J K-1 mol-1)
+    REAL(r_std), DIMENSION(kjpindex)                         :: T_Rd             !! Temperature dependance of Rd (unitless)
+    REAL(r_std), DIMENSION(kjpindex)                         :: T_Kmc            !! Temperature dependance of KmC (unitless)
+    REAL(r_std), DIMENSION(kjpindex)                         :: T_KmO            !! Temperature dependance of KmO (unitless)
+    REAL(r_std), DIMENSION(kjpindex)                         :: T_gamma_star     !! Temperature dependance of gamma_star (unitless)    
+    REAL(r_std), DIMENSION(kjpindex)                         :: vc               !! Maximum rate of Rubisco activity-limited carboxylation (mumol CO2 mâ2 sâ1)
+    REAL(r_std), DIMENSION(kjpindex)                         :: vj               !! Maximum rate of e- transport under saturated light (mumol CO2 mâ2 sâ1)
+    REAL(r_std), DIMENSION(kjpindex)                         :: Rd               !! Day respiration (respiratory CO2 release other than by photorespiration) (mumol CO2 mâ2 sâ1)
+    REAL(r_std), DIMENSION(kjpindex)                         :: Kmc              !! MichaelisâMenten constant of Rubisco for CO2 (mubar)
+    REAL(r_std), DIMENSION(kjpindex)                         :: KmO              !! MichaelisâMenten constant of Rubisco for O2 (mubar)
+    REAL(r_std), DIMENSION(kjpindex)                         :: gb               !! Boundary-layer conductance (mol mâ2 sâ1 barâ1)
+    REAL(r_std), DIMENSION(kjpindex)                         :: fvpd             !! Factor for describing the effect of leaf-to-air vapour difference on gs (-)
+    REAL(r_std), DIMENSION(kjpindex)                         :: low_gamma_star   !! Half of the reciprocal of Sc/o (bar bar-1)
+    REAL(r_std)                                              :: N_Vcmax          !! Nitrogen level dependance of Vcmacx and Jmax 
+    REAL(r_std)                                              :: fcyc             !! Fraction of electrons at PSI that follow cyclic transport around PSI (-)
+    REAL(r_std)                                              :: z                !! A lumped parameter (see Yin et al. 2009) ( mol mol-1)                          
+    REAL(r_std)                                              :: Rm               !! Day respiration in the mesophyll (umol CO2 mâ2 sâ1)
+    REAL(r_std)                                              :: Cs_star          !! Cs -based CO2 compensation point in the absence of Rd (ubar)
+    REAL(r_std), DIMENSION(kjpindex)                         :: Iabs             !! Photon flux density absorbed by leaf photosynthetic pigments (umol photon mâ2 sâ1)
+    REAL(r_std), DIMENSION(kjpindex)                         :: Jmax             !! Maximum value of J under saturated light (umol eâ mâ2 sâ1)
+    REAL(r_std), DIMENSION(kjpindex)                         :: JJ               !! Rate of eâ transport (umol eâ mâ2 sâ1)
+    REAL(r_std)                                              :: J2               !! Rate of all eâ transport through PSII (umol eâ mâ2 sâ1)
+    REAL(r_std)                                              :: VpJ2             !! eâ transport-limited PEP carboxylation rate (umol CO2 mâ2 sâ1)
+    REAL(r_std)                                              :: A_1, A_3         !! Lowest First and third roots of the analytical solution for a general 
+                                                                                 !! cubic equation (see Appendix A of Yin et al. 2009) (umol CO2 mâ2 sâ1)
+    REAL(r_std)                                              :: A_1_tmp, A_3_tmp            !! Temporary First and third roots of the analytical solution 
+                                                                                            !! for a general cubic equation (see Appendix A of Yin et al. 2009) (umol CO2 mâ2 sâ1)
+    REAL(r_std)                                              :: Obs                         !! Bundle-sheath oxygen partial pressure (ubar)
+    REAL(r_std)                                              :: Cc                          !! Chloroplast CO2 partial pressure (ubar)
+    REAL(r_std)                                              :: ci_star                     !! Ci -based CO2 compensation point in the absence of Rd (ubar)        
+    REAL(r_std)                                              :: a,b,c,d,m,f,j,g,h,i,l,p,q,r !! Variables used for solving the cubic equation (see Yin et al. (2009))
+    REAL(r_std)                                              :: QQ,UU,PSI,x1,x2,x3          !! Variables used for solving the cubic equation (see Yin et al. (2009))
+    REAL(r_std)                                              :: cresist                     !! coefficient for resistances (??)
+    REAL(r_std)                                              :: lai_min                     !! mininum lai to calculate photosynthesis       
+
+    LOGICAL,DIMENSION(kjpindex,nlevels_tot)                  :: top_level                   !! A flag to see if a given level is considered
+                                                                                            !! a "top" level or not.  Must be done this way
+                                                                                            !! because there could be several "top" levels.
+    REAL(r_std)                                              :: totlai_top                  !! The sum of the LAI in all the levels that we
+                                                                                            !! declare as the "top".
+    INTEGER(i_std)                                           :: lev_count                   !! How many levels we have already taken for
+                                                                                            !! the "top"
+
+! @defgroup Photosynthesis Photosynthesis
+! @{   
+    ! 1. Preliminary calculations\n
+    REAL(r_std),DIMENSION (kjpindex,nvm)                     :: rveget_min                  !! Minimal Surface resistance of vegetation
+    REAL(r_std),DIMENSION (kjpindex,nvm,nlevels_tot)     &
+                                                             :: light_tran_to_level         !! Cumulative amount of light transmitted to a given level
+    LOGICAL,DIMENSION (kjpindex)                             :: lskip                       !! A flag to indicate we've hit an unusual
+                                                                                            !! case were we may have numerical instability.
+
+    INTEGER                                                  :: ic, jc, kc
+
+    INTEGER                                                  :: ipts
+    LOGICAL                                                  :: llight
+    LOGICAL                                                  :: llai
+    INTEGER,SAVE                                             :: istep=0, counter=0
+!_ ================================================================================================================================
+
+
+! IF (.NOT. ALLOCATED(vbeta3save)) ALLOCATE (vbeta3save(kjpindex,nvm))
+! IF (.NOT. ALLOCATED(vbeta3save)) ALLOCATE (vbeta3save(kjpindex,nvm),stat=ier)
+ !   IF (ier /= 0) CALL ipslerr_p(3,'hydrol_arch','Problem in allocate of variable iniok','','')
+
+
+
+    !++++++ Useful debugging info ++++++ 
+    IF(ld_albedo .OR. ld_photo)THEN 
+       WRITE(numout,*) 'Absorbed light in diffuco. ',test_grid,test_pft 
+       DO ilev=nlevels_tot,1,-1 
+          WRITE(numout,'(I5,10F20.10)') & 
+               ilev, Isotrop_Abs_Tot_p(test_grid,test_pft,ilev),& 
+               Isotrop_Tran_Tot_p(test_grid,test_pft,ilev),& 
+               lai_per_level(test_grid,test_pft,ilev) 
+       ENDDO
+    ENDIF
+    !++++++++++++
+
+    gs_column_total = 0.0d0
+    gs_distribution = 0.0d0
+    gs_diffuco_output = 0.0d0
+    gstot_frac = 0.0d0
+    gstot_component = 0.d0
+    gstot_store = 0.0d0
+    gs_store(:,:,:)=zero
+    !
+    !
+    ! 1. Photosynthesis parameters
+    !
+    vcmax(:,:) = assim_param(:,:,ivcmax)
+    !
+    ! @addtogroup Photosynthesis
+    ! @{   
+    ! 1.3 Estimate relative humidity of air (for calculation of the stomatal conductance).\n
+    !! \latexonly
+    !! \input{diffuco_trans_co2_1.3.tex}
+    !! \endlatexonly
+    ! @}
+    !
+    CALL qsatcalc (kjpindex, temp_sol, pb, qsatt)
+    air_relhum(:) = &
+      ( qsurf(:) * pb(:) / (Tetens_1+qsurf(:)* Tetens_2) ) / &
+      ( qsatt(:)*pb(:) / (Tetens_1+qsatt(:)*Tetens_2 ) )
+
+
+    VPD(:) = ( qsatt(:)*pb(:) / (Tetens_1+qsatt(:)*Tetens_2 ) ) &
+         - ( qsurf(:) * pb(:) / (Tetens_1+qsurf(:)* Tetens_2) )
+    ! VPD is needed in kPa
+    ! We limit the impact of VPD in the range of [0:6] kPa
+    ! This seems to be the typical range of values
+    ! that the vapor pressure difference can take, although
+    ! there is a paper by Mott and Parkhurst, Plant, Cell & Environment,
+    ! Vol. 14, pp. 509--519 (1991) which gives a value of 15 kPa.
+    VPD(:) = MAX(zero,MIN(VPD(:)/10.,6.))
+   ! VPD(:) = VPD(:)*1.038291 + 0.1315685
+    VPD(:) = VPD(:)*vpd_k1+vpd_b1
+    ! @endcodeinc
+    !
+    !
+    ! 2. beta coefficient for vegetation transpiration
+    !
+    rstruct(:,1) = rstruct_const(1)
+    rveget(:,:) = undef_sechiba
+    rveget_min(:,:) = undef_sechiba
+    !
+    vbeta3(:,:) = zero
+    vbeta3pot(:,:) = zero
+    gsmean(:,:) = zero
+    gpp(:,:) = zero
+    light_tran_to_level(:,:,:)=un
+    !
+    cimean(:,1) = Ca(:)
+!    vbeta3save(:,:)=1000    
+
+!
+    ! @addtogroup Photosynthesis
+    ! @{   
+    ! 2. Loop over vegetation types\n
+    ! @} 
+    !
+    DO jv = 2,nvm
+      !
+      ! @addtogroup Photosynthesis
+      ! @{   
+      !
+      ! 2.1 Initializations\n
+      !! \latexonly
+      !! \input{diffuco_trans_co2_2.1.tex}
+      !! \endlatexonly
+      ! @}      
+      !
+      ! beta coefficient for vegetation transpiration
+      !
+      rstruct(:,jv) = rstruct_const(jv)
+      cimean(:,jv) = Ca(:)
+ 
+      IF (downregulation_co2) THEN
+         vcmax(:,jv) = assim_param(:,jv,ivcmax)*&
+              (un-downregulation_co2_coeff(jv)*&
+              log(Ca(:)/downregulation_co2_baselevel))
+      ELSE
+         vcmax(:,jv) = assim_param(:,jv,ivcmax)
+      ENDIF
+
+      !
+      !! mask that contains points where there is photosynthesis
+      !! For the sake of vectorisation [DISPENSABLE], computations are done only for convenient points.
+      !! nia is the number of points where the assimilation is calculated and nina the number of points where photosynthesis is not
+      !! calculated (based on criteria on minimum or maximum values on LAI, vegetation fraction, shortwave incoming radiation, 
+      !! temperature and relative humidity).
+      !! For the points where assimilation is not calculated, variables are initialized to specific values. 
+      !! The assimilate(kjpindex) array contains the logical value (TRUE/FALSE) relative to this photosynthesis calculation.
+      !! The index_assi(kjpindex) array indexes the nia points with assimilation, whereas the index_no_assi(kjpindex) array indexes
+      !! the nina points with no assimilation.
+      !          
+      ! set minimum lai value to test if photosynthesis should be calculated
+      ! 0.0001 is abitrary
+      ! could be externalised 
+      lai_min = 0.0001
+      !
+      nia=0
+      nina=0
+      index_assi=0
+      index_non_assi=0
+      !
+      DO ji=1,kjpindex
+
+         IF(veget_max(ji,jv) == zero)THEN
+            ! this vegetation type is not present, so no reason to do the 
+            ! calculation
+            CYCLE
+         ENDIF
+
+         !
+         ! This is tricky.  We need a certain amount of LAI to have photosynthesis.
+         ! However, we divide our canopy up into certain levels, so even if we
+         ! have a total amount that is sufficient, there might not be enough
+         ! in any particular layer.  So we check each layer to see if there
+         ! is one that has enough to give a non-zero photosynthesis.  In
+         ! the worst-case scenario (small LAI in every other level), this becomes 
+         ! our top level for the gs calculation.  If gs_top_level is zero below,
+         ! we have a divide by zero issue.
+         llai=.FALSE.
+         DO ilev=1,nlevels_tot
+            IF(lai_per_level(ji,jv,ilev) .GT. lai_min) llai=.TRUE.
+         ENDDO
+
+         IF ( llai .AND. &
+              ( veget_max(ji,jv) .GT. min_sechiba ) ) THEN
+            
+            ! Here we need to do something different than in the previous model.
+            ! We explicitly need to check for absorbed light.  This occurs
+            ! because our albedo in the two stream model is a function
+            ! of the solar angle.  If the sun has set, we have no
+            ! light, and therefore we cannot have photosynthesis.
+            llight=.FALSE.
+            DO ilev=1,nlevels_tot
+               IF(Isotrop_Abs_Tot_p(ji,jv,ilev) .GT. min_sechiba) llight=.TRUE.
+            ENDDO
+            IF ( ( swdown(ji) .GT. min_sechiba )   .AND. &
+                 ( temp_growth(ji) .GT. tphoto_min(jv) ) .AND. &
+                 llight .AND. &
+                 ( temp_growth(ji) .LT. tphoto_max(jv) )) 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
+      !
+
+      IF(ld_photo .AND. jv == test_pft)THEN
+         WRITE(numout,*) 'jv: ',jv
+         WRITE(numout,*) 'test_grid: ',test_grid
+         WRITE(numout,*) 'llai, veget_max: ',llai,veget_max(test_grid,jv)
+         WRITE(numout,*) 'temp_growth: ',temp_growth(test_grid)
+         WRITE(numout,*) 'tphoto_min: ',tphoto_min(jv)
+         WRITE(numout,*) 'tphoto_max: ',tphoto_max(jv)
+         WRITE(numout,*) 'swdown: ',swdown(test_grid)
+         WRITE(numout,*) 'index_non_assi(:): ',index_non_assi(test_grid)
+         WRITE(numout,*) 'index_assi(:): ',index_assi(test_grid)
+         WRITE(numout,*) 'nia: ',nia
+      ENDIF
+
+      top_level(:,:)=.FALSE.
+      gstot(:) = zero
+      assimtot(:) = zero
+      Rdtot(:)=zero
+      gs_top(:) = zero
+      lskip(:)=.FALSE.
+      !
+      zqsvegrap(:) = zero
+      WHERE (qsintmax(:,jv) .GT. min_sechiba)
+         !! relative water quantity in the water interception reservoir
+         zqsvegrap(:) = MAX(zero, qsintveg(:,jv) / qsintmax(:,jv))
+      ENDWHERE
+      
+      !! Calculate the water limitation factor that restricts Vcmax when hydrol_arch is turned off.
+      !  If hydrol_architecture is used, VCmax is not controled but instead there is a control on
+      !  stomatal conductance
+      IF(control%ok_hydrol_arch) THEN
+
+WRITE(*,*) "vbeta3save", vbeta3save(:,jv), jv
+         WHERE ( assimilate(:) .AND. (vbeta3save(:,jv) .GT. min_sechiba))
+            water_lim(:) = un
+         ELSEWHERE
+            water_lim(:) = zero
+         ENDWHERE
+  
+     ELSE
+         WHERE ( assimilate(:) )
+            water_lim(:) = MAX( min_sechiba, MIN( vegstress(:,jv)/0.5, un ))
+         ELSEWHERE
+            water_lim(:) = zero
+         ENDWHERE
+      ENDIF
+
+      ! give a default value of ci for all pixel that do not assimilate
+      DO ilev=1,nlevels_tot
+         DO inina=1,nina
+            leaf_ci(index_non_assi(inina),jv,ilev) = Ca(index_non_assi(inina)) 
+         ENDDO
+      ENDDO
+      !
+      !
+      ! Here is the calculation of assimilation and stomatal conductance
+      ! based on the work of Farquahr, von Caemmerer and Berry (FvCB model) 
+      ! as described in Yin et al. 2009
+      ! Yin et al. developed a extended version of the FvCB model for C4 plants
+      ! and proposed an analytical solution for both photosynthesis pathways (C3 and C4)
+      ! Photosynthetic parameters used are those reported in Yin et al. 
+      ! Except For Vcmax25, relationships between Vcmax25 and Jmax25 for which we use 
+      ! Medlyn et al. (2002) and Kattge & Knorr (2007)
+      ! Because these 2 references do not consider mesophyll conductance, we neglect this term
+      ! in the formulations developed by Yin et al. 
+      ! Consequently, gm (the mesophyll conductance) tends to the infinite
+      ! This is of importance because as stated by Kattge & Knorr and Medlyn et al.,
+      ! values of Vcmax and Jmax derived with different model parametrizations are not 
+      ! directly comparable and the published values of Vcmax and Jmax had to be standardized
+      ! to one consistent formulation and parametrization
+
+      ! See eq. 6 of Yin et al. (2009)
+      ! Parametrization of Medlyn et al. (2002) - from Bernacchi et al. (2001)
+      T_KmC(:)        = Arrhenius(kjpindex,temp_sol,298.,E_KmC(jv))
+      T_KmO(:)        = Arrhenius(kjpindex,temp_sol,298.,E_KmO(jv))
+      T_gamma_star(:) = Arrhenius(kjpindex,temp_sol,298.,E_gamma_star(jv))
+
+
+      ! Parametrization of Yin et al. (2009) - from Bernacchi et al. (2001)
+      T_Rd(:)         = Arrhenius(kjpindex,temp_sol,298.,E_Rd(jv))
+
+
+      ! For C3 plants, we assume that the Entropy term for Vcmax and Jmax 
+      ! acclimates to temperature as shown by Kattge & Knorr (2007) - Eq. 9 and 10
+      ! and that Jmax and Vcmax respond to temperature following a modified Arrhenius function
+      ! (with a decrease of these parameters for high temperature) as in Medlyn et al. (2002) 
+      ! and Kattge & Knorr (2007).
+      ! In Yin et al. (2009), temperature dependance to Vcmax is based only on a Arrhenius function
+      ! Concerning this apparent unconsistency, have a look to the section 'Limitation of 
+      ! Photosynthesis by gm' of Bernacchi (2002) that may provide an explanation
+
+      ! Growth temperature tested by Kattge & Knorr range from 11 to 35Â°C
+      ! So, we limit the relationship between these lower and upper limits
+      S_Jmax_acclim_temp(:) = aSJ(jv) + bSJ(jv) * MAX(11., MIN(temp_growth(:),35.))      
+      T_Jmax(:)  = Arrhenius_modified(kjpindex,temp_sol,298.,E_Jmax(jv),D_Jmax(jv),S_Jmax_acclim_temp)
+
+      S_Vcmax_acclim_temp(:) = aSV(jv) + bSV(jv) * MAX(11., MIN(temp_growth(:),35.))   
+      T_Vcmax(:) = Arrhenius_modified(kjpindex,temp_sol,298.,E_Vcmax(jv),D_Vcmax(jv),S_Vcmax_acclim_temp)
+
+      vc(:) = vcmax(:,jv) * T_Vcmax(:)
+      
+      !DO ji=1,kjpindex
+
+         !write(*,*) 'temp_sol',temp_sol(ji)
+         !write(*,*) 'temp_growth',temp_growth(ji)
+         !write(*,*) 'T_Vcmax',T_Vcmax(ji)
+         !write(*,*) 'vcmax_',vcmax(ji,jv)
+         !write(*,*) 'vc_',vc(ji)
+
+      !ENDDO
+
+      ! As shown by Kattge & Knorr (2007), we make use
+      ! of Jmax25/Vcmax25 ratio (rJV) that acclimates to temperature for C3 plants
+      ! rJV is written as a function of the growth temperature
+      ! rJV = arJV + brJV * T_month 
+      ! See eq. 10 of Kattge & Knorr (2007)
+      ! and Table 3 for Values of arJV anf brJV 
+      ! Growth temperature is monthly temperature (expressed in Â°C) - See first paragraph of
+      ! section Methods/Data of Kattge & Knorr
+      vj(:) = ( arJV(jv) + brJV(jv) *  MAX(11., MIN(temp_growth(:),35.)) ) * vcmax(:,jv) * T_Jmax(:)
+      !
+      ! @endcodeinc
+      !
+      KmC(:)=KmC25(jv)*T_KmC(:)
+      KmO(:)=KmO25(jv)*T_KmO(:)
+      gamma_star(:) = gamma_star25(jv)*T_gamma_star(:)
+      ! low_gamma_star is defined by Yin et al. (2009)
+      ! as the half of the reciprocal of Sco - See Table 2
+      ! We derive its value from Equation 7 of Yin et al. (2009)
+      ! assuming a constant O2 concentration (Oi)
+      low_gamma_star(:) = gamma_star(:)/Oi
+      ! VPD expressed in kPa
+      !fvpd(:) = 1. / ( 1. / (a1(jv) - b1(jv) * VPD(:)) - 1. )
+      DO ji=1,kjpindex
+         IF (VPD(ji) .LT. 0.35) THEN
+                 CALL getin_p('newA1',a1)
+                 CALL getin_p('newB1',b1)
+                 fvpd(ji) = 1. / ( 1. / (a1(jv) - b1(jv) * VPD(ji)) - 1. )
+         ELSE
+                 CALL getin_p('A1',a1)
+                 CALL getin_p('B1',b1)
+                 fvpd(ji) = 1. / ( 1. / (a1(jv) - b1(jv) * VPD(ji)) - 1. )
+         ENDIF
+         !write(*,*) 'vpdvpd_yyt2',VPD(ji)
+         !write(*,*) 'fvpd_yyt2',fvpd(ji)
+      ENDDO 
+      !write(*,*) 'vpdvpd',VPD(:)
+     ! write(*,*) 'cons_a1',a1(jv)
+     ! write(*,*) 'cons_b1',b1(jv) 
+      !leaf boundary layer conductance
+      gb(:) = (1.0_r_std /25.0_r_std)/(22.4_r_std *temp_sol(:)/273._r_std/1000._r_std) 
+      !
+      !
+      ! @addtogroup Photosynthesis
+      ! @{   
+      !
+      ! 2.4 Loop over LAI levels to estimate assimilation and conductance\n
+      ! @}           
+      !
+      IF (nia .GT. 0) THEN
+         assim_loop:DO inia=1,nia
+            !
+            iainia=index_assi(inia)
+
+            !
+            ! Find the top layer that still contains lai.  We have also
+            ! added a check in here to make sure this layer has absorbed
+            ! light.  If there is no absorbed light, we will not calculate
+            ! stomatal conductance for the top level, which means gstop
+            ! will be zero later and we'll crash when we divide by it.
+            ! Include a warning so we know how often this happens.
+            ! The old system of chosing just one top level caused some bad results
+            ! in the transpir, evidently due to the calculation of vbeta3 being
+            ! too low due to too low of LAI in the top level.  Therefore, we are
+            ! now going to take several top levels in an effort to make sure
+            ! we have enough LAI.  We aim for an arbitrary amount of 0.1 or
+            ! the top three levels.  This has not been rigoursly tested, but it
+            ! is theoretically justified by the fact that if the LAI of the top
+            ! level is very low, other leaves will be getting a lot of sun and
+            ! well-exposed to the atmosphere, and therefore contribute equal
+            ! to the resistence of the vegetation.
+            totlai_top=zero
+            lev_count=0
+            !   
+            DO ilev=nlevels_tot, 1, -1
+               IF(lai_per_level(iainia,jv,ilev) .GT. lai_min)THEN
+                  IF(Isotrop_Abs_Tot_p(iainia,jv,ilev) .GT. min_sechiba)THEN
+                     IF(totlai_top .LT. lai_top(jv) .AND. lev_count .LT. nlev_top)THEN
+                        lev_count=lev_count+1
+                        top_level(iainia,ilev)=.TRUE.
+                        totlai_top=totlai_top+lai_per_level(iainia,jv,ilev)
+                     ELSE
+                        ! We have enough levels now.
+                        !WRITE(numout,*) 'Top levels ',totlai_top,lev_count
+                        EXIT
+                     ENDIF
+                  ELSE
+                     IF(ld_warn)THEN
+                        WRITE(numout,*) 'WARNING: Found a level with LAI, ' // &
+                             'but no absorbed light.'
+                        WRITE(numout,*) 'WARNING: iainia,jv,ilev, ',iainia,jv,ilev
+                        WRITE(numout,*) 'WARNING: Isotrop_Abs_Tot_p(iainia,jv,ilev),' //&
+                             'lai_per_level(iainia,jv,ilev), ',iainia,jv,ilev
+                     ENDIF
+                  ENDIF
+               ENDIF
+            ENDDO
+            IF(totlai_top .LT. min_sechiba)THEN
+               ! There seem to be some fringe cases where this happens, usually
+               ! at sunrise or sunset with low LAI levels.  Instead of stopping
+               ! here, I'm going to issue a warning.  If this case happens,
+               ! we produce no GPP, but we're not going to crash.  We need to
+               ! be careful in one of the loops below, since a stomatal 
+               ! conductance of zero will cause a crash.
+                IF(ld_warn)THEN
+                   WRITE(numout,*) 'WARNING: Did not find a level with LAI in diffuco!'
+                   WRITE(numout,*) 'WARNING: iainia,ivm: ',iainia,jv
+                ENDIF
+               assimtot(iainia) = zero
+               Rdtot(iainia) = zero
+               gstot(iainia) = zero
+               lskip(iainia)=.TRUE.
+               CYCLE assim_loop
+            ENDIF
+
+            ! We need to know how much is transmitted to this level
+            ! from the top of the canopy, since this aboslute number
+            ! is what is actually used in the photosyntheis.  Right now
+            ! Isotrop_Tran_Tot_p and Isotropic_Abs_Tot_p are the 
+            ! relative quantities transmitted through and absorbed
+            ! by the layer.
+            DO ilev = nlevels_tot-1,1,-1
+               light_tran_to_level(iainia,jv,ilev)=light_tran_to_level(iainia,jv,ilev+1)*Isotrop_Tran_Tot_p(iainia,jv,ilev+1)
+            ENDDO
+            IF(ld_photo .AND. jv == test_pft .AND. iainia == test_grid)THEN
+               WRITE(numout,*) 'Absolute transmitted light to each level',jv,iainia
+               DO ilev = nlevels_tot,1,-1
+                  WRITE(numout,*) ilev,light_tran_to_level(iainia,jv,ilev)
+               ENDDO
+            ENDIF
+
+            DO ilev = 1, nlevels_tot
+               
+               IF (Isotrop_Abs_Tot_p(iainia,jv,ilev) .GT. min_sechiba) THEN
+
+                  IF(lai_per_level(iainia,jv,ilev) .LE. min_sechiba)THEN
+                     ! This is not necessarily a problem.  LAI is updated in slowproc, while
+                     ! absorbed light is updated in condveg, which is called after diffuco.
+                     ! So we might be one timestep off.  It generally should be at night,
+                     ! though, so there is no absorbed light.  If this persists, that
+                     ! is a real problem.
+                     IF(ld_warn)THEN
+                        WRITE(numout,*) 'WARNING: We have absorbed light but no LAI ' // &
+                             'in this level. Skipping.'
+                        WRITE(numout,'(A,3I8)') 'WARNING: iainia,jv,ilev: ',iainia,jv,ilev
+                        WRITE(numout,'(A,2F20.10)') 'WARNING: Isotrop_Abs_Tot_p(iainia,jv,ilev), ' // &
+                             'lai_per_level(iainia,jv,ilev): ',&
+                             Isotrop_Abs_Tot_p(iainia,jv,ilev), lai_per_level(iainia,jv,ilev)
+                     ENDIF
+                     CYCLE
+                  ENDIF
+                  !
+                  ! nitrogen is scaled according to the transmitted light
+                  ! before the caclulation was (1 - exp(lai)) we replaced
+                  ! it by the transmitted light calculated by the 2stream
+                  ! model, maybe ( un - Isotrop_Tran_Tot_p(iainia,jv,ilev) )
+                  ! could be replaced by the directly calculated absorbed
+                  ! light Isotrop_Abs_Tot_p(iainia,jv,ilev).
+                  ! Notice that light in the old code was the cumulative light transmitted to
+                  ! the layer, while Isotrop_Tran_Tot_p is the relative light transmitted
+                  ! through the layer.  Therefore, we use a different variable.
+                  !
+!                     N_Vcmax = ( un - .7_r_std * ( un - Isotrop_Tran_Tot_p(iainia,jv,ilev) ) )
+                  N_Vcmax = ( un - .7_r_std * ( un - light_tran_to_level(iainia,jv,ilev) ) )
+              
+                  
+                  
+                  !When hydrol_arch is turned on there is no water stress on the vcmax and photosynthesis
+                  !is only restricted by stomatal closure when transpiration is higher than the water supply
+                  !to the leaves as calculated in hydrol_arch. This more consistent with the substantial 
+                  !consensus in plant physiology that the main restriction of photosynthesis during drought
+                  !occurs through diffusion limitation rather than photochemical or biochemical failure
+                  !(Flexas et al. 2006). Effects of drought stress on respiration are less well known: 
+                  !increases, decreases and no change have been found. For now there is no effect of drought
+                  !stress on dark respiration when hydrol_arch is used.                    
+                  vc2(iainia) = vc(iainia) * N_Vcmax * water_lim(iainia)
+                  vj2(iainia) = vj(iainia) * N_Vcmax * water_lim(iainia)
+                     
+                  ! see Comment in legend of Fig. 6 of Yin et al. (2009)
+                  ! Rd25 is assumed to equal 0.01 Vcmax25 
+                  Rd(iainia) = vcmax(iainia,jv) * N_Vcmax * 0.01 * T_Rd(iainia)* water_lim(iainia)
+
+
+                  Iabs(iainia)=swdown(iainia)*W_to_mmol*RG_to_PAR*&
+                       Isotrop_Abs_Tot_p(iainia,jv,ilev)*light_tran_to_level(iainia,jv,ilev) &
+                       / lai_per_level(iainia,jv,ilev)
+
+                  ! If we have a very dense canopy, the lower levels might
+                  ! get almost no light.  If the light is close to zero, it
+                  ! causes a numerical problem below, as x1 will be zero.  Of
+                  ! course, if the absorbed light is really small photosynthesis will
+                  ! not happen, so we can just skip this level.  This number is 
+                  ! fairly arbitrary, but it should be as small as possible.
+                  IF(Iabs(iainia) .LT. 1e-12)CYCLE
+
+                  ! eq. 4 of Yin et al (2009)
+                  ! Note that Iabs is very sensitive to the number of layers used
+                  ! in the photosynthesis module and to the canopy structure. The first
+                  ! sensitivity is related to none-linearities to the light conditions
+                  ! and is an numerical issue. The sensitivity to the canopy structure
+                  ! is a wanted behavior (that's why canopy structure was implemented)
+                  ! but makes a substantial difference for the total GPP in tropical 
+                  ! compared to temperate forests. An easy way to prescribe a different
+                  ! canopy structure is by changing the range of the prescribed height.
+                  ! The parameter ::alpha_LL describes the relationship between Jmax and
+                  ! light saturation. It is thought to depend on the amount of chlorophyl
+                  ! in the leaves which in turn depends on the N-content. For the moment
+                  ! we use a prescribed value. After the introduction of the structured 
+                  ! canopy we noticed an important sensitivity of GPP to this parameter
+                  ! which may indicate that a substantial part of our canopy is under
+                  ! light saturation. 
+                  Jmax(iainia)=vj2(iainia)
+                  JJ(iainia) = ( alpha_LL(jv) * Iabs(iainia) + Jmax(iainia) - &
+                       sqrt((alpha_LL(jv) * Iabs(iainia) + Jmax(iainia) )**2. &
+                       - 4 * theta(jv) * Jmax(iainia) * alpha_LL(jv) * &
+                       Iabs(iainia)) ) &
+                       / ( 2 * theta(jv))
+
+                  
+                 IF (ld_photo .AND. test_pft == jv) THEN
+                     WRITE(numout,*) '*************************'
+                     WRITE(numout,*) 'jv,ilev: ',jv,ilev
+                     WRITE(numout,*) 'JJ(iainia),Jmax(iainia),Iabs(iainia),Rd(iainia): ',&
+                          JJ(iainia),Jmax(iainia),Iabs(iainia),Rd(iainia)
+                     WRITE(numout,*) 'vj2(iainia),vc2(iainia),N_Vcmax:',&
+                          vj2(iainia),vc2(iainia),N_Vcmax
+                     WRITE(numout,*) 'Isotrop_Abs_Tot_p(iainia,jv,ilev),Isotrop_Tran_Tot_p(iainia,jv,ilev):',&
+                          Isotrop_Abs_Tot_p(iainia,jv,ilev),Isotrop_Tran_Tot_p(iainia,jv,ilev)
+                     
+                     WRITE(numout,*) 'water_lim(iainia),T_Rd(iainia):',water_lim(iainia),T_Rd(iainia)
+                     WRITE(numout,*) 'vc(iainia),vj(iainia), vcmax(iainia,jv):',&
+                          vc(iainia),vj(iainia),vcmax(iainia,jv)
+                     WRITE(numout,*) '*************************'
+                 ENDIF
+
+                 IF ( is_c4(jv) )  THEN
+                     !
+                     ! @addtogroup Photosynthesis
+                     ! @{   
+                     !
+                     ! 2.4.2 Assimilation for C4 plants (Collatz et al., 1992)\n
+                     !! \latexonly
+                     !! \input{diffuco_trans_co2_2.4.2.tex}
+                     !! \endlatexonly
+                     ! @}           
+                     !
+                     !
+                     !
+                     ! Analytical resolution of the Assimilation based Yin et al. (2009)
+                     ! Eq. 28 of Yin et al. (2009)
+                     fcyc= 1. - ( 4.*(1.-fpsir(jv))*(1.+fQ(jv)) + 3.*h_protons(jv)*fpseudo(jv) ) / &
+                          ( 3.*h_protons(jv) - 4.*(1.-fpsir(jv)))
+
+                     ! See paragraph after eq. (20b) of Yin et al.
+                     Rm=Rd(iainia)/2.
+
+                     ! We assume that cs_star equals ci_star (see Comment in legend of Fig. 6 of Yin et al. (2009)
+                     ! Equation 26 of Yin et al. (2009)
+                     Cs_star = (gbs(jv) * low_gamma_star(iainia) * Oi - ( 1. + &
+                          low_gamma_star(iainia) * alpha(jv) / 0.047) * Rd(iainia) + Rm ) &
+                          / ( gbs(jv) + kp(jv) ) 
+
+                     ! eq. 11 of Yin et al (2009)
+                     J2 = JJ(iainia) / ( 1. - fpseudo(jv) / ( 1. - fcyc ) )
+
+                     ! Equation right after eq. (20d) of Yin et al. (2009)
+                     z = ( 2. + fQ(jv) - fcyc ) / ( h_protons(jv) * (1. - fcyc ))
+
+                     VpJ2 = fpsir(jv) * J2 * z / 2.
+
+                     A_3=9999.
+
+                     ! See eq. right after eq. 18 of Yin et al. (2009)
+                     ! The loop over limit_photo calculates the assimultion
+                     ! rate of the Rubisco-limited CO2 assimilation (Ac) and
+                     ! the rate of electron transport-limited CO2 assimultion
+                     ! (Aj).  The overall assimilation will be the slower
+                     ! of these two processes.
+                     DO limit_photo=1,2
+                        ! Is Vc limiting the Assimilation
+                        IF ( limit_photo .EQ. 1 ) THEN
+                           a = 1. + kp(jv) / gbs(jv)
+                           b = 0.
+                           x1 = Vc2(iainia)
+                           x2 = KmC(iainia)/KmO(iainia)
+                           x3 = KmC(iainia)
+                           ! Is J limiting the Assimilation
+                        ELSE
+                           a = 1.
+                           b = VpJ2
+                           x1 = (1.- fpsir(jv)) * J2 * z / 3.
+                           x2 = 7. * low_gamma_star(iainia) / 3.
+                           x3 = 0.
+                        ENDIF
+
+                        m=fvpd(iainia)-g0(jv)/gb(iainia)
+                        d=g0(jv)*(Ca(iainia)-Cs_star) + fvpd(iainia)*Rd(iainia)
+                        f=(b-Rm-low_gamma_star(iainia)*Oi*gbs(jv))*x1*d + a*gbs(jv)*x1*Ca(iainia)*d
+                        j=(b-Rm+gbs(jv)*x3 + x2*gbs(jv)*Oi)*m + (alpha(jv)*x2/0.047-1.)*d &
+                             + a*gbs(jv)*(Ca(iainia)*m - d/gb(iainia) - (Ca(iainia) - Cs_star ))
+
+                        g=(b-Rm-low_gamma_star(iainia)*Oi*gbs(jv))*x1*m - (alpha(jv)*low_gamma_star(iainia)/0.047+1.)*x1*d &
+                             + a*gbs(jv)*x1*(Ca(iainia)*m - d/gb(iainia) - (Ca(iainia)-Cs_star ))
+
+                        h=-((alpha(jv)*low_gamma_star(iainia)/0.047+1.)*x1*m + (a*gbs(jv)*x1*(m-1.))/gb(iainia) )
+                        i= ( b-Rm + gbs(jv)*x3 + x2*gbs(jv)*Oi )*d + a*gbs(jv)*Ca(iainia)*d
+                        l= ( alpha(jv)*x2/0.047 - 1.)*m - (a*gbs(jv)*(m-1.))/gb(iainia)
+
+                        p = (j-(h-l*Rd(iainia))) / l
+                        q = (i+j*Rd(iainia)-g) / l
+                        r = -(f-i*Rd(iainia)) / l 
+
+                        ! See Yin et al. (2009) and  Baldocchi (1994)
+                        QQ = ( (p**2._r_std) - 3._r_std * q) / 9._r_std
+                        UU = ( 2._r_std* (p**3._r_std) - 9._r_std *p*q + 27._r_std *r) /54._r_std
+
+                   
+                        IF  (QQ .GE. 0._r_std) THEN 
+                           IF (ABS(UU/(QQ**1.5_r_std) ) .LE. 1._r_std)  THEN
+                              PSI = ACOS(UU/(QQ**1.5_r_std))
+                              A_3_tmp = -2._r_std * SQRT(QQ) * COS(( PSI + 4._r_std * PI)/3._r_std ) - p / 3._r_std
+                              IF (( A_3_tmp .LT. A_3 )) THEN
+                                 A_3 = A_3_tmp
+                              ELSE
+                                 ! In case, J is not limiting the assimilation
+                                 ! we have to re-initialise a, b, x1, x2 and x3 values
+                                 ! in agreement with a Vc-limited assimilation 
+                                 a = 1. + kp(jv) / gbs(jv)
+                                 b = 0.
+                                 x1 = Vc2(iainia)
+                                 x2 = KmC(iainia)/KmO(iainia)
+                                 x3 = KmC(iainia)
+                              ENDIF
+                           ENDIF
+                        ELSE
+                           WRITE(numout,*) 'WARNING: unexpected value for QQ (diffuco.f90)'
+                        ENDIF
+
+
+                        IF ( ( A_3 .EQ. 9999. ) .OR. ( A_3 .LT. (-Rd(iainia)) ) ) THEN
+                           write(numout,*) 'A_3', A_3
+                           write(numout,*) '-Rd', -Rd(iainia)
+                           WRITE(numout,*) 'We have a problem in diffuco_trans_co2'
+                           WRITE(numout,*) 'no real positive solution found for pft:',jv
+                           WRITE(numout,*) 'temp_sol:',temp_sol(iainia)
+                           WRITE(numout,*) 'vpd:',vpd(iainia)
+                           A_3 = -Rd(iainia)
+                        ENDIF
+                        assimi(iainia) = A_3
+
+                        IF(ld_photo .AND. jv == test_pft .AND. iainia == test_pft)THEN
+                           WRITE(numout,*) '( x1 - ( assimi(iainia) + Rd(iainia) ) ', &
+                                ( x1 - (assimi(iainia) + Rd(iainia) ))
+                           WRITE(numout,*) 'x1,assimi(iainia),Rd(iainia): ', &
+                                x1,assimi(iainia),Rd(iainia)
+                           WRITE(numout,*) 'jv,ilev,iainia: ', jv,ilev,iainia
+                        ENDIF
+
+                        !++++ TEMP +++++
+                        IF(( x1 - (assimi(iainia) + Rd(iainia) )) == zero)THEN
+
+                           ! This causes a problem, since we really should not
+                           ! be dividing by zero.  However, it seems to happen
+                           ! fairly rarely, so all we'll do is cycle to the
+                           ! next loop and keep track of this warning so we
+                           ! can look at it afterwards.
+                           warnings(iainia,jv,iwphoto)=warnings(iainia,jv,iwphoto)+un
+
+                           IF(ld_warn)THEN
+                              WRITE(numout,*) 'Diffuco, Getting ready to divide by zero! C4'
+                              WRITE(numout,*) '( x1 - ( assimi(iainia) + Rd(iainia) ) ', &
+                                   ( x1 - (assimi(iainia) + Rd(iainia) ))
+                              WRITE(numout,*) 'x1,assimi(iainia),Rd(iainia): ', &
+                                   x1,assimi(iainia),Rd(iainia)
+                              WRITE(numout,*) 'jv,ilev,iainia: ', jv,ilev,iainia
+                           ENDIF
+
+                           CYCLE
+
+                        ENDIF
+
+                        ! Eq. 24 of Yin et al. (2009) 
+                        Obs = ( alpha(jv) * assimi(iainia) ) / ( 0.047 * gbs(jv) ) + Oi
+                        ! Eq. 23 of Yin et al. (2009)
+                        Cc = ( ( assimi(iainia) + Rd(iainia) ) * ( x2 * Obs + x3 ) + low_gamma_star(iainia) &
+                             * Obs * x1 ) &
+                             / ( x1 - ( assimi(iainia) + Rd(iainia) ))
+                        ! Eq. 22 of Yin et al. (2009)
+                        leaf_ci(iainia,jv,ilev) = ( Cc - ( b - assimi(iainia) - Rm ) / gbs(jv) ) / a
+
+                        ! Eq. 25 of Yin et al. (2009)
+                        ! It should be Cs instead of Ca but it seems that 
+                        ! other equations in Appendix C make use of Ca
+                        IF ( ABS( assimi(iainia) + Rd(iainia) ) .LT. min_sechiba ) THEN
+                           gs(iainia) = g0(jv)
+                        ELSE
+                           gs(iainia) = g0(jv) + ( assimi(iainia) + Rd(iainia) ) / ( Ca(iainia) - Cs_star ) * fvpd(iainia)             
+                        ENDIF
+                        !                       
+                     ENDDO
+                     !
+                  ELSE
+                     !
+                     ! @addtogroup Photosynthesis
+                     ! @{   
+                     !
+                     ! 2.4.3 Assimilation for C3 plants (Farqhuar et al., 1980)\n
+                     !! \latexonly
+                     !! \input{diffuco_trans_co2_2.4.3.tex}
+                     !! \endlatexonly
+                     ! @}           
+                     !
+                     !
+                     !
+                     A_1=9999.
+
+                     ! See eq. right after eq. 18 of Yin et al. (2009)
+                     DO limit_photo=1,2
+                        ! Is Vc limiting the Assimilation
+                        IF ( limit_photo .EQ. 1 ) THEN
+                           x1 = vc2(iainia)
+                           ! It should be O not Oi (comment from Vuichard)
+                           x2 = KmC(iainia) * ( 1. + Oi / KmO(iainia) )
+                           ! Is J limiting the Assimilation
+                        ELSE
+                           x1 = JJ(iainia)/4.
+                           x2 = 2. * gamma_star(iainia)
+                        ENDIF
+
+
+                        ! See Appendix B of Yin et al. (2009)
+                        a = g0(jv) * ( x2 + gamma_star(iainia) ) + ( fvpd(iainia) ) * ( x1 - Rd(iainia) )
+                        b = Ca(iainia) * ( x1 - Rd(iainia) ) - gamma_star(iainia) * x1 - Rd(iainia) * x2
+                        c = Ca(iainia) + x2 + ( 1./gb(iainia) ) * ( x1 - Rd(iainia) ) 
+                        d = x2 + gamma_star(iainia)
+                        m = fvpd(iainia) / gb(iainia)  
+
+                        p = - ( d + a / gb(iainia) + fvpd(iainia) * c ) / m
+
+                        q = ( d * ( x1 - Rd(iainia) ) + a*c + ( fvpd(iainia) ) * b ) / m
+                        r = - a * b / m
+
+                        ! See Yin et al. (2009) 
+                        QQ = ( (p**2._r_std) - 3._r_std * q) / 9._r_std
+                        UU = ( 2._r_std* (p**3._r_std) - 9._r_std *p*q + 27._r_std *r) /54._r_std
+
+                        IF  (QQ .GE. 0._r_std) THEN
+                           IF (ABS(UU/(QQ**1.5_r_std) ) .LE. 1._r_std)  THEN
+                           PSI = ACOS(UU/(QQ**1.5_r_std))
+                           A_1_tmp = -2._r_std * SQRT(QQ) * COS( PSI / 3._r_std ) - p / 3._r_std
+                           IF (( A_1_tmp .LT. A_1 )) THEN
+                              A_1 = A_1_tmp
+                           ELSE
+                              ! In case, J is not limiting the assimilation
+                              ! we have to re-initialise x1 and x2 values
+                              ! in agreement with a Vc-limited assimilation 
+                              x1 = vc2(iainia)
+                              ! It should be O not Oi (comment from Vuichard)
+                              x2 = KmC(iainia) * ( 1. + Oi / KmO(iainia) )                           
+                           ENDIF
+                           ENDIF
+                        ENDIF
+                     ENDDO
+
+                     IF ( (A_1 .EQ. 9999.) .OR. ( A_1 .LT. (-Rd(iainia)) ) ) THEN
+                        write(numout,*) 'A_3', A_3
+                           write(numout,*) '-Rd 3208', -Rd(iainia)
+                        WRITE(numout,*) 'We have a problem in diffuco_trans_co2'
+                        WRITE(numout,*) 'no real positive solution found for pft:',jv
+                        WRITE(numout,*) 'temp_sol:',temp_sol(iainia)
+                        WRITE(numout,*) 'vpd:',vpd(iainia)
+                        WRITE(numout,*) 'Setting the solution to -Rd(iainia):',-Rd(iainia)
+                        A_1 = -Rd(iainia)
+                     ENDIF
+                     assimi(iainia) = A_1
+                     ! Eq. 18 of Yin et al. (2009)
+
+                     IF(ld_photo .AND. jv == test_pft .AND. iainia == test_pft)THEN
+                        WRITE(numout,*) '( x1 - ( assimi(iainia) + Rd(iainia) ) ', &
+                             ( x1 - (assimi(iainia) + Rd(iainia) ))
+                        WRITE(numout,*) 'x1,assimi(iainia),Rd(iainia): ', &
+                             x1,assimi(iainia),Rd(iainia)
+                        WRITE(numout,*) 'jv,ilev,iainia: ', jv,ilev,iainia
+                     ENDIF
+                     
+                     !++++ TEMP +++++
+                     IF(( x1 - (assimi(iainia) + Rd(iainia) )) == zero)THEN
+
+                        ! This causes a problem, since we really should not
+                        ! be dividing by zero.  However, it seems to happen
+                        ! fairly rarely, so all we'll do is cycle to the
+                        ! next loop and keep track of this warning so we
+                        ! can look at it afterwards.
+                        warnings(iainia,jv,iwphoto)=warnings(iainia,jv,iwphoto)+un
+
+                        IF(ld_warn)THEN
+                           WRITE(numout,*) 'Diffuco, Getting ready to divide by zero! C3'
+                           WRITE(numout,*) '( x1 - ( assimi(iainia) + Rd(iainia) ) ', &
+                                ( x1 - (assimi(iainia) + Rd(iainia) ))
+                           WRITE(numout,*) 'x1,assimi(iainia),Rd(iainia): ', &
+                                x1,assimi(iainia),Rd(iainia)
+                           WRITE(numout,*) 'jv,ilev,iainia: ', jv,ilev,iainia
+                        ENDIF
+
+                        CYCLE
+
+                     ENDIF
+                     !++++++++++++++++++++++++++++++
+
+                     Cc = ( gamma_star(iainia) * x1 + ( assimi(iainia) + Rd(iainia) ) * x2 )  &
+                          / ( x1 - ( assimi(iainia) + Rd(iainia) ) )
+                     ! Eq. 17 of Yin et al. (2009)
+                     leaf_ci(iainia,jv,ilev) = Cc 
+                     ! See eq. right after eq. 15 of Yin et al. (2009)
+                     ci_star = gamma_star(iainia) 
+                     ! 
+                     ! Eq. 15 of Yin et al. (2009)
+                     IF ( ABS( assimi(iainia) + Rd(iainia) ) .LT. min_sechiba ) THEN
+                        gs(iainia) = g0(jv)
+                     ELSE
+                        gs(iainia) = g0(jv) + ( assimi(iainia) + Rd(iainia) ) / ( leaf_ci(iainia,jv,ilev) &
+                             - ci_star ) * fvpd(iainia)
+                     ENDIF
+                  ENDIF
+                  !
+                  !
+                  ! this is only for output to netcdf
+                  gs_diffuco_output(iainia,jv,ilev) = gs(iainia)
+                  !write(*,*) 'gs_diffuco_pft',jv,'ilev',ilev,gs(iainia)
+                  !
+                  !
+                  ! @addtogroup Photosynthesis
+                  ! @{   
+                  !
+                  !! 2.4.4 Estimatation of the stomatal conductance (Ball et al., 1987).\n
+                  !! \latexonly
+                  !! \input{diffuco_trans_co2_2.4.4.tex}
+                  !! \endlatexonly
+                  ! @}           
+                  !
+                  !
+                  ! keep stomatal conductance of the levels which we decide
+                  ! are the top levels.  Notice that we multiply by the LAI
+                  ! in the level here, so this is no longer a per leaf quantity,
+                  ! but the whole quantity.
+                  IF ( top_level(iainia,ilev) ) THEN
+                     gs_top(iainia) = gs_top(iainia)+gs(iainia)*lai_per_level(iainia,jv,ilev)
+                     !
+                  ENDIF
+                  !
+                  ! @addtogroup Photosynthesis
+                  ! @{   
+                  !
+                  !! 2.4.5 Integration at the canopy level\n
+                  !! \latexonly
+                  !! \input{diffuco_trans_co2_2.4.5.tex}
+                  !! \endlatexonly
+                  ! @}           
+                  ! total assimilation and conductance
+                  ! 
+                  !++++++++++++++++++++
+                  ! The equations give the amount of carbon produced per m**2 if
+                  ! leaf surface.  Therefore, since we want GPP in units of m**2 of land surface,
+                  ! we have to multiply by the LAI.
+                  assimtot(iainia) = assimtot(iainia) + &
+                       assimi(iainia) * lai_per_level(iainia,jv,ilev)
+!                       assimi(iainia) 
+                  Rdtot(iainia) = Rdtot(iainia) + &
+!                       Rd(iainia) 
+                       Rd(iainia) * lai_per_level(iainia,jv,ilev)
+                  gstot(iainia) = gstot(iainia) + &
+                       gs(iainia) * lai_per_level(iainia,jv,ilev)
+!                       gs(iainia) 
+                   
+                  IF(test_pft == jv .AND. ld_photo)THEN
+                     WRITE(numout,'(A,2I5,10ES20.8)') 'assimi ',ilev,&
+                          iainia,assimi(iainia),assimtot(iainia),gs(iainia),&
+                          gstot(iainia),lai_per_level(iainia,jv,ilev)
+                  ENDIF
+
+                  !! (JR 100714) we need to retain the gs (stomatal conductance) per level and per PFT for use
+                  !! outside of this routine, in the case that the supply term constraint is applied and the 
+                  !! stomatal conductance profile needs to be re-calculated.
+                  gs_store(iainia, jv, ilev) = gs(iainia)
+                  !
+
+                  !! (JR 100714) we also retain the gstot (stomatal conductance over all canopy levels, constrained
+                  !! by LAI, again for the recalculation of the stomatal conductance profile.
+                  gstot_store(iainia, jv) = gstot_store(iainia, jv) + (gs(iainia) * lai_per_level(iainia,jv,ilev))
+
+                  !
+               ENDIF ! if there is absorbed light 
+            ENDDO  ! loop over levels
+         ENDDO assim_loop  ! loop over assimulation points
+
+      !
+      !! 2.5 Calculate resistances
+
+         DO inia=1,nia
+
+            !
+            iainia=index_assi(inia)
+            !
+
+            ! We hit a fringe case above where we could not
+            ! calculate the GPP.  Skip this loop so we don't
+            ! divide by zero.
+            IF(lskip(iainia)) CYCLE
+
+
+            !! Mean stomatal conductance for CO2 (mol m-2 s-1)
+            gsmean(iainia,jv) = gstot(iainia)
+            !
+            ! cimean is the "mean ci" calculated in such a way that assimilation 
+            ! calculated in enerbil is equivalent to assimtot
+            !
+            IF((assimtot(iainia)+Rdtot(iainia)) .GT. min_sechiba)THEN
+               cimean(iainia,jv) = (gsmean(iainia,jv)-g0(jv)) &
+                    / (fvpd(iainia)*(assimtot(iainia)+Rdtot(iainia))) &
+                    + gamma_star(iainia) 
+            ELSE
+               ! According to Nicolas, this variable is completely diagnostic and not
+               ! used for anything.  If the analytical photosynthesis is unable to find
+               ! a solution for the A_1 coefficients in any of the levels, assimtot will
+               ! be equal to -Rd, which means we will be dividing by zero.  This loop
+               ! is to prevent that, and since cimean is diagnostic is doesn't matter
+               ! what the value is.
+               cimean(iainia,jv) = val_exp
+            ENDIF
+                 
+            ! conversion from umol m-2 (PFT) s-1 to gC m-2 (mesh area) tstep-1
+            gpp(iainia,jv) = assimtot(iainia)*12e-6*veget_max(iainia,jv)*dtradia
+            !
+            !IF(test_grid == 1 .AND. jv == test_pft)THEN
+            !   istep=istep+1
+            !   WRITE(numout,*) 'GPP DIFFUCO: ',istep,gpp(iainia,jv),assimtot(iainia), veget_max(iainia,jv)
+            !ENDIF
+
+            ! conversion from (mol m-2 s-1) to (umol m-2 s-1)
+            !gsmean(iainia,jv) = gsmean(iainia,jv)*1e-6
+            !
+            gsmean(iainia,jv) = gsmean(iainia,jv)*1000000
+            ! conversion from mol/m^2/s to m/s
+            !
+            ! As in Pearcy, Schulze and Zimmermann
+            ! Measurement of transpiration and leaf conductance
+            ! Chapter 8 of Plant Physiological Ecology
+            ! Field methods and instrumentation, 1991
+            ! Editors:
+            !
+            !    Robert W. Pearcy,
+            !    James R. Ehleringer,
+            !    Harold A. Mooney,
+            !    Philip W. Rundel
+            !
+            ! ISBN: 978-0-412-40730-7 (Print) 978-94-010-9013-1 (Online)
+            !
+            !
+            !
+            !++++++++ CHECK +++++++++
+            ! Do we need to normalise gs_top here by the LAI in the level?
+            ! In the trunk, it seems like they use an LAI of 0.1, so renormalise
+            ! to that.  The default value of lai_top is 0.1.
+            !
+            !! (JR 100714)
+            !! gs_top is normalised in the trunk over the entire canopy LAI, as it
+            !! meant to provide backwards compatability with the 'old' method for calculating
+            !! the stomatal conductance (in diffuco_trans) that calculates gs according to 
+            !! incident SW radiation (rather than CO2 concentration, as here in diffuco_trans_co2)
+            !!
+            !! rstruct in diffuco_trans is an extra resistance term added to reflect the fact
+            !! that less light reaches the lower canopy, and the total resistance used to calculate
+            !! vbeta3, and hence the transpiration, is (rstruct + rveget)
+            !!
+            !! The rstruct term makes the code more difficult to follow, and is no longer has
+            !! a physical requirement. We are getting small values of gstop as calculated below,
+            !! which was resulting in big resistances when rstruct = min_sechiba and 
+            !! rveget = un/gstop and total resistance = (rstruct + rveget) - see commented out
+            !! code below.
+            !!
+            !! The most transparent structure is to set total resistance = rveget = (1 / gstot)
+            !! This is analogous to the way in which assimtot, and hence canopy GPP, is calculated
+            !! above
+
+            gs_top(iainia)=gs_top(iainia)/totlai_top*lai_top(jv)
+            !+++++++++++++++++++++++++
+
+            gstot(iainia) =  mmol_to_m_1 *(temp_sol(iainia)/tp_00)*&
+                 (pb_std/pb(iainia))*gstot(iainia)*ratio_H2O_to_CO2
+            gstop(iainia) =  mmol_to_m_1 * (temp_sol(iainia)/tp_00)*&
+                 (pb_std/pb(iainia))*gs_top(iainia)*ratio_H2O_to_CO2
+                 
+                 
+            !IF (jv == test_pft .AND. test_grid == 1) THEN 
+            !         WRITE(numout, '(A20)'        ) 'Without water stress:'
+            !         WRITE(numout, '(A20, I5)'    ) 'pft type is:    ', jc
+            !        WRITE(numout, '(A20, ES15.5)') 'Old_Gs_total:', gstot(iainia)            
+            !ENDIF   
+             
+            ! THIS PART OF CORRECTION OF ::gstot SHOULD BE CONSISTENCY WITH 
+            ! "SECHIBA_HYDROL_ARCH" where the ::gstot is recalculated, again. 
+              
+            !++++++ CHECK ++++++
+            ! We introduce ::coupled_lai to calculate the :: vbeta3 
+            ! In an closed canopy not all the leaves fully interact with the
+            ! atmosphere because leaves can shelter each other. In a more open
+            ! canopy most leaves can interact with the atmosphere. We use the
+            ! ratio of lai over ::Pgap as a proxy for the amount of canopy that
+            ! can interact with the atmosphere. Clearly that amount of lai that
+            ! interacts should never exceed the:: total_lai.
+            coupled_lai(iainia, jv) = biomass_to_coupled_lai( biomass(iainia, &
+                 jv, ileaf, icarbon), veget(iainia,jv), jv)
+            
+            total_lai(iainia, jv) = biomass_to_lai( biomass(iainia, jv, ileaf,&
+                 icarbon), jv )
+
+            !---TEMP---
+!!$            IF (ld_wstress) THEN
+!!$               WRITE(numout,*) 'coupled LAI, ',  jv, coupled_lai(iainia, jv)
+!!$               WRITE(numout,*) 'total LAI, ',  jv, total_lai(iainia, jv)
+!!$               WRITE(numout,*) 'veget, ', jv, veget(iainia, jv)
+!!$               WRITE(numout,*) 'biomass(ileaf), ',biomass(iainia, jv, ileaf, icarbon) 
+!!$            ENDIF
+            !----------
+      
+            !+++++CHECK++++
+            !Here, we try to use coupled_lai to reset/refine the total stomata conductance 
+            !which interacted with the atmosphere for the transpiration for each pft.
+            gstot(iainia) = gstot(iainia)* (coupled_lai(iainia,jv)/total_lai(iainia,jv))
+            !++++++++++++++
+            !write(*,*) 'coupled_LAI',coupled_lai(iainia,jv)
+            !write(*,*) 'total_lai',total_lai(iainia,jv) 
+            !+++++++++CHECK++++++++
+            !To get the resonable transpiration we had to set :: lai_top to
+            !::lai
+            !so we were using the entire canopy. Therefore we no longer use
+            !::lai_top and simply make use of the entire canopy to calculate the
+            !vegetation resistance from inverse of ::gstot so, we calculate the
+            !:: rveget using :: 1/gstot
+       !     rveget(iainia, jv) = un / gstot(iainia) 
+       
+
+
+            IF (gstot(iainia) .NE. zero) THEN
+       rveget(iainia, jv) = un / gstot(iainia)  
+           ELSE
+              rveget(iainia,jv)=undef_sechiba
+
+            ENDIF
+
+
+
+
+
+
+
+
+
+     !+++++++++++++++++++++++++++++++++++++++           
+
+            !rveget(iainia,jv) = un/gstop(iainia)
+ 
+
+          !  rveget_min(iainia,jv) = (defc_plus / kzero(jv)) * &
+          !      (un / SUM(lai_per_level(iainia,jv,:)))
+          
+    !     WRITE(*,*) "nexw"  
+
+            IF (SUM(lai_per_level(iainia,jv,:)) .NE. zero) THEN
+              rveget_min(iainia,jv) = (defc_plus / kzero(jv)) * &
+                 (un / SUM(lai_per_level(iainia,jv,:)))
+            ELSE
+              rveget_min(iainia,jv)=undef_sechiba 
+          
+            ENDIF
+
+            !
+            ! 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)
+            
+            !++++++++ CHECK +++++++
+            !It seems that the calcualtion of rstruct is duplicated with the calculation of rvegt
+            !So, we set the ::rstruct as zero 
+            !rstruct(iainia,jv) = MAX( un/gstot(iainia) - &
+            !     rveget(iainia,jv), min_sechiba)
+            !
+            !
+            !! wind is a global variable of the diffuco module.
+            speed = MAX(min_wind, wind(iainia))
+            !
+            ! beta for transpiration
+            !
+            ! Corrections Nathalie - 28 March 2006 - on advices of Fred Hourdin
+            !! Introduction of a potentiometer rveg_pft to settle the rveg+rstruct sum problem in the coupled mode.
+            !! rveg_pft=1 in the offline mode. rveg_pft is a global variable declared in the diffuco module.
+            !vbeta3(iainia,jv) = veget_max(iainia,jv) * &
+            !  (un - zqsvegrap(iainia)) * &
+            !  (un / (un + speed * q_cdrag(iainia) * (rveget(iainia,jv) + &
+            !   rstruct(iainia,jv))))
+            !! Global resistance of the canopy to evaporation
+            !cresist=(un / (un + speed * q_cdrag(iainia) * &
+            !     (rveg_pft(jv)*(rveget(iainia,jv) + rstruct(iainia,jv)))))
+
+            ! (JR 100714)
+            ! previously the resistance term in this expression was (rveget + rstruct), but we now
+            ! use rveget alone  
+
+            cresist=(un / (un + speed * q_cdrag(iainia) * &
+                 (rveg_pft(jv)*(rveget(iainia,jv)))))
+
+            !+++CHECK+++
+            !For the interception we assume -as earlier- that the surface area
+            !that intercepts is well estimated by ::veget. This is wrong because
+            !every leav can contribute to the interception. Depending on weather
+            !the parameters for interception are bulk values or single leave. Our
+            !approach is correct or needd to be improved.  
+            !
+            vbeta3(iainia,jv) = MAX(zero, veget_max(iainia,jv) * cresist)
+                ! veget_max(iainia,jv) * &
+                ! (un - zqsvegrap(iainia)) * cresist + &
+                ! MIN( vbeta23(iainia,jv), veget(iainia,jv) * &
+                ! zqsvegrap(iainia) * cresist )
+            !+++++++++++++++++++++++++
+            !write(*,*) "vbeta3_diffuco_co2",vbeta3(iainia,jv)
+            
+            !vbeta3(iainia,jv) = veget_max(iainia,jv) * &
+            !     (un - zqsvegrap(iainia)) * cresist + &
+            !     MIN( vbeta23(iainia,jv), veget_max(iainia,jv) * &
+            !     zqsvegrap(iainia) * cresist )
+           
+! AD100715 tzj_wb : because of g0, vbeta3 cannot be zero even if humrel=0
+!            ADDING dependence on humrel, as we don't want transpiration when
+!            the soil cannot deliver it
+!            should this correction induce changes to assim, gpp etc ?
+!            similarly, should the transpiration controlled by vbeta23 be
+!            converted to assimilation ???
+            IF ( humrel(iainia,jv) .LT. min_sechiba ) THEN
+               vbeta3(iainia,jv) = zero
+            ENDIF        
+ 
+            ! vbeta3pot for computation of potential transpiration (needed for irrigation)
+            vbeta3pot(iainia,jv) = MAX(zero, veget_max(iainia,jv) * cresist)
+           ! write(*,*) 'vbeta3pot_diffuco_co2',vbeta3pot(iainia,jv)
+            !
+            
+         ENDDO !loop over grid points
+         !
+      ENDIF ! if nia LT zero
+       
+   ENDDO  ! loop over vegetation types
+   !
+   !DO ic =1, kjpindex
+   !     write(*,*) 'vbeta3_diffuco_loop',vbeta3(ic,2)
+   !ENDDO
+
+   DO ic = 1, kjpindex
+      DO jc = 1, nvm 
+      !++++++TEMP++++++++++++++++++++++++++++++++++++
+      !  IF ( ld_gstest .AND. jc == test_pft) THEN
+      !     WRITE(714,   '(A20, ES20.4)') 'Rcanopy,', (un / (un + speed *q_cdrag(ic) * &
+      !                        (rveg_pft(jc)*(rveget(ic,jc) + rstruct(ic,jc))))) 
+                                                    
+      !     WRITE(numout,'(A20, ES20.4)') 'Rcanopy',(un / (un + speed *q_cdrag(ic) * &
+      !                        (rveg_pft(jc)*(rveget(ic,jc) + rstruct(ic,jc))))) 
+      !  ENDIF
+      !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      
+
+      
+         IF(veget_max(ic,jc) == zero)THEN
+             ! this vegetation type is not present, so no reason to do the 
+             ! calculation
+             CYCLE
+         ENDIF
+
+         DO kc = 1, nlevels_tot
+             gs_column_total(ic,jc) = gs_column_total(ic,jc) + gs_store(ic,jc,kc) * lai_per_level(ic,jc,kc) 
+
+             gstot_component(ic,jc,kc) = gs_store(ic,jc,kc) * lai_per_level(ic,jc,kc) 
+
+             IF (gstot_store(ic,jc) .eq. 0.0d0) THEN
+                 gstot_frac(ic,jc,kc) = 0.0d0
+             ELSE
+                 gstot_frac(ic,jc,kc) = gstot_component(ic,jc,kc) / gstot_store(ic,jc)
+             END IF
+         END DO ! kc = 1, nlevels_tot 
+      END DO ! jc = 1, nvm
+   END DO ! ic = 1, kjpindex
+
+    Abs_light(:,:,:) = zero
+    Abs_light_can(:,:) = zero
+    
+   DO ic = 1, kjpindex
+      DO jc = 1, nvm 
+         IF(veget_max(ic,jc) == zero)THEN
+             ! this vegetation type is not present, so no reason to do the 
+             ! calculation
+             CYCLE
+         ENDIF
+
+         DO kc = 1, nlevels_tot
+            IF (gs_column_total(ic,jc) .ne. zero) THEN
+               gs_distribution(ic,jc,kc) = gs_store(ic,jc,kc)* lai_per_level(ic,jc,kc) / gs_column_total(ic,jc)
+            ELSE
+               gs_distribution(ic,jc,kc) = zero
+            END IF
+               Abs_light(ic,jc,kc)=Isotrop_Abs_Tot_p(ic,jc,kc)*light_tran_to_level(ic,jc,kc)
+            END DO ! kc = 1, nlevels_tot 
+            IF (jv==test_pft .AND. ld_photo) THEN  
+               Abs_light_can(:,:)=SUM(Abs_light(:,:,:),3)
+               WRITE(numout,*) 'Absorbed light in the canopy', Abs_light_can(:,jc)
+            ENDIF
+      END DO ! jc = 1, nvm
+   END DO ! ic = 1, kjpindex   
+
+!!$   !++++++ WRITING OUT SOME STUFF
+!!$   counter=counter+1
+!!$   WRITE(123,'(I8,20F20.10)') counter,gs_distribution(test_grid,test_pft,:)
+!!$   WRITE(124,'(I8,20F20.10)') counter,gstot_frac(test_grid,test_pft,:)
+!!$   WRITE(125,'(I8,20F20.10)') counter,gstot_store(test_grid,test_pft)
+!!$   WRITE(126,'(I8,20F20.10)') counter,gs_store(test_grid,test_pft,:)
+!!$   WRITE(127,'(I8,20F20.10)') counter,lai_per_level(test_grid,test_pft,:)
+!!$   WRITE(128,'(I8,20F20.10)') counter,gstot_component(test_grid,test_pft,:)
+!!$   WRITE(129,'(I8,20F20.10)') counter,gs_column_total(test_grid,test_pft)
+!!$   WRITE(130,'(I8,20F20.10)') counter,SUM(lai_per_level(test_grid,test_pft,:))
+!!$   IF(rveget(test_grid,test_pft) .LT. 1e19) &
+!!$        WRITE(131,'(I8,20ES20.10)') counter,rveget(test_grid,test_pft)
+!!$   IF(rveget_min(test_grid,test_pft) .LT. 1e19) &
+!!$        WRITE(132,'(I8,20ES20.10)') counter,rveget_min(test_grid,test_pft)
+!!$   WRITE(133,'(I8,20ES20.10)') counter,vbeta3(test_grid,test_pft)
+!!$   WRITE(134,'(I8,20ES20.10)') counter,vbeta3pot(test_grid,test_pft)
+  
+
+
+
+
+
+vbeta3save=vbeta3
+!write(*,*) "vbeta3save END", vbeta3save
+ 
+   IF (long_print) WRITE (numout,*) ' diffuco_trans_co2 done '
+!IF ( ALLOCATED (vbeta3save)) DEALLOCATE (vbeta3save) 
+
+END SUBROUTINE diffuco_trans_co2
+
+
+!! ================================================================================================================================
+!! SUBROUTINE	   : jdiffuco_comb
+!!
+!>\BRIEF           This routine combines the previous partial beta 
+!! coefficients and calculates the total alpha and complete beta coefficients.
+!!
+!! DESCRIPTION	   : Those integrated coefficients are used to calculate (in enerbil.f90) the total evapotranspiration 
+!! from the grid-cell. \n
+!!
+!! In the case that air is more humid than surface, dew deposition can occur (negative latent heat flux). 
+!! In this instance, for temperature above zero, all of the beta coefficients are set to 0, except for 
+!! interception (vbeta2) and bare soil (vbeta4 with zero soil resistance). The amount of water that is 
+!! intercepted by leaves is calculated based on the value of LAI of the surface. In the case of freezing 
+!! temperatures, water is added to the snow reservoir, and so vbeta4 and vbeta2 are set to 0, and the 
+!! total vbeta and valpha is set to 1.\n
+!!
+!! \latexonly 
+!!     \input{diffucocomb1.tex}
+!! \endlatexonly
+!!
+!! The beta and alpha coefficients are initially set to 1.
+!! \latexonly 
+!!     \input{diffucocomb2.tex}
+!! \endlatexonly
+!!
+!! If snow is lower than the critical value:
+!! \latexonly 
+!!     \input{diffucocomb3.tex}
+!! \endlatexonly
+!! If in the presence of dew:
+!! \latexonly 
+!!     \input{diffucocomb4.tex}
+!! \endlatexonly
+!!
+!! Determine where the water goes (soil, vegetation, or snow)
+!! when air moisture exceeds saturation.
+!! \latexonly 
+!!     \input{diffucocomb5.tex}
+!! \endlatexonly
+!!
+!! If it is not freezing dew is put into the interception reservoir and onto the bare soil. If it is freezing, 
+!! water is put into the snow reservoir. 
+!! Now modify valpha and vbetas where necessary: for soil and snow
+!! \latexonly 
+!!     \input{diffucocomb6.tex}
+!! \endlatexonly
+!!
+!! and for vegetation
+!! \latexonly 
+!!     \input{diffucocomb7.tex}
+!! \endlatexonly
+!!
+!! Then compute part of dew that can be intercepted by leafs.
+!!
+!! There will be no transpiration when air moisture is too high, under any circumstance
+!! \latexonly 
+!!     \input{diffucocomb8.tex}
+!! \endlatexonly
+!!
+!! There will also be no interception loss on bare soil, under any circumstance.
+!! \latexonly 
+!!     \input{diffucocomb9.tex}
+!! \endlatexonly
+!!
+!! The flowchart details the 'decision tree' which underlies the module. 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): vbeta1, vbeta4, humrel, vbeta2, vbeta3, valpha, vbeta
+!!
+!! REFERENCE(S) :
+!! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+!! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+!! Circulation Model. Journal of Climate, 6, pp.248-273
+!! - Guimberteau, M, 2010. ModÃ©lisation de l'hydrologie continentale et influences de l'irrigation
+!! sur le cycle de l'eau, PhD Thesis, available from:
+!! http://www.sisyphe.upmc.fr/~guimberteau/docs/manuscrit_these.pdf
+!!
+!! FLOWCHART    :
+!! \latexonly 
+!!     \includegraphics[scale=0.25]{diffuco_comb_flowchart.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+
+  SUBROUTINE jdiffuco_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, vbeta2sum, vbeta3sum)    
+    
+    ! Ajout qsintmax dans les arguments de la routine Nathalie / le 13-03-2006
+
+  !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+    
+    INTEGER(i_std), INTENT(in)                           :: kjpindex   !! Domain size (-)
+    REAL(r_std), INTENT (in)                             :: dtradia    !! Time step (s)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: rau        !! Air Density (kg m^{-3})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: u          !! Eastward Lowest level wind speed (m s^{-1}) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: v          !! Nortward Lowest level wind speed (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: q_cdrag    !! Product of Surface drag coefficient and wind speed (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: pb         !! Lowest level pressure (Pa)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: qair       !! Lowest level specific air humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: temp_sol   !! Skin temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: temp_air   !! Lower air temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: snow       !! Snow mass (kg)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: veget      !! Fraction of vegetation type (fraction)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: lai        !! Leaf area index (m^2 m^{-2})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: qsintmax   !! Maximum water on vegetation (kg m^{-2})
+
+    !! 0.2 Output variables
+    
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)       :: valpha     !! Total Alpha coefficient (-)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)       :: vbeta      !! Total beta coefficient (-)
+
+    !! 0.3 Modified variables 
+    
+    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 (within range 0 to 1)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: vbeta2     !! Beta for interception loss (-)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: vbeta3     !! Beta for Transpiration (-)
+    
+    !! 0.4 Local variables
+    
+    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
+   ! REAL(r_std), DIMENSION(kjpindex)                     :: vbeta2sum, vbeta3sum
+!_ ================================================================================================================================
+    
+    !! \latexonly 
+    !!     \input{diffucocomb1.tex}
+    !! \endlatexonly
+    vbeta2sum(:) = zero
+    vbeta3sum(:) = zero
+    DO jv = 1, nvm
+      vbeta2sum(:) = vbeta2sum(:) + vbeta2(:,jv)
+      vbeta3sum(:) = vbeta3sum(:) + vbeta3(:,jv)
+    ENDDO 
+
+  !! 1. The beta and alpha coefficients are initially set to 1.
+     
+    !! \latexonly 
+    !!     \input{diffucocomb2.tex}
+    !! \endlatexonly
+    vbeta(:) = un
+    valpha(:) = un
+
+    
+  !! 2. if snow is lower than the critical value:
+    
+    !! \latexonly 
+    !!     \input{diffucocomb3.tex}
+    !! \endlatexonly
+    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:
+     
+    CALL qsatcalc (kjpindex, temp_air, pb, qsatt)
+   ! modified in 25/Nov 16:44 temp_sol -> temp_air
+   ! modified in 02/Jan 17:44 temp_air -> temp_sol
+   ! modified in March 3 use temp_sol to check the dew
+    !! 9.3.1 Determine where the water goes 
+    !! Determine where the water goes (soil, vegetation, or snow)
+    !! when air moisture exceeds saturation.
+    !! \latexonly 
+    !!     \input{diffucocomb5.tex}
+    !! \endlatexonly
+    toveg(:) = .FALSE.
+    tosnow(:) = .FALSE.
+    DO ji = 1, kjpindex
+        !write(*,*) 'qsatt_dewj',qsatt(ji)
+        !write(*,*) 'qair_dewj',qair(ji)
+
+      IF ( qsatt(ji) .LT. qair(ji) ) THEN
+          IF (temp_air(ji) .GT. tp_00) THEN
+
+              !! 9.3.1.1  If it is not freezing, 
+              !! If it is not freezing dew is put into the 
+              !! interception reservoir and onto the bare soil.
+              toveg(ji) = .TRUE.
+          ELSE
+
+              !! 9.3.1.2  If it is freezing, 
+              !! If it is freezing water is put into the 
+              !! snow reservoir.
+              tosnow(ji) = .TRUE.
+          ENDIF
+      ENDIF
+    END DO
+
+
+    !! 9.3.1.3 Now modify valpha and vbetas where necessary.
+    
+    !! 9.3.1.3.1 Soil and snow (2d)
+    !! \latexonly 
+    !!     \input{diffucocomb6.tex}
+    !! \endlatexonly
+    DO ji = 1, kjpindex
+      IF ( toveg(ji) ) THEN
+        vbeta1(ji) = zero
+        vbeta4(ji) = tot_bare_soil(ji)
+        ! 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
+
+    !! 9.3.1.3.2 Vegetation (3d)
+    !! \latexonly 
+    !!     \input{diffucocomb7.tex}
+    !! \endlatexonly
+    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
+              
+              ! 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= &
+                         &   dew_veg_poly_coeff(6)*lai(ji,jv)**5 &
+                         & - dew_veg_poly_coeff(5)*lai(ji,jv)**4 &
+                         & + dew_veg_poly_coeff(4)*lai(ji,jv)**3 &
+                         & - dew_veg_poly_coeff(3)*lai(ji,jv)**2 &
+                         & + dew_veg_poly_coeff(2)*lai(ji,jv) &
+                         & + dew_veg_poly_coeff(1)
+                 ELSE
+                    coeff_dew_veg=un
+                 ENDIF
+              ELSE
+                 coeff_dew_veg=zero
+              ENDIF
+              IF (jv .EQ. 1) THEN
+                 vbeta2(ji,jv) = coeff_dew_veg*tot_bare_soil(ji) ! bare soil
+              ELSE
+                 vbeta2(ji,jv) = coeff_dew_veg*veget(ji,jv)  ! forest 
+             !vbeta2(ji,jv) = veget(ji,jv)
+              ENDIF
+           ELSE
+              vbeta2(ji,jv) = zero
+           ENDIF
+           vbeta(ji) = vbeta(ji) + vbeta2(ji,jv)
+        ENDIF
+        IF ( tosnow(ji) ) vbeta2(ji,jv) = zero
+        
+      ENDDO
+      
+    ENDDO
+
+    !! 9.3.2a  There will be no transpiration when air moisture is too high, under any circumstance
+    !! \latexonly 
+    !!     \input{diffucocomb8.tex}
+    !! \endlatexonly
+    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
+
+    
+    !! 9.3.2b  There will also be no interception loss on bare soil, under any circumstance.
+    !! \latexonly 
+    !!     \input{diffucocomb9.tex}
+    !! \endlatexonly
+    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 jdiffuco_comb
+
+
+
+
+  ! ------------------------------------------------------------------------------------------------
+
+
+
+
+
+  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, vbeta2sum, vbeta3sum)    
+    
+    ! Ajout qsintmax dans les arguments de la routine Nathalie / le 13-03-2006
+
+  !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+    
+    INTEGER(i_std), INTENT(in)                           :: kjpindex   !! Domain size (-)
+    REAL(r_std), INTENT (in)                             :: dtradia    !! Time step (s)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: rau        !! Air Density (kg m^{-3})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: u          !! Eastward Lowest level wind speed (m s^{-1}) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: v          !! Nortward Lowest level wind speed (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: q_cdrag    !! Product of Surface drag coefficient and wind speed (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: pb         !! Lowest level pressure (hPa)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: qair       !! Lowest level specific air humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: temp_sol   !! Skin temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: temp_air   !! Lower air temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: snow       !! Snow mass (kg)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: veget      !! Fraction of vegetation type (fraction)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: lai        !! Leaf area index (m^2 m^{-2})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: qsintmax   !! Maximum water on vegetation (kg m^{-2})
+
+    !! 0.2 Output variables
+    
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)       :: valpha     !! Total Alpha coefficient (-)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)       :: vbeta      !! Total beta coefficient (-)
+
+    !! 0.3 Modified variables 
+    
+    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 (within range 0 to 1)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: vbeta2     !! Beta for interception loss (-)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: vbeta3     !! Beta for Transpiration (-)
+    
+    !! 0.4 Local variables
+    
+    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  
+!_ ================================================================================================================================
+    
+    !! \latexonly 
+    !!     \input{diffucocomb1.tex}
+    !! \endlatexonly
+
+!    vbeta2sum(:) = zero
+!    vbeta3sum(:) = zero
+!    DO jv = 1, nvm
+!      vbeta2sum(:) = vbeta2sum(:) + vbeta2(:,jv)
+!      vbeta3sum(:) = vbeta3sum(:) + vbeta3(:,jv)
+!    ENDDO 
+
+  !! 1. The beta and alpha coefficients are initially set to 1.
+     
+    !! \latexonly 
+    !!     \input{diffucocomb2.tex}
+    !! \endlatexonly
+!    vbeta(:) = un
+    valpha(:) = un
+
+    
+  !! 2. if snow is lower than the critical value:
+    
+    !! \latexonly 
+    !!     \input{diffucocomb3.tex}
+    !! \endlatexonly
+!    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
+!             ! JR insert 131013
+!             vbeta4(ji) = 0.0d0
+!             vbeta2sum(ji) = 0.0d0
+!             vbeta3sum(ji) = 0.0d0
+!             ! end JR insert
+!          END IF
+!
+!      END IF
+!
+!    ENDDO
+
+    
+  !! 3 If we are in presence of dew:
+    !CALL getin_p('DEW_SOL',dew_sol)
+    ! WRITE(*,*) '181113a test, pre call to qsatcalc diffuco line 3403; temp_sol is: ', temp_sol
+    !IF (dew_sol)  THEN 
+        CALL qsatcalc (kjpindex, temp_air, pb, qsatt)
+        ! modified 25/Nov 17:00 temp_sol -> temp_air
+        ! modified 02/Jan 17:43 temp_air -> temp_sol
+        ! modified before Mar 3 we use temp_air to calculate qsatt 
+    !ELSE
+        !CALL qsatcalc (kjpindex, temp_air, pb, qsatt)
+    !ENDIF 
+    !! 9.3.1 Determine where the water goes 
+    !! Determine where the water goes (soil, vegetation, or snow)
+    !! when air moisture exceeds saturation.
+    !! \latexonly 
+    !!     \input{diffucocomb5.tex}
+    !! \endlatexonly
+    toveg(:) = .FALSE.
+    tosnow(:) = .FALSE.
+    DO ji = 1, kjpindex
+        !write(*,*) 'qsatt_dew',qsatt(ji)
+        !write(*,*) 'qair_dew',qair(ji)
+
+      IF ( qsatt(ji) .LT. qair(ji) ) THEN
+          IF (temp_air(ji) .GT. tp_00) THEN
+
+              !! 9.3.1.1  If it is not freezing, 
+              !! If it is not freezing dew is put into the 
+              !! interception reservoir and onto the bare soil.
+              toveg(ji) = .TRUE.
+          ELSE
+
+              !! 9.3.1.2  If it is freezing, 
+              !! If it is freezing water is put into the 
+              !! snow reservoir.
+              tosnow(ji) = .TRUE.
+          ENDIF
+      ENDIF
+    END DO
+
+
+    !! 9.3.1.3 Now modify valpha and vbetas where necessary.
+    
+    !! 9.3.1.3.1 Soil and snow (2d)
+    !! \latexonly 
+    !!     \input{diffucocomb6.tex}
+    !! \endlatexonly
+    DO ji = 1, kjpindex
+      IF ( toveg(ji) ) THEN
+        vbeta1(ji) = zero
+        vbeta4(ji) = tot_bare_soil(ji)
+!        ! 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
+        ! JR insert 131013
+        ! vbeta4(ji) = 0.0d0
+!        vbeta2sum(ji) = 0.0d0
+!        vbeta3sum(ji) = 0.0d0
+        ! end JR insert
+        
+      ENDIF
+      IF ( tosnow(ji) ) THEN
+        vbeta1(ji) = un
+        vbeta4(ji) = zero
+ !       vbeta(ji) = un
+ !       valpha(ji) = un
+        ! JR insert 131013
+        ! vbeta4(ji) = 0.0d0
+ !       vbeta2sum(ji) = 1.0d0
+ !       vbeta3sum(ji) = 0.0d0
+        ! end JR insert
+      ENDIF
+    ENDDO
+
+    !! 9.3.1.3.2 Vegetation (3d)
+    !! \latexonly 
+    !!     \input{diffucocomb7.tex}
+    !! \endlatexonly
+    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
+              
+              ! 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= &
+                         &   dew_veg_poly_coeff(6)*lai(ji,jv)**5 &
+                         & - dew_veg_poly_coeff(5)*lai(ji,jv)**4 &
+                         & + dew_veg_poly_coeff(4)*lai(ji,jv)**3 &
+                         & - dew_veg_poly_coeff(3)*lai(ji,jv)**2 &
+                         & + dew_veg_poly_coeff(2)*lai(ji,jv) &
+                         & + dew_veg_poly_coeff(1)
+                 ELSE
+                    coeff_dew_veg=un
+                 ENDIF
+              ELSE
+                 coeff_dew_veg=zero
+              ENDIF
+              IF (jv .EQ. 1) THEN
+                 vbeta2(ji,jv) = coeff_dew_veg*tot_bare_soil(ji)
+              ELSE
+                 vbeta2(ji,jv) = coeff_dew_veg*veget(ji,jv)
+             !vbeta2(ji,jv) = veget(ji,jv)
+              ENDIF
+           ELSE
+              vbeta2(ji,jv) = zero
+           ENDIF
+  !         vbeta(ji) = vbeta(ji) + vbeta2(ji,jv)
+  !        ! JR insert 131013
+  !         vbeta4(ji) = 0.0d0
+  !         vbeta2sum(ji) = vbeta(ji)
+  !         vbeta3sum(ji) = 0.0d0
+  !        ! end JR insert
+        ENDIF
+        IF ( tosnow(ji) ) vbeta2(ji,jv) = zero
+        
+      ENDDO
+      
+    ENDDO
+
+    !! 9.3.2a  There will be no transpiration when air moisture is too high, under any circumstance
+    !! \latexonly 
+    !!     \input{diffucocomb8.tex}
+    !! \endlatexonly
+    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
+
+    
+    !! 9.3.2b  There will also be no interception loss on bare soil, under any circumstance.
+    !! \latexonly 
+    !!     \input{diffucocomb9.tex}
+    !! \endlatexonly
+    DO ji = 1, kjpindex
+       IF ( qsatt(ji) .LT. qair(ji) ) THEN
+          vbeta2(ji,1) = zero
+       ENDIF
+    ENDDO
+
+!! 3  Now calculate vbeta in all cases (the equality needs to hold for enerbil
+!to be consistent) 
+DO ji = 1, kjpindex 
+        vbeta(ji) = vbeta4(ji) + SUM(vbeta2(ji,:)) + SUM(vbeta3(ji,:)) 
+           IF (vbeta(ji) .LT. min_sechiba) THEN 
+                   vbeta(ji) = zero 
+                   vbeta4(ji) = zero 
+                   vbeta2(ji,:)= zero 
+                   vbeta3(ji,:)= zero 
+            END IF 
+ENDDO  
+
+
+
+
+    IF (long_print) WRITE (numout,*) ' diffuco_comb done '
+
+  END SUBROUTINE diffuco_comb
+
+
+!! ================================================================================================================================
+!! SUBROUTINE	: diffuco_raerod
+!!
+!>\BRIEF	Computes the aerodynamic resistance, for cases in which the
+!! surface drag coefficient is provided by the coupled atmospheric model LMDZ and  when the flag
+!! 'ldq_cdrag_from_gcm' is set to TRUE
+!!
+!! DESCRIPTION	: Simply computes the aerodynamic resistance, for cases in which the
+!! surface drag coefficient is provided by the coupled atmospheric model LMDZ. If the surface drag coefficient
+!! is not provided by the LMDZ or signalled by the flag 'ldq_cdrag_from_gcm' set to FALSE, then the subroutine
+!! diffuco_aero is called instead of this one.
+!!
+!! Calculation of the aerodynamic resistance, for diganostic purposes. First calculate wind speed:
+!! \latexonly 
+!!     \input{diffucoaerod1.tex}
+!! \endlatexonly       
+!!
+!! next calculate ::raero
+!! \latexonly 
+!!     \input{diffucoaerod2.tex}
+!! \endlatexonly
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::raero
+!!
+!! REFERENCE(S)	:
+!! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+!! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+!! Circulation Model. Journal of Climate, 6, pp.248-273
+!! - Guimberteau, M, 2010. ModÃ©lisation de l'hydrologie continentale et influence de l'irrigation
+!! sur le cycle de l'eau, PhD Thesis, available from:
+!! http://www.sisyphe.upmc.fr/~guimberteau/docs/manuscrit_these.pdf
+!!
+!! FLOWCHART    :  None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE diffuco_raerod (kjpindex, u, v, q_cdrag, raero)
+    
+    IMPLICIT NONE
+    
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                     :: kjpindex     !! Domain size (-)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)  :: u            !! Eastward Lowest level wind velocity (m s^{-1}) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)  :: v            !! Northward Lowest level wind velocity (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)  :: q_cdrag      !! Product of Surface drag coefficient and wind speed (m s^{-1})
+    
+    !! 0.2 Output variables 
+    
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: raero        !! Aerodynamic resistance (s m^{-1})
+     
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    
+    INTEGER(i_std)                                 :: ji           !! (-)
+    REAL(r_std)                                    :: speed        !! (m s^{-1})
+!_ ================================================================================================================================
+   
+  !! 1. Simple calculation of the aerodynamic resistance, for diganostic purposes.
+
+    DO ji=1,kjpindex
+
+       !! \latexonly 
+       !!     \input{diffucoaerod1.tex}
+       !! \endlatexonly       
+       speed = MAX(min_wind, wind(ji))
+
+       !! \latexonly 
+       !!     \input{diffucoaerod2.tex}
+       !! \endlatexonly
+       raero(ji) = un / (q_cdrag(ji)*speed)
+       !write(*,*) 'raero',raero(ji)
+       
+    ENDDO
+  
+  END SUBROUTINE diffuco_raerod
+
+!! ================================================================================================================================
+!! SUBROUTINE   : diffuco_ok_inca
+!!
+!>\BRIEF         This subroutine computes biogenic emissions of reactive compounds, that is of
+!!               VOCs (volatile organic compounds) from vegetation and NOx (nitrogen oxides) from soils.
+!!               Calculation are mostly based on the works by Guenther et al. (1995) and Yienger and Levy (1995).\n 
+!!
+!! DESCRIPTION  : Biogenic VOC emissions from vegetation are based on the parameterisations developped by
+!!                Guenther et al. (1995). Biogenic VOCs considered here are: isoprene, monoterpenes, OVOC and ORVOC 
+!!                as bulked emissions, methanol, acetone, acetaldehyde, formaldehyde, acetic acid, formic acid
+!!                as single emissions.\n
+!!                For every biogenic VOCs an emission factor (EF), depending on the PFT considered, is used.\n
+!!                Isoprene emissions depend on temperature and radiation. A partition between sunlit and shaded
+!!                leaves is taken into account and either one (if ok_multilayer = FALSE) or several layers
+!!                (if ok_multilayer = TRUE) in the canopy can be used.\n
+!!                When radiation extinction is considered, the canopy radiative transfer model takes into 
+!!                account light extinction through canopy, calculating first need diffuse and direct radiation
+!!                based on Andrew Friend 2001 radiative model and Spitters et al. 1986. The calculation of lai, 
+!!                parscat, parsh and parsun, laisun and laishabsed based on Guenther et al.(JGR, 1995) and Norman (1982).\n
+!!                Emissions for other BVOCs (monoterpenes, OVOC, ORVOC and other single compounds such as
+!!                methanol, acetone...) depend only on temperature.\n   
+!!                The impact of leaf age, using an emission activity prescribed for each of the 4 leaf age
+!!                classes can also be considered for isoprene and methanol emissions when ok_leafage = TRUE.\n
+!!                NOx emissions from soils are based on Yienger and Levy (1995) and depend on soil moisture
+!!                and temperature and PFT. The pulse effect, related to significant rain occuring after severe
+!!                drought can also be considered (ok_pulse_NOx = TRUE), as well as the increase in emissions related to
+!!                biomass buring (ok_bbgfertil_NOx = TRUE) or use of fertilizers (ok_cropsfertil_NOx = TRUE). 
+!!                A net NO flux is eventually calculated taking into account loss by deposition on the surface, using
+!!                a Canopy Reduction Factor (CRF) based on stomatal and leaf area.\n 
+!!                This subroutine is called by diffuco_main only if biogenic emissions are activated
+!!                for sechiba (flag DIFFUCO_OK_INCA=TRUE).\n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): :: PAR, :: PARsun, :: PARsh, :: laisun, :: laish,
+!!                          :: flx_iso, :: flx_mono, :: flx_ORVOC, :: flx_MBO,
+!!                          :: flx_methanol, :: flx_acetone, :: flx_acetal, :: flx_formal,
+!!                          :: flx_acetic, :: flx_formic, :: flx_no_soil, :: flx_no,
+!!                          :: CRF, :: flx_fertil_no, :: Trans, :: Fdf,
+!!                          :: PARdf, :: PARdr, :: PARsuntab, :: PARshtab
+!!
+!! REFERENCE(S) :
+!! - Andrew Friend (2001), Modelling canopy CO2 fluxes: are 'big-leaf' simplifications justified? 
+!! Global Ecology and Biogeography, 10, 6, 603-619, doi: 10.1046/j.1466-822x.2001.00268.x 
+!! - Spitters, C.J.T, Toussaint, H.A.J.M, Groudriaan, J. (1986), Separating the diffuse and direct
+!! component of global radiation and its implications for modeling canopy photosynthesis, Agricultural
+!! and Forest Meteorology, 38, 1-3, 217-229, doi:10.1016/0168-1923(86)90060-2
+!! - Norman JM (1982) Simulation of microclimates. In: Hatfield JL, Thomason IJ (eds)
+!!  Biometeorology in integrated pest management. Academic, New York, pp 65â99
+!! - Guenther, A., Hewitt, C. N., Erickson, D., Fall, R., Geron, C., Graedel, T., Harley, P.,
+!! Klinger, L., Lerdau, M., McKay, W. A., Pierce, T., Scholes, B., Steinbrecher, R., Tallamraju,
+!! R., Taylor, J. et Zimmerman, P. (1995), A global model of natural volatile organic compound
+!! emissions, J. Geophys. Res., 100, 8873-8892.
+!! - MacDonald, R. et Fall, R. (1993), Detection of substantial emissions of methanol from
+!! plants to the atmosphere, Atmos. Environ., 27A, 1709-1713.
+!! - Guenther, A., Geron, C., Pierce, T., Lamb, B., Harley, P. et Fall, R. (2000), Natural emissions
+!! of non-methane volatile organic compounds, carbon monoxide, and oxides of nitrogen from
+!! North America, Atmos. Environ., 34, 2205-2230.
+!! - Yienger, J. J. et Levy II, H. (1995), Empirical model of global soil-biogenic NOx emissions,
+!! J. Geophys. Res., 100, 11,447-11,464.
+!! - Lathiere, J., D.A. Hauglustaine, A. Friend, N. De Noblet-Ducoudre, N. Viovy, and
+!!  G. Folberth (2006), Impact of climate variability and land use changes on global biogenic volatile 
+!! organic compound emissions, Atmospheric Chemistry and Physics, 6, 2129-2146. 
+!! - Lathiere, J., D.A. Hauglustaine, N. De Noblet-Ducoudre, G. Krinner et G.A. Folberth (2005),
+!! Past and future changes in biogenic volatile organic compound emissions simulated with a global
+!! dynamic vegetation model, Geophysical Research Letters, 32, doi: 10.1029/2005GL024164.
+!! - Lathiere, J. (2005), Evolution des emissions de composes organiques et azotes par la biosphere
+!!  continentale dans le modele LMDz-INCA-ORCHIDEE, These de doctorat, Universite Paris VI.
+!!
+!! FLOWCHART    : None
+!_ ================================================================================================================================
+
+  SUBROUTINE diffuco_inca (kjpindex, dtradia, swdown, sinang, temp_air, temp_sol, ptnlev1, precip_rain, humrel, &
+                        veget_max, lai, frac_age, &
+                        lalo, &
+                        PAR, PARsun, PARsh, laisun, laish, &
+                        flx_iso, flx_mono, flx_ORVOC, flx_MBO, flx_methanol, flx_acetone, flx_acetal, &
+                        flx_formal, flx_acetic, flx_formic, &
+                        flx_no_soil, flx_no,CRF, flx_fertil_no, Fdf, PARsuntab, PARshtab, PARdf, PARdr, Trans)
+
+
+    !! 0. Variables and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                                 :: kjpindex         !! Domain size - terrestrial pixels only (unitless)
+    REAL(r_std), INTENT(in)                                    :: dtradia          !! Time step (seconds)
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in)               :: swdown           !! Down-welling surface short-wave flux 
+                                                                                   !! (W.m^{-2})
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in)               :: sinang           !! Sinus of Solar Angle 
+                                                                                   !! (as computed in read_dim2) (unitless)
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in)               :: temp_air         !! Air temperature (K)
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in)               :: temp_sol         !! Skin temperature (K)
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in)               :: ptnlev1          !! 1st level of soil temperature (K)
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in)               :: precip_rain      !! Rain precipitation !!?? init
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in)           :: humrel           !! Soil moisture stress (0-1, unitless)
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in)           :: veget_max        !! Max. vegetation fraction (0-1, unitless)
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in)           :: lai              !! Leaf area index (m^2.m^{-2})
+    REAL(r_std), DIMENSION(kjpindex,nvm,nleafages), INTENT(in) :: frac_age         !! Age efficacity from STOMATE for iso 
+    REAL(r_std), DIMENSION(kjpindex,2), INTENT(in)             :: lalo             !! Geographical coordinates for pixels (degrees)
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)        :: PAR              !! Photosynthetic active radiation, half of swdown
+                                                                             !! @tex ($\mu mol photons. m^{-2} s^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: PARsun           !! PAR received by sun leaves 
+                                                                             !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: PARsh            !! PAR received by shaded leaves 
+                                                                             !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: laisun           !! Leaf area index of Sun leaves 
+                                                                             !! (m^2.m^{-2})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: laish            !! Leaf area index of Shaded leaves
+                                                                             !! (m^2.m^{-2})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: flx_iso          !! Biogenic isoprene emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: flx_mono         !! Biogenic monoterpene emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: flx_ORVOC        !! Biogenic ORVOC emission - 
+                                                                             !! Other Reactive Volatil Organic Components 
+                                                                             !! (kgC.m^{-2}.s^{-1})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: flx_MBO          !! Biogenic MBO emission 
+                                                                             !! MethylButanOl (kgC.m^{-2}.s^{-1})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: flx_methanol     !! Biogenic methanol emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: flx_acetone      !! Biogenic acetone emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: flx_acetal       !! Biogenic Acetaldehyde emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: flx_formal       !! Biogenic Formaldehyde emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: flx_acetic       !! Biogenic Acetic Acid emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: flx_formic       !! Biogenic Formic Acid emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: flx_no_soil      !! Biogenic NO emission by soil (kgC.m^{-2}.s^{-1})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: flx_no           !! Biogenic total NO emission (kgC.m^{-2}.s^{-1})
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)    :: CRF              !! Canopy reduction factor 
+                                                                             !! for net NO flux calculation 
+   REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)     :: flx_fertil_no    !! Biogenic NO emission due to N-fertilisation 
+                                                                             !! (kgC.m^{-2}.s^{-1})
+    !!Canopy radiative transfer model
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)         :: Trans           !! Atmospheric Transmissivity (unitless)
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)         :: Fdf             !! Diffuse Fraction of the radiation (0-1, unitless)
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)         :: PARdf           !! Diffuse PAR
+                                                                             !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)         :: PARdr           !! Direct PAR 
+                                                                             !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+    !! for multilayer canopy model for iso flux
+    REAL(r_std), DIMENSION(kjpindex,nlai+1), INTENT(out)  :: PARsuntab       !! PAR received by sun leaves 
+                                                                             !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex,nlai+1), INTENT(out)  :: PARshtab        !! PAR received by shaded leaves 
+                                                                             !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables 
+
+    INTEGER(i_std)                             :: ji, jv, jf, jl    !! Indices (unitless)
+    REAL(r_std), DIMENSION(kjpindex,nvm)       :: fol_dens          !! foliar density (gDM.m^{-2})
+    REAL(r_std), DIMENSION(kjpindex)           :: tleaf             !! Foliar temperature (K)
+    REAL(r_std), DIMENSION(kjpindex)           :: t_no              !! Temperature used for soil NO emissions (C)
+    REAL(r_std), DIMENSION(kjpindex)           :: exp_1             !! First exponential used in the calculation of 
+                                                                    !! isoprene dependancy to Temperature 
+    REAL(r_std), DIMENSION(kjpindex)           :: exp_2             !! Second exponential used in the calculation of 
+                                                                    !! Isoprene dependancy to Temperature
+    REAL(r_std), DIMENSION(kjpindex)           :: Ct_iso            !! Isoprene dependancy to Temperature
+    REAL(r_std), DIMENSION(kjpindex)           :: Cl_iso            !! Isoprene dependancy to Light 
+    REAL(r_std), DIMENSION(kjpindex)           :: Ct_mono           !! Monoterpene dependancy to Temperature
+    REAL(r_std), DIMENSION(kjpindex)           :: Ct_MBO            !! MBO dependance to Temperature
+    REAL(r_std), DIMENSION(kjpindex)           :: Cl_MBO            !! MBO dependance to Light
+    REAL(r_std), DIMENSION(kjpindex)           :: Xvar              !! Parameter used in the calculation 
+                                                                    !! of MBO dependance to Temperature
+    REAL(r_std), DIMENSION(kjpindex,nvm)       :: flx_OVOC          !! Biogenic OVOC emission - 
+                                                                    !! Other Volatil Organic Components (kgC.m^{-2}.s^{-1})
+    !!Canopy radiative transfer model
+    REAL(r_std)                                :: day               !! Day of The Year
+    REAL(r_std), DIMENSION(kjpindex)           :: So                !! Maximum radiation at the Earth surface (W.m^{-2})
+    REAL(r_std), DIMENSION(kjpindex)           :: Rfrac             !! Parameter in the regression of diffuse 
+                                                                    !! share on transmission
+    REAL(r_std), DIMENSION(kjpindex)           :: Kfrac             !! Parameter in the regression of diffuse 
+                                                                    !! share on transmission
+    REAL(r_std), DIMENSION(kjpindex)           :: swdf              !! Sw diffuse radiation (W.m^{-2}) 
+    REAL(r_std), DIMENSION(kjpindex)           :: swdr              !! Sw direct radiation (W.m^{-2}) 
+    REAL(r_std), DIMENSION(kjpindex,nvm)       :: PARscat           !! Scatter PAR @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex,nvm)       :: Clsun_iso         !! Isoprene dependance to light for sun leaves 
+    REAL(r_std), DIMENSION(kjpindex,nvm)       :: Clsh_iso          !! Isoprene dependance to light for shaded leaves
+    !! for multilayer canopy model for iso flux
+    REAL(r_std), DIMENSION(kjpindex,nlai+1)    :: PARscattab        !! Scatter PAR @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+    REAL(r_std), DIMENSION(nlai+1)             :: laitab            !! LAI per layer (m^2.m^{-2})
+    REAL(r_std), DIMENSION(kjpindex,nlai+1)    :: laisuntab         !! LAI of sun leaves per layer (m^2.m^{-2})
+    REAL(r_std), DIMENSION(kjpindex,nlai+1)    :: laishtab          !! LAI of shaded leaves per layer 
+                                                                    !! (m^2.m^{-2})
+    REAL(r_std)                                :: Clsun_iso_tab     !! Isoprene dependance to light 
+                                                                    !! for sun leaves and per layer 
+    REAL(r_std)                                :: Clsh_iso_tab      !! Isoprene dependance to light 
+                                                                    !! for shaded leaves and per layer
+    !!Leaf age
+    REAL(r_std), DIMENSION(kjpindex,nvm)       :: Eff_age_iso       !! Isoprene emission dependance to Leaf Age 
+    REAL(r_std), DIMENSION(kjpindex,nvm)       :: Eff_age_meth      !! Methanol emission dependance to Leaf Age 
+    REAL(r_std), DIMENSION(kjpindex,nvm)       :: Eff_age_VOC       !! Other VOC emission dependance to Leaf Age 
+    !!BBG and Fertilizers for NOx soil emission
+    REAL(r_std), DIMENSION(kjpindex)           :: veget_max_nowoody !! sum of veget_max for non-woody PFT
+    REAL(r_std), DIMENSION(kjpindex,nvm)       :: N_qt_WRICE_pft    !! N fertiliser on RICE 
+                                                                    !! (kgN per year per grid cell)
+    REAL(r_std), DIMENSION(kjpindex,nvm)       :: N_qt_OTHER_pft    !! N fertiliser on other veg 
+                                                                    !! (kgN per year per grid cell)
+
+
+    !! 0.5 Parameters values
+
+    REAL(r_std), PARAMETER :: CT1 = 95000.0       !! Empirical coeffcient (see Guenther .et. al, 1995, eq(10)) (J.mol^{-1})
+    REAL(r_std), PARAMETER :: CT2 = 230000.0      !! Empirical coefficient (see Guenther .et. al, 1995, eq(10)) (J.mol^{-1})
+    REAL(r_std), PARAMETER :: TS = 303.0          !! Leaf temperature at standard condition
+                                                  !! (see Guenther .et. al, 1995, eq(10)) (K)
+    REAL(r_std), PARAMETER :: TM = 314.0          !! Leaf temperature (see Guenther .et. al, 1995, eq(10)) (K)
+
+    REAL(r_std), PARAMETER :: alpha_ = 0.0027     !! Empirical coeffcient (see Guenther .et. al, 1995, eq(9)) (unitless)
+    REAL(r_std), PARAMETER :: CL1 = 1.066         !! Empirical coeffcient (see Guenther .et. al, 1995, eq(9)) (unitless)
+    REAL(r_std), PARAMETER :: beta = 0.09         !! Empirical coeffcient (see Guenther .et. al, 1995, eq(11)) (K^{-1})
+    REAL(r_std), PARAMETER :: lai_threshold = 11. !! Lai threshold for the calculation of scattered radiation
+                                                  !! based on Guenther .et. al (1995) (m^2.m^{-2})
+
+!_ ================================================================================================================================
+
+    !! 1. Canopy radiative transfer model
+
+    !! Canopy radiative transfer model: takes into account light extinction through canopy
+    !! First need to calculate diffuse and direct radiation
+    !! Based on Andrew Friend radiative model (Global Ecology & Biogeography, 2001)
+    !! And Spitters et al. (Agricultural and Forest Meteorology, 1986)
+       !! As in diffuco_trans_co2 one could use the direct LAI layers without
+       !! using the artifical LAI layers (laitab). For that you need to run
+       !! ORCHIDEE in DOFOCO mode but then you could use directly the absorbed
+       !! light per layer (for more information look at diffuco_trans_co2 and
+       !the
+       !! module albedo.f90
+
+
+    IF ( control%ok_radcanopy ) THEN
+
+       DO ji = 1, kjpindex
+          IF (sinang(ji) .GT. zero) THEN
+             day = julian_diff
+             !! 1.1 Extra-terrestrial solar irradiance at a plan parallel to Earh's surface
+             So(ji) = Sct*( un + 0.033*COS(360.*pi/180.*day/365.))*sinang(ji)
+             !! 1.2 Atmospheric transmissivity
+             Trans(ji) = swdown(ji)/So(ji)
+             !! 1.3 Empirical calculation of fraction diffuse from transmission based on Spitters et al. (1986)
+             Rfrac(ji) = 0.847 - 1.61*sinang(ji) + 1.04*(sinang(ji)**2.)
+             Kfrac(ji) = (1.47 - Rfrac(ji)*Rfrac(ji))/1.66      
+             IF (Trans(ji) .LE. 0.22) THEN
+                Fdf(ji) = un
+             ELSE IF (Trans(ji) .LE. 0.35) THEN
+                Fdf(ji) = un - 6.4*((Trans(ji) - 0.22)**2.) 
+             ELSE IF (Trans(ji) .LE. Kfrac(ji)) THEN
+                Fdf(ji) = 1.47 - 1.66*Trans(ji)
+             ELSE
+                Fdf(ji) = Rfrac(ji)
+             END IF
+             !! 1.4 Direct and diffuse sw radiation in W.m^{-2}
+             swdf(ji) = swdown(ji)*Fdf(ji)
+             swdr(ji) = swdown(ji)*(un-Fdf(ji))
+          ELSE
+             swdf(ji) = zero
+             swdr(ji) = zero
+          END IF
+
+          !! 1.5 PAR diffuse and direct in umol/m^2/s
+          PARdf(ji) = swdf(ji) * W_to_mmol * RG_to_PAR
+          PARdr(ji) = swdr(ji) * W_to_mmol * RG_to_PAR 
+       END DO
+
+       !! 1.6 Calculation of lai, parscat, parsh and parsun, laisun and laish !!?? define the terms
+       !! Based on Guenther et al. (JGR, 1995) and Norman (1982)
+       !! One-layer canopy model or multi-layer canopy model
+       IF (control%ok_multilayer) THEN 
+
+
+          ! Calculation PER LAYER
+          DO jl = 1, nlai+1
+             laitab(jl) = laimax*(EXP(lai_level_depth*REAL(jl-1,r_std)) - un)/(EXP(lai_level_depth*REAL(nlai,r_std)) - un)
+
+             DO ji = 1, kjpindex
+                IF (laitab(jl) .LE. lai_threshold) THEN
+                   PARscattab(ji,jl) = 0.07*PARdr(ji)*(1.1 - 0.1*laitab(jl))*exp(-sinang(ji))
+                ELSE
+                   PARscattab(ji,jl) = zero
+                END IF
+
+                IF (sinang(ji) .NE. zero ) THEN
+                   PARshtab(ji,jl) = PARdf(ji)*exp(-0.5*((laitab(jl))**0.7)) + PARscattab(ji,jl)
+                   PARsuntab(ji,jl) = PARdr(ji)*COS(60.*pi/180.)/sinang(ji) + PARshtab(ji,jl)
+                ELSE
+                   PARshtab(ji,jl) = PARdf(ji)*exp(-0.5*(laitab(jl)**0.7)) + PARscattab(ji,jl)
+                   PARsuntab(ji,jl) = zero 
+                END IF
+                IF (ABS(ACOS(sinang(ji))) .LT. pi/2. .AND. sinang(ji) .NE. zero) THEN 
+                   ! calculation corrected for multi-layer canopy model from Friend (2001)
+                   laisuntab(ji,jl) = laitab(jl)*exp(-0.5*laitab(jl)) 
+                   laishtab(ji,jl) = laitab(jl) - laisuntab(ji,jl)
+                ELSE
+                   laisuntab(ji,jl) = zero
+                   laishtab(ji,jl) = laitab(jl)
+                END IF
+             END DO
+          END DO
+       ELSE
+          ! Calculation FOR one layer
+          DO jv = 1, nvm
+             DO ji = 1, kjpindex
+                IF (lai(ji,jv) .LE. lai_threshold) THEN
+                   PARscat(ji,jv) = 0.07*PARdr(ji)*(1.1 - 0.1*lai(ji,jv))*exp(-sinang(ji))
+                ELSE
+                   PARscat(ji,jv) = zero
+                END IF
+
+                IF (sinang(ji) .NE. zero ) THEN
+                   PARsh(ji,jv) = PARdf(ji)*exp(-0.5*((lai(ji,jv))**0.7)) + PARscat(ji,jv)
+                   PARsun(ji,jv) = PARdr(ji)*COS(60.*pi/180.)/sinang(ji) + PARsh(ji,jv)
+                ELSE
+                   PARsh(ji,jv) = PARdf(ji)*exp(-0.5*(lai(ji,jv)**0.7)) + PARscat(ji,jv)
+                   PARsun(ji,jv) = zero 
+                END IF
+                IF (ABS(ACOS(sinang(ji))) .LT. pi/2. .AND. sinang(ji) .NE. zero) THEN 
+                   ! calculation as in Lathiere (2005) = with correction removing lai in Guenther (1995)
+                   laisun(ji,jv) = (un - exp(-0.5*lai(ji,jv)/(sinang(ji))))*sinang(ji)/COS(60.*pi/180.)
+                   laish(ji,jv) = lai(ji,jv) - laisun(ji,jv)
+                ELSE
+                   laisun(ji,jv) = zero
+                   laish(ji,jv) = lai(ji,jv)
+                END IF
+             END DO
+          END DO
+       ENDIF
+    END IF
+
+
+    !! 2. Calculation of non-PFT dependant parameters used for VOC emissions
+    DO ji = 1, kjpindex ! (loop over # pixels)
+       !! 2.1 Calculation of Tleaf (based on Lathiere, 2005)
+       IF ((temp_sol(ji) - temp_air(ji)) .GT. 2) THEN
+          tleaf(ji) = temp_air(ji) + 2
+       ELSE IF ((temp_sol(ji) - temp_air(ji)) .LT. -2) THEN
+          tleaf(ji) = temp_air(ji) - 2
+       ELSE
+          tleaf(ji) = temp_sol(ji)
+       END IF
+
+       !! 2.2 Isoprene emission dependency - with no PARsun/PARshaded partitioning - Guenther et al. (1995) and Lathiere (2005)
+       !> @codeinc $$?? ecrire les equation en latex ? 
+       exp_1(ji) = exp( (CT1 * ( tleaf(ji) - TS )) / (RR*TS*tleaf(ji)) )
+       exp_2(ji) = exp( (CT2 *( tleaf(ji) - TM )) / (RR*TS*tleaf(ji)) )
+       PAR(ji)   = swdown(ji) * W_to_mmol * RG_to_PAR        ! from W/m^2 to umol photons/m^2/s and half of sw for PAR
+       Ct_iso(ji)    = exp_1(ji)/(un + exp_2(ji))            ! temperature dependance  
+       Cl_iso(ji)    = alpha_*CL1*PAR(ji)/sqrt(un + (alpha_**2) * (PAR(ji)**2) ) ! light dependance
+       !> @endcodeinc
+       !! 2.3 Monoterpene emission dependency to Temperature
+       !> @codeinc
+       Ct_mono(ji) = exp(beta*(tleaf(ji) - TS))
+       !> @endcodeinc
+       !! 2.4 MBO biogenic emissions dependency, only from PFT7 and PFT4 for location of vegetation emitter
+       ! but in fact MBO fluxes only in America (ponderosa and lodgepole pines only found in these areas)
+       !> @codeinc
+       Xvar(ji) = ((un/312.3) - (un/tleaf(ji)))/RR
+       !> @endcodeinc
+       !! 2.4.1 temperature dependency
+       !> @codeinc
+       Ct_MBO(ji)    = (1.52*209000.0*exp(67000.0*Xvar(ji)))/(209000.0 - 67000.0*(un - exp(209000.0*Xvar(ji))))
+       !> @endcodeinc
+       !! 2.4.2 light dependency
+       Cl_MBO(ji)    = (0.0011*1.44*PAR(ji))/(sqrt(un + (0.0011**2)*(PAR(ji)**2)))
+       !! 2.5 NO biogenic emissions given in ngN/m^2/s, emission factor in ngN/m^2/s too
+       !! calculation of temperature used for NO soil emissions
+       t_no(ji) = ptnlev1(ji) - ZeroCelsius  !!temp must be in celsius to calculate no emissions
+       !! 2.6 calculation of non-woody veget_max fraction
+       IF (control%ok_cropsfertil_NOx) THEN
+          veget_max_nowoody(ji) = zero
+          DO jv = 1,nvm
+             IF ( (jv /= ibare_sechiba) .AND. .NOT.(is_tree(jv)) ) THEN
+                veget_max_nowoody(ji) = veget_max_nowoody(ji) + veget_max(ji,jv)
+             ENDIF
+          ENDDO
+       END IF
+    END DO ! (loop over # pixels)
+
+    !! 3. Calculation of PFT dependant parameters and
+    ! Calculation of VOC emissions flux
+
+    Eff_age_iso(:,:) = zero
+    Eff_age_meth(:,:) = zero
+
+    DO jv = 1, nvm
+       DO ji = 1, kjpindex
+
+          IF(veget_max(ji,jv) == zero)THEN
+              ! this vegetation type is not present, so no reason to do the 
+              ! calculation
+              CYCLE
+          ENDIF
+
+          ! 6-Calculation of Leaf Age Function (Lathiere 2005)
+          IF ( control%ok_leafage ) THEN
+             DO jf = 1, nleafages
+                !> @codeinc
+                Eff_age_iso(ji,jv) = Eff_age_iso(ji,jv) + frac_age(ji,jv,jf)*iso_activity(jf)
+                Eff_age_meth(ji,jv) = Eff_age_meth(ji,jv) + frac_age(ji,jv,jf)*methanol_activity(jf)
+                !> @endcodeinc 
+             END DO
+             !> @codeinc
+             Eff_age_VOC(ji,jv) = un
+             !> @endcodeinc
+          ELSE
+             Eff_age_iso(ji,jv) = un
+             Eff_age_meth(ji,jv) = un
+             Eff_age_VOC(ji,jv) = un
+          END IF
+          !! 5. Calculation of foliar density
+          IF ( sla(jv) .eq. zero ) THEN
+             fol_dens(ji,jv) = zero
+          ELSE
+             ! 2 factor for conversion from gC to gDM
+             fol_dens(ji,jv) = 2 * lai(ji,jv)/sla(jv)
+          ENDIF
+          !! 6. Calculation of VOC emissions from vegetation
+          IF ( control%ok_radcanopy ) THEN
+             ! if multi-layer canopy model
+             IF (control%ok_multilayer) THEN 
+                flx_iso(ji,jv) = zero
+                laisun(ji,jv) = zero
+                laish(ji,jv) = zero
+                ! loop over the NLAI canopy layers
+                DO jl = 1, nlai
+                   IF ((laitab(jl) .LE. lai(ji,jv)).AND.(lai(ji,jv).NE.zero)) THEN
+                      !sunlit vegetation 
+                      Clsun_iso_tab   = alpha_*CL1*PARsuntab(ji,jl)/sqrt(un + (alpha_**2) * (PARsuntab(ji,jl)**2) )
+                      ! shaded vegetation
+                      Clsh_iso_tab    = alpha_*CL1*PARshtab(ji,jl)/sqrt(un + (alpha_**2) * (PARshtab(ji,jl)**2) ) 
+
+                      !                  flx_iso(ji,jv) = flx_iso(ji,jv) + ((laisuntab(ji,jl+1)-laisuntab(ji,jl))*Clsun_iso_tab+ &
+                      !                       & (laishtab(ji,jl+1)-laishtab(ji,jl))*Clsh_iso_tab)* &
+                      !                       & fol_dens(ji,jv)*Ct_iso(ji)*em_factor_isoprene(jv)* &
+                      !                       & Eff_age_iso(ji,jv)*1e-9/one_hour
+                      !
+                      flx_iso(ji,jv) = flx_iso(ji,jv) + ((laisuntab(ji,jl+1) - laisuntab(ji,jl))*Clsun_iso_tab+ &
+                           & (laishtab(ji,jl+1) - laishtab(ji,jl))*Clsh_iso_tab)* &
+                           & fol_dens(ji,jv)/lai(ji,jv)*Ct_iso(ji)*em_factor_isoprene(jv)* &
+                           & Eff_age_iso(ji,jv)*1e-9/one_hour
+
+                      laisun(ji,jv) = laisuntab(ji,jl)
+                      laish(ji,jv)  = laishtab(ji,jl)
+                   END IF
+                END DO
+                ! if mono-layer canopy model
+             ELSE
+                !sunlit vegetation 
+                Clsun_iso(ji,jv)   = alpha_*CL1*PARsun(ji,jv)/sqrt(un + (alpha_**2) * (PARsun(ji,jv)**2) )
+                ! shaded vegetation      
+                Clsh_iso(ji,jv)    = alpha_*CL1*PARsh(ji,jv)/sqrt(un + (alpha_**2) * (PARsh(ji,jv)**2) )       
+                IF (lai(ji,jv) .NE. zero) THEN
+                   flx_iso(ji,jv) = (laisun(ji,jv)*Clsun_iso(ji,jv) + laish(ji,jv)*Clsh_iso(ji,jv))* &
+                        & fol_dens(ji,jv)/lai(ji,jv)*Ct_iso(ji)*em_factor_isoprene(jv)* &
+                        & Eff_age_iso(ji,jv)*1e-9/one_hour
+                ELSE
+                   ! 
+                   flx_iso(ji,jv) = zero
+                END IF
+             END IF
+             ! if no light extinction due to vegetation  
+          ELSE
+             !! Isoprene emissions - general equation
+             !> @codeinc
+             flx_iso(ji,jv) = fol_dens(ji,jv)*Ct_iso(ji)*Cl_iso(ji)*Eff_age_iso(ji,jv)*em_factor_isoprene(jv)*1e-9/one_hour
+             !> @endcodeinc
+          END IF
+          !! 6.2 Calculation of monoterpene biogenic emissions
+          !> @codeinc
+          flx_mono(ji,jv) = fol_dens(ji,jv)*em_factor_monoterpene(jv)*Ct_mono(ji)*Eff_age_VOC(ji,jv)*1e-9/one_hour
+          !> @endcodeinc
+          !! 6.3 Calculation of ORVOC biogenic emissions
+          !! Other Reactive Volatile Organic Compounds
+          !> @codeinc
+          flx_ORVOC(ji,jv) = fol_dens(ji,jv)*em_factor_ORVOC(jv)*Ct_mono(ji)*Eff_age_VOC(ji,jv)*1e-9/one_hour
+          !> @endcodeinc
+          !! 6.4 Calculation of OVOC biogenic emissions
+          !! Other Volatile Organic Compounds
+          flx_OVOC(ji,jv) = fol_dens(ji,jv)*em_factor_OVOC(jv)*Ct_mono(ji)*Eff_age_VOC(ji,jv)*1e-9/one_hour
+          !! 6.5 Calculation of MBO biogenic emissions
+          !! 2-Methyl-3-Buten-2-ol 
+          IF(lalo(ji,1) .GE. 20. .AND. lalo(ji,2) .LE. -100) THEN
+             flx_MBO(ji,jv) = fol_dens(ji,jv)*em_factor_MBO(jv)*Ct_MBO(ji)*Cl_MBO(ji)*Eff_age_VOC(ji,jv)*1e-9/one_hour
+          ELSE
+             flx_MBO(ji,jv) = zero
+          END IF
+          !! 6.6 Calculation of methanol biogenic emissions
+          flx_methanol(ji,jv) = fol_dens(ji,jv)*em_factor_methanol(jv)*Ct_mono(ji)*Eff_age_meth(ji,jv)*1e-9/one_hour
+          !! 6.7 Calculation of acetone biogenic emissions
+          flx_acetone(ji,jv) = fol_dens(ji,jv)*em_factor_acetone(jv)*Ct_mono(ji)*Eff_age_VOC(ji,jv)*1e-9/one_hour
+          !! 6.8 Calculation of acetaldehyde biogenic emissions
+          flx_acetal(ji,jv) = fol_dens(ji,jv)*em_factor_acetal(jv)*Ct_mono(ji)*Eff_age_VOC(ji,jv)*1e-9/one_hour
+          !! 6.9 Calculation of formaldehyde biogenic emissions
+          flx_formal(ji,jv) = fol_dens(ji,jv)*em_factor_formal(jv)*Ct_mono(ji)*Eff_age_VOC(ji,jv)*1e-9/one_hour
+          !! 6.10 Calculation of acetic acid biogenic emissions
+          flx_acetic(ji,jv) = fol_dens(ji,jv)*em_factor_acetic(jv)*Ct_mono(ji)*Eff_age_VOC(ji,jv)*1e-9/one_hour
+          !! 6.11 Calculation of formic acid biogenic emissions
+          flx_formic(ji,jv) = fol_dens(ji,jv)*em_factor_formic(jv)*Ct_mono(ji)*Eff_age_VOC(ji,jv)*1e-9/one_hour
+       END DO
+
+    END DO
+
+
+    !! 7. Calculation of NOx emissions from soils
+    ! Based on Yienger & Levy (1995) and Lathiere (2005, chapter 3)
+    DO ji = 1, kjpindex
+       !! 7.1 Precipitation-related pulse function
+       IF (control%ok_pulse_NOx) THEN
+          ! if we are during a period where pulses are not allowed
+          IF (ok_siesta(ji)) THEN
+             ! if this period is not over 
+             IF (FLOOR(siestaday(ji)) .LE. siestalim(ji)) THEN
+                siestaday(ji) = siestaday(ji) + (dtradia/one_day)
+                ! if this period is over
+             ELSE
+                ok_siesta(ji) = .FALSE.
+                siestaday(ji) = zero
+             END IF
+          END IF
+          ! if we are during a period where pulses are allowed
+          IF ((.NOT. ok_siesta(ji)) .AND. (.NOT. allow_pulse(ji))) THEN
+             IF (humrel(ji,1) .LT. 0.15) THEN
+                ! if precip exceeds 1 mm/day over one time step => a pulse occurs
+                IF(precip_rain(ji)/nbre_precip .GE. un/(one_day/dtradia)) THEN
+                   ! if precip is up to 5 mm/day => pulse length is 3 days
+                   IF (precip_rain(ji)/nbre_precip .LT. 5./(one_day/dtradia)) THEN
+                      pulselim(ji) = 3.
+                      ! if precip is up to 15 mm/day => pulse length is 7 days
+                   ELSE IF (precip_rain(ji)/nbre_precip .LT. 15./(one_day/dtradia)) THEN
+                      pulselim(ji) = 7.
+                      ! if precip is upper than 15 mm/day => pulse length is 14 days
+                   ELSE IF (precip_rain(ji)/nbre_precip .GE. 15./(one_day/dtradia)) THEN
+                      pulselim(ji) = 14.
+                   END IF
+                   allow_pulse(ji)=.TRUE.
+                   pulseday(ji) = un
+                END IF
+             END IF
+          END IF
+          ! if we were during a pulse period
+          IF (allow_pulse(ji)) THEN
+             ! if we are still during the pulse period
+             ! 16/06/2010 We assume a (pulselim-1) days for the pulse length (NVui+Jlath)
+             IF(FLOOR(pulseday(ji)) .LT. pulselim(ji)) THEN
+                ! calculation of the pulse function
+                IF (pulselim(ji).EQ.3) THEN
+                   pulse(ji) = 11.19*exp(-0.805*pulseday(ji))
+                ELSE IF (pulselim(ji).EQ.7) THEN
+                   pulse(ji) = 14.68*exp(-0.384*pulseday(ji))
+                ELSE IF (pulselim(ji).EQ.14) THEN 
+                   pulse(ji) = 18.46*exp(-0.208*pulseday(ji))
+                END IF
+                pulseday(ji) = pulseday(ji) + (dtradia/one_day)
+                ! if the pulse period is over
+             ELSE
+                ! pulse function is set to 1 
+                pulse(ji) = un
+                allow_pulse(ji) = .FALSE.
+                siestaday(ji) = un
+                siestalim(ji) = pulselim(ji)
+                ok_siesta(ji) = .TRUE. 
+             END IF
+          END IF
+          ! no precipitation-related pulse function
+       ELSE
+          pulse(ji) = un
+       END IF
+    END DO
+
+    !! 7.2 Calculation of NO basal emissions including pulse effect
+    DO jv = 1, nvm
+       DO ji = 1, kjpindex
+
+          IF(veget_max(ji,jv) == zero)THEN
+              ! this vegetation type is not present, so no reason to do the 
+              ! calculation
+              CYCLE
+          ENDIF
+
+          !Tropical forests
+          IF ( is_tropical(jv) .AND. is_evergreen(jv) ) THEN
+             ! Wet soils
+             IF (humrel(ji,1) .GT. 0.3) THEN
+                flx_no_soil(ji,jv) = 2.6*pulse(ji)
+                ! Dry soils
+             ELSE
+                flx_no_soil(ji,jv) = 8.6*pulse(ji)
+             END IF
+             !Else If agricultural lands OR Wet soils
+          ELSE IF ( ( .NOT.(natural(jv)) ) .OR. ( humrel(ji,1) .GT. 0.3 ) ) THEN
+             ! Calculation of NO emissions depending of Temperature
+             IF (t_no(ji) .LT. zero) THEN
+                flx_no_soil(ji,jv) = zero
+             ELSE IF (t_no(ji) .LE. 10.) THEN
+                flx_no_soil(ji,jv) = 0.28*em_factor_no_wet(jv)*t_no(ji)*pulse(ji)
+             ELSE IF (t_no(ji) .LE. 30.) THEN
+                flx_no_soil(ji,jv) = em_factor_no_wet(jv)*exp(0.103*t_no(ji))*pulse(ji)
+             ELSE
+                flx_no_soil(ji,jv) = 21.97*em_factor_no_wet(jv)*pulse(ji)
+             END IF
+             !Else if Temp negative
+          ELSE IF (t_no(ji) .LT. zero) THEN
+             flx_no_soil(ji,jv) = zero
+             !Else if Temp <= 30
+          ELSE IF (t_no(ji) .LE. 30.) THEN
+             flx_no_soil(ji,jv) = (em_factor_no_dry(jv)*t_no(ji))/30.*pulse(ji)
+          ELSE
+             flx_no_soil(ji,jv) = em_factor_no_dry(jv)*pulse(ji)
+          END IF
+
+          !! 7.3 IF ACTIVATED (ok_bbgfertil_NOx = TRUE) calculation of NOx soil emission increase due to biomass burning
+          ! Calculation of Biomass-Burning-induced NOx emissions (Lathiere, 2005)
+          ! => NOx emissions 3-fold increase
+          IF (control%ok_bbgfertil_NOx) THEN
+             IF ( natural(jv) ) THEN
+                ! North Tropical zone from May to June
+                IF ((lalo(ji,1) .LE. 30. .AND. lalo(ji,1) .GE. zero).AND. &
+                     (day .GE. 121. .AND. day .LE. 181).AND.(flx_co2_bbg_year(ji) .GT. 0.1)) THEN
+                   flx_no_soil(ji,jv) = flx_no_soil(ji,jv)*3.
+                   ! South Tropical zone from November to December
+                ELSE IF ((lalo(ji,1) .GE. -30. .AND. lalo(ji,1) .LT. zero).AND.(day .GE. 305.).AND. & 
+                        (flx_co2_bbg_year(ji) .GT. 0.1)) THEN
+                   flx_no_soil(ji,jv) = flx_no_soil(ji,jv)*3.
+                END IF
+             END IF
+          END IF
+
+          !! 7.4 IF ACTIVATED (ok_cropsfertil_NOx = TRUE) calculation of NOx soil emission increase due to fertilizer use 
+          ! Calculation of N-fertiliser-induced NOx emissions
+          flx_fertil_no(ji,jv) = zero
+          IF (control%ok_cropsfertil_NOx) THEN
+             IF (veget_max_nowoody(ji) .NE. zero) THEN
+                ! Non-agricultural lands
+                IF ( (jv == ibare_sechiba) .OR. is_tree(jv) ) THEN
+                   N_qt_WRICE_pft(ji,jv) = zero
+                   N_qt_OTHER_pft(ji,jv) = zero
+                ! Grasslands or Croplands
+                ELSE
+                   N_qt_WRICE_pft(ji,jv) = N_qt_WRICE_year(ji)*veget_max(ji,jv)/veget_max_nowoody(ji)
+                   N_qt_OTHER_pft(ji,jv) = N_qt_OTHER_year(ji)*veget_max(ji,jv)/veget_max_nowoody(ji)
+                END IF
+             ELSE
+                N_qt_WRICE_pft(ji,jv) = zero
+                N_qt_OTHER_pft(ji,jv) = zero
+             END IF
+
+             ! North temperate regions from May to August
+             ! OR South Temperate regions from November to February
+             IF (((lalo(ji,1) .GT. 30.) .AND. (day .GE. 121. .AND. day .LE. 243.).AND.(veget_max(ji,jv) .NE. zero)) .OR. & 
+             &  ((lalo(ji,1) .LT. -30.) .AND. (day .GE. 305. .OR. day .LE. 59.) .AND.(veget_max(ji,jv) .NE. zero))) THEN
+                ! 1e12 for conversion from kg to Ng
+                ! 1/(365/12*24*60*60*4) for conversion from year to seconds corrected for 4 months of emissions
+                flx_fertil_no(ji,jv) = (N_qt_WRICE_pft(ji,jv)*(1/30.)+N_qt_OTHER_pft(ji,jv))*(2.5/100.) &
+                     & *1e12/(365*24*60*60*4/12)/(area2(ji)*veget_max(ji,jv))
+                ! OR Tropical regions all the year
+             ELSE IF ((lalo(ji,1) .GE. -30.).AND.(lalo(ji,1) .LE. 30.).AND.(veget_max(ji,jv) .NE. zero)) THEN
+                flx_fertil_no(ji,jv) = (N_qt_WRICE_pft(ji,jv)*(1/30.)+N_qt_OTHER_pft(ji,jv))*(2.5/100.) &
+                     & *1e12/(365*24*60*60)/(area2(ji)*veget_max(ji,jv))
+             END IF
+             flx_no_soil(ji,jv) = flx_no_soil(ji,jv) + flx_fertil_no(ji,jv)
+          END IF
+
+          !! 7.5 Calculation of net NO flux above soil accounting for surface deposition, 
+          !! based on the Canopy Reduction Factor (CRF), calculated using Leaf Area and Stomatal Area
+          !kc=cuticle absorptivity = 0.24m^2/m^2
+          !ks=stomatal absorptivity = 8.75m^2/m^2
+          !Larch=Larcher SAI/LAI ratio given in Larcher 1991
+          !> @codeinc
+          CRF(ji,jv) = (exp(-8.75*Larch(jv)*lai(ji,jv)) + exp(-0.24*lai(ji,jv)))/2.
+          flx_no(ji,jv) = flx_no_soil(ji,jv)*CRF(ji,jv)
+          !> @endcodeinc
+       END DO
+    END DO
+    IF (long_print) WRITE(numout,*) 'OK diffuco inca'
+
+!WRITE(*,*) 'PAR', PAR
+
+  END SUBROUTINE diffuco_inca
+
+!! ================================================================================================================================
+!! SUBROUTINE   : diffuco_inca_read
+!!
+!>\BRIEF         This subroutine will read and interpolate the data set of CO2 emissions from biomass burning.\n
+!!
+!! DESCRIPTION  :  This subroutine will interpolate the 1 x 1 deg based data set of CO2 emissions from biomass burning
+!!                 expresssed in kgC/m^2 per year (=> density = TRUE), N fertiliser amount expressed in kgN per year and
+!!                 per grid cell (=> density = FALSE) to the resolution of the model.\ n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): :: data_year
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!_ ================================================================================================================================
+
+  SUBROUTINE diffuco_inca_read (nbpt, lalo, neighbours, resolution, data_year, filename, filename2, fieldname, density)
+
+    IMPLICIT NONE
+
+    !! 0. Variables and parameter declaration
+
+    !! 0.1 Input variables
+
+    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 m of each grid-box in X and Y 
+    CHARACTER(LEN=80), INTENT(in)    :: filename2
+    CHARACTER(LEN=80), INTENT(in)    :: fieldname
+    LOGICAL, INTENT(in)              :: density
+
+    !! 0.2 Output variables
+
+    REAL(r_std), INTENT(out)          :: data_year(:)       !! data per year (climatology) per unit area 
+
+    !! 0.3 Modified variables
+
+    CHARACTER(LEN=80), INTENT(inout)  :: filename
+
+
+    !! 0.4 Local variables 
+
+    INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, ilf, lastjp, nbexp
+    REAL(r_std) :: lev(1), date, dt, coslat
+    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(:,:) :: data_year_file
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: loup_rel, lolow_rel, laup_rel, lalow_rel
+    REAL(r_std) :: area2                                     !! total area of the final grid box 
+    REAL(r_std) :: data_grid                                 !! emissions for the final grid point before being 
+                                                             !! ponderated by area2
+    REAL(r_std) :: data_global                               !! global emissions to check
+    REAL(r_std) :: ax, ay, sgn, surp, ax_file, ay_file
+    REAL(r_std) :: lonrel, louprel, lolowrel
+
+!_ ================================================================================================================================
+
+    !
+    CALL getin_p(filename2,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 (data_year_file(iml,jml))
+    !
+    CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
+    !
+    CALL flinget(fid, fieldname, iml, jml, lml, tml, 1, 1, data_year_file)
+    !
+    CALL flinclo(fid)
+    !
+    !
+    WRITE(*,*) 'lon_rel : ', MAXVAL(lon_rel), MINVAL(lon_rel)
+    WRITE(*,*) 'lat_rel : ', MAXVAL(lat_rel), MINVAL(lat_rel)
+    WRITE(*,*) 'data_year_file min,max: ', MINVAL(data_year_file, MASK=data_year_file .GT. 0), &
+         &                      MAXVAL(data_year_file, MASK=data_year_file .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. ), 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.
+       !
+       lastjp = 1
+       data_grid = zero
+       area2 = 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. ), 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
+                   !!to calculate the surface of the initial grid box, ie data one
+                   ax_file = (louprel-lolowrel)*pi/180. * R_Earth * coslat
+                   ay_file = (laup_rel(ip,jp)-lalow_rel(ip,jp))*pi/180. * R_Earth
+                   !
+                   IF (data_year_file(ip,jp) .LT. undef_sechiba-un) THEN
+                      IF(density) THEN
+                         data_grid = data_grid + ax*ay*data_year_file(ip,jp)
+                      ELSE
+                         data_grid = data_grid + ax*ay*(data_year_file(ip,jp)/(ax_file*ay_file))
+                      ENDIF
+                      area2 = area2 + ax*ay
+                   ENDIF
+                   !
+                ENDIF
+                !
+                !
+             ENDDO
+             !
+          ENDIF
+          !
+       ENDDO
+       !
+       ! Put the total data_year areas in the output variables
+       !
+       IF(density) THEN
+          data_year(ib) = data_grid/area2 
+       ELSE
+          data_year(ib) = data_grid
+       ENDIF
+
+
+       IF ( data_year(ib) < 0 ) THEN
+          WRITE(numout,*) 'We have a problem here : ', data_year(ib)
+          WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
+          WRITE(numout,*) area2
+          CALL ipslerr(3,'diffuco.f90','','','') 
+       ENDIF
+       !
+       !!Accumulates emissions (in Kg/year) per grid box to calculate global emissions
+       data_global = data_global + data_grid
+    ENDDO
+    !
+    WRITE(*,*) 'RESULT data_year : ', MINVAL(data_year), MAXVAL(data_year)
+    WRITE(*,*) 'RESULT Global data emissions : ', data_global 
+    !
+
+  END SUBROUTINE diffuco_inca_read
+
+
+  FUNCTION Arrhenius (kjpindex,temp,ref_temp,energy_act) RESULT ( val_arrhenius )
+    !! 0.1 Input variables
+
+    INTEGER(i_std),INTENT(in)                     :: kjpindex          !! Domain size (-)
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)    :: temp              !! Temperature (K)
+    REAL(r_std), INTENT(in)                       :: ref_temp          !! Temperature of reference (K)
+    REAL(r_std),INTENT(in)                        :: energy_act        !! Activation Energy (J mol-1)
+    
+    !! 0.2 Result
+
+    REAL(r_std), DIMENSION(kjpindex)              :: val_arrhenius     !! Temperature dependance based on
+                                                                       !! a Arrhenius function (-)
+    
+    val_arrhenius(:)=EXP(((temp(:)-ref_temp)*energy_act)/(ref_temp*RR*(temp(:))))
+  END FUNCTION Arrhenius
+
+  FUNCTION Arrhenius_modified (kjpindex,temp,ref_temp,energy_act,energy_deact,entropy) RESULT ( val_arrhenius )
+    !! 0.1 Input variables
+
+    INTEGER(i_std),INTENT(in)                     :: kjpindex          !! Domain size (-)
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)    :: temp              !! Temperature (K)
+    REAL(r_std), INTENT(in)                       :: ref_temp          !! Temperature of reference (K)
+    REAL(r_std),INTENT(in)                        :: energy_act        !! Activation Energy (J mol-1)
+    REAL(r_std),INTENT(in)                        :: energy_deact      !! Deactivation Energy (J mol-1)
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)    :: entropy           !! Entropy term (J K-1 mol-1)
+        
+    !! 0.2 Result
+
+    REAL(r_std), DIMENSION(kjpindex)              :: val_arrhenius     !! Temperature dependance based on
+                                                                       !! a Arrhenius function (-)
+    
+    val_arrhenius(:)=EXP(((temp(:)-ref_temp)*energy_act)/(ref_temp*RR*(temp(:))))  &
+         * (1. + EXP( (ref_temp * entropy(:) - energy_deact) / (ref_temp * RR ))) &
+         / (1. + EXP( (temp(:) * entropy(:) - energy_deact) / ( RR*temp(:))))
+         
+  END FUNCTION Arrhenius_modified
+
+
+
+END MODULE diffuco
Index: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/enerbil.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/enerbil.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/enerbil.f90	(revision 7236)
@@ -0,0 +1,6723 @@
+!  ==============================================================================================================================
+!  MODULE		 			: enerbil
+!
+!  CONTACT		 			: orchidee-help _at_ ipsl.jussieu.fr
+!
+!  LICENCE	 			        : IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF					This module computes the energy balance on 
+!! continental surfaces. The module contains the following subroutines: enerbil_main, enerbil_init,
+!! enerbil_clear, enerbil_var_init, enerbil_begin, enerbil_surftemp, enerbil_flux, enerbil_evapveg,
+!! enerbil_fusion and enerbil_t2mdiag
+!!
+!!\n DESCRIPTION                                : 
+!! \n
+!! \latexonly 
+!!     \input{enerbil_intro2.tex}
+!! \endlatexonly
+!!
+!! IMPORTANT NOTE: The coefficients A and B are defined differently than those in the referenced 
+!! literature and from those in the code and documentation of the atmospheric model LMDZ. For the
+!! avoidance of doubt, the coefficients as described here always refer to the ORCHIDEE coefficients, 
+!! and are denoted as such (with the marker: ORC). The re-definition of the coefficients takes place 
+!! within LMDZ before they are passed to ORCHIDEE. The following sequence of expressions is to be 
+!! found within the LMDZ module 'surf_land_orchidee':\n
+!!
+!! \latexonly 
+!!     \input{surflandLMDZ1.tex}
+!!     \input{surflandLMDZ2.tex}
+!!     \input{surflandLMDZ3.tex}
+!!     \input{surflandLMDZ4.tex}
+!! \endlatexonly
+!! \n
+!!
+!! \latexonly 
+!!     \input{enerbil_symbols.tex}
+!! \endlatexonly
+!!
+!! RECENT CHANGE(S)                             : None
+!!
+!! REFERENCE(S)	                                : None 
+!!
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_sechiba/enerbil.f90 $
+!! $Date: 2015-02-22 16:18:16 +0100 (Sun, 22 Feb 2015) $
+!! $Revision: 2555 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE enerbil
+
+  ! routines called : restput, restget
+  !
+  ! modules used
+  USE ioipsl
+  USE xios_orchidee
+  USE ioipsl_para 
+  USE constantes
+  USE pft_parameters
+  USE qsat_moisture
+  USE sechiba_io
+  
+
+  USE slowproc ! JR 151013 - because we need access to tot_bare_soil
+
+  ! USE write_field_p, only : WriteFieldI_p  
+  IMPLICIT NONE
+
+  PRIVATE
+  PUBLIC :: enerbil_main, enerbil_fusion,enerbil_clear, jdriver, enerbil_write
+
+  ! variables used inside enerbil module : declaration and initialisation
+ 
+  LOGICAL, SAVE                              :: l_first_enerbil=.TRUE.  !! Initialisation has to be done one time
+
+  LOGICAL, SAVE                              :: l_first_jenerbil=.TRUE.  !! similar initialisation for multi-layer scheme
+
+!$OMP THREADPRIVATE(l_first_enerbil)
+  ! one dimension array allocated, computed and used in enerbil module exclusively
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: psold         !! Old surface dry static energy (J kg^{-1})
+!$OMP THREADPRIVATE(psold)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: qsol_sat      !! Saturated specific humudity for old temperature (kg kg^{-1})
+!$OMP THREADPRIVATE(qsol_sat)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: pdqsold       !! Deriv. of saturated specific humidity at old temp
+                                                                 !! (kg (kg s)^{-1})
+!$OMP THREADPRIVATE(pdqsold)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: psnew         !! New surface static energy (J kg^{-1})
+!$OMP THREADPRIVATE(psnew)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: qsol_sat_new  !! New saturated surface air moisture (kg kg^{-1})
+!$OMP THREADPRIVATE(qsol_sat_new)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: netrad        !! Net radiation (W m^{-2})
+!$OMP THREADPRIVATE(netrad)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: lwabs         !! LW radiation absorbed by the surface (W m^{-2})
+!$OMP THREADPRIVATE(lwabs)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: lwup          !! Long-wave up radiation (W m^{-2})
+!$OMP THREADPRIVATE(lwup)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: lwnet         !! Net Long-wave radiation (W m^{-2})
+!$OMP THREADPRIVATE(lwnet)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: fluxsubli     !! Energy of sublimation (mm day^{-1})
+!$OMP THREADPRIVATE(fluxsubli)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: qsat_air      !! Air saturated specific humidity (kg kg^{-1})
+!$OMP THREADPRIVATE(qsat_air)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tair          !! Air temperature (K)
+!$OMP THREADPRIVATE(tair)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: q_sol_pot     !! Potential surface humidity
+!$OMP THREADPRIVATE(q_sol_pot)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: temp_sol_pot  !! Potential surface temperature (unstressed)
+!$OMP THREADPRIVATE(temp_sol_pot)
+ 
+
+
+
+  ! %%% JR 230813 start variables %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! variables that are used throughout the program / module
+  INTEGER                                         :: timesteps = 1   			  ! number of half-hour timesteps
+  REAL(r_std)                                     :: canopy_height = 50.0d0               ! canopy height (m)
+  REAL(r_std)                                     :: u_h                                  ! total wind speed at canopy height (m/s)
+  REAL(r_std)                                     :: rho_veg = 1000.0d0                   ! temporary for number checking
+  REAL(r_std)                                     :: leaf_tks = 0.001d0                   ! leaf thickness
+  REAL(r_std)                                     :: rho_soil = 1.0d0
+  INTEGER, PARAMETER                              :: jnlvls_integ = 1
+  REAL, DIMENSION(0:jnlvls_integ+1)               :: lai_profile, lai_cum
+  
+
+  REAL(r_std), SAVE                               :: top_jnlvls
+  REAL(r_std), SAVE                               :: big_k_lw
+  REAL(r_std), SAVE                               :: big_k_sw
+  REAL(r_std), SAVE                               :: k_eddy_fac
+  REAL(r_std), SAVE                               :: sr_fac
+  REAL(r_std), SAVE                               :: br_fac
+  REAL(r_std), SAVE                               :: hd_big_r
+  REAL(r_std), SAVE                               :: hd_big_r_prime
+  CHARACTER(LEN=256), SAVE                        :: jamescdfname           !! To store the name of the multilayer netCDF output file (seperate to the rest)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: pad_deltah
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: box_height
+
+  
+  ! %%%% JR 230813 end variables %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+  CONTAINS  
+    
+   
+  !!  ===========================================================================================================================
+  !! SUBROUTINE		 		    : enerbil_main
+  !!
+  !!
+  !>\BRIEF				    Calls each part of the energy budget calculation in sequence 
+  !!
+  !! DESCRIPTION			    : 
+  !! This is the main routine for the 'enerbil' module. It is called
+  !! once during the initialisation of ORCHIDEE, and then once for each time step. It is called a final
+  !! time at the culmination of the last time step, for the writing of a restart file.\n
+  !!
+  !! The algorithm first calls 'enerbil_begin' for initialisation, followed by 'enerbil_surftemp' to
+  !! calculate the surface static energy and the saturated surface humidity for the new time step.
+  !! Next is the module 'enerbil_flux' which calculates the new surface temperature, the net radiation in
+  !! the surface layer, the total evaporation and the latent and sensible heat fluxes. Finally comes
+  !! 'enerbil_evapveg', which calculates the evaporation and transpiration from the vegetation.\n
+
+  !! \n
+  !!
+  !! RECENT CHANGE(S): None
+  !!
+  !! MAIN OUTPUT VARIABLE(S)	: evapot, evapot_corr, temp_sol, qsurf, fluxsens, fluxlat, tsol_rad,
+  !! vevapp, temp_sol_new, vevapnu, vevapsno, transpir, vevapwet, t2mdiag
+  !!
+  !! REFERENCE(S)		:
+  !! - Best, MJ, Beljaars, A, Polcher, J & Viterbo, P, 2004. A proposed structure for coupling tiled
+  !! surfaces with the planetary boundary layer. Journal of Hydrometeorology, 5, pp.1271-1278
+  !! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+  !! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+  !! Circulation Model. Journal of Climate, 6, pp.248-273
+  !! - Dufresne, J-L & Ghattas, J, 2009. Description du schÃ©ma de la couche limite turbulente et la
+  !! interface avec la surface planetaire dans LMDZ, Technical note, available (22/12/11):
+  !! http://lmdz.lmd.jussieu.fr/developpeurs/notes-techniques/ressources/pbl_surface.pdf
+  !! - Guimberteau, M, 2010. ModÃ©lisation de l'hydrologie continentale et influences de l'irrigation
+  !! sur le cycle de l'eau, PhD Thesis, available (22/12/11):
+  !! http://www.sisyphe.upmc.fr/~guimberteau/docs/manuscrit_these.pdf 
+  !! - Polcher, J. McAvaney, B, Viterbo, P, Gaertner, MA, Hahmann, A, Mahfouf, J-F, Noilhan, J
+  !! Phillips, TJ, Pitman, AJ, Schlosser, CA, Schulz, J-P, Timbal, B, Verseghy, D &
+  !! Xue, Y, 1998. A proposal for a general interface between land surface schemes and
+  !! general circulation models. Global and Planetary Change, 19, pp.261-276
+  !! - Richtmeyer, RD, Morton, KW, 1967. Difference Methods for Initial-Value Problems.
+  !! Interscience Publishers\n
+  !! - Schulz, Jan-Peter, Lydia DÃŒmenil, Jan Polcher, 2001: On the Land SurfaceâAtmosphere 
+  !! Coupling and Its Impact in a Single-Column Atmospheric Model. J. Appl. Meteor., 40, 642â663.
+  !!
+  !! FLOWCHART			:
+  !! \latexonly 
+  !!     \includegraphics[scale=0.5]{enerbil_main_flowchart.png}
+  !! \endlatexonly
+  !! \n
+  !_ ==============================================================================================================================
+   
+  ! %%%% 230813 JR function insert %%%%%%%%
+
+  REAL(r_std) FUNCTION gu (x_in)
+    
+  REAL(r_std) :: k_ext = 0.9d0 
+  REAL(r_std) :: x_in
+    
+      gu = exp(-k_ext*x_in)    
+
+  END FUNCTION ! gu(x_in)
+
+  ! %%%% 230813 end JR function insert %%%%
+
+  SUBROUTINE enerbil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
+       & index, indexveg, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef, &
+       & qair, peqAcoef, peqBcoef, pb, rau, vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta3pot, vbeta4, vbeta5, &
+       & emis, soilflx, soilcap, q_cdrag, humrel, fluxsens, fluxlat, &
+!!$       & cimean, ccanopy, emis, soilflx, soilcap, q_cdrag, humrel, fluxsens, fluxlat, &
+       & vevapp, transpir, transpot, vevapnu, vevapwet, vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, &
+!!$       & vevapp, transpir, transpot, gpp, vevapnu, vevapwet, vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, &
+       & temp_sol_new, qsurf, evapot, evapot_corr, rest_id, hist_id, hist2_id, jr_enerbil, beta_diffuco, james_write) 
+
+    !! 0 Variable and parameter description
+
+    !! 0.1 Input variables
+
+    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 (s)
+    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)                                  :: jr_enerbil       !! Flag that controls the activation of alternate enerbil scheme (true/false)
+    
+    
+    LOGICAL, INTENT(in)                                  :: james_write      !! Flag for turning all of the verbose write statements on and off
+    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)        :: zlev             !! Height of first layer (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: lwdown           !! Down-welling long-wave flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: swnet            !! Net surface short-wave flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: epot_air         !! Air potential energy (?? J)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: temp_air         !! Air temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: u                !! Eastward Lowest level wind speed  (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: v                !! Northward Lowest level wind speed (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: petAcoef         !! PetAcoef (see note)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: petBcoef         !! PetBcoef (see note)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: qair             !! Lowest level specific humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: peqAcoef         !! PeqAcoef (see note)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: peqBcoef         !! PeqBcoef (see note)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: pb               !! Lowest level pressure (hPa)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: rau              !! Air density (kg m^{-3})
+    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)        :: vbeta5           !! Floodplains resistance
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: emis             !! Emissivity (-)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: soilflx          !! Soil flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: soilcap          !! Soil calorific capacity (J K^{-1])
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: q_cdrag          !! Surface drag (m s^{-1})
+!!$    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: ccanopy          !! CO_2 concentration in the canopy (ppm)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: humrel           !! Soil moisture stress (within range 0 to 1)
+    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)    :: vbeta3pot        !! Vegetation resistance for potential transpiration
+!!$    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: cimean           !! mean intercellular ci (from STOMATE) 
+!!$                                                                             !! (\mu mole m^{-2} s^{-1})
+    REAL(r_std), DIMENSION(kjpindex)                     :: dev_qsol
+!!$    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: gpp              !! STOMATE: GPP. gC/m**2 of total area
+  
+  !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)       :: vevapnu          !! Bare soil evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)       :: vevapsno         !! Snow evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)       :: vevapflo         !! Floodplains evaporation
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)   :: transpir         !! Transpiration (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)   :: transpot         !! Potential transpiration
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)   :: vevapwet         !! Interception (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)       :: t2mdiag          !! Diagnostic temperature at 2m above ground (K)
+    REAL(r_std),DIMENSION (kjpindex)                     :: beta_diffuco
+
+
+    
+    !! 0.3 Modified variables
+    
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: evapot           !! Soil Potential Evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: evapot_corr      !! Soil Potential Evaporation Correction (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: temp_sol         !! Soil temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: qsurf            !! Surface specific humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: fluxsens         !! Sensible heat flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: fluxlat          !! Latent heat flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: tsol_rad         !! Tsol_rad (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: vevapp           !! Total of evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: temp_sol_new     !! New soil temperature (K)
+    
+    !! 0.4 Local variables
+    REAL(r_std),DIMENSION (kjpindex)                     :: epot_air_new, qair_new
+    CHARACTER(LEN=80)                                    :: var_name                !! To store variables names for I/O
+
+     REAL(r_std)              :: M_1_h, N_1_h, M_1_q, N_1_q
+
+
+!_ ================================================================================================================================
+    
+    
+ !   write(numout, *) "YC 1 chenk timesteps:", kjit 
+ !   write(numout, *) "YC 1 chenk stpail index:", kjpindex
+ !   write(numout, *) "YC 1 chenk ok_nenerbil:", control%ok_nenerbil
+   
+    !! 1. Run the initialisation routines 
+    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, evapot, evapot_corr)
+
+        CALL enerbil_var_init (kjpindex, temp_air, t2mdiag)
+        ! This needs initialization too, since it is used in hydrol.  I have no idea if this is
+        ! the correct value.
+        vevapsno(:)=zero
+        RETURN 
+
+    ENDIF
+    
+
+    
+    !! 2. Prepare a 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)
+
+        var_name= 'tempsolpot'
+        CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, temp_sol_pot, 'scatter',  nbp_glo, index_g)
+
+        var_name= 'qsolpot'
+        CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, q_sol_pot, 'scatter',  nbp_glo, index_g)
+       
+        RETURN 
+
+    ENDIF
+    
+    
+    
+    IF (.not. control%ok_nenerbil ) THEN
+    
+!!------Do standard calculation & set variable out if ok_enbile is FALSE ------
+    
+	!! 3. Computes some initialisation variables
+	!  Computes some initialisation variables psold (the old surface static energy), qsol_sat
+	! (the saturated surface humidity) and pdqsold (the derivative of the saturated surface humidity,
+	! calculated with respect to the surface temperature at the 'old' timestep)
+	CALL enerbil_begin (kjpindex, temp_sol, lwdown, swnet, pb, psold, qsol_sat, pdqsold, netrad, emis, &
+                         & jr_enerbil, dev_qsol)
+ 
+	!! 4. Computes psnew (the surface static energy at the 'new' timestep) 
+    
+	! Computes psnew (the surface static energy at the 'new' timestep), qsol_sat_new (the surface
+	! saturated humidity at the 'new' timestep), temp_sol_new (the surface temperature at the 'new'
+	! timestep), qair_new (the lowest atmospheric humidity at the 'new' timestep) and epot_air_new
+	! (the lowest atmospheric evaporation potential at the 'new' timestep)
+	CALL enerbil_surftemp (kjpindex, dtradia, zlev, emis, &
+		& epot_air, petAcoef, petBcoef, qair, peqAcoef, peqBcoef, soilflx, rau, u, v, q_cdrag, vbeta,&
+		& valpha, vbeta1, vbeta5, soilcap, lwdown, swnet, psnew, qsol_sat_new, temp_sol_new, &
+		& qair_new, epot_air_new, jr_enerbil, beta_diffuco, temp_sol, dev_qsol)
+  
+	!  computes surface temperature and humidity for a saturated surface
+	!
+	CALL enerbil_pottemp (kjpindex, dtradia, zlev, emis, &
+		& epot_air, petAcoef, petBcoef, qair, peqAcoef, peqBcoef, soilflx, rau, u, v, q_cdrag, vbeta,&
+		& valpha, vbeta1, vbeta5, soilcap, lwdown, swnet, q_sol_pot, temp_sol_pot)
+
+	!! 5. Diagnoses components of the energy budget
+	
+	! Diagnoses lwup (upwards long wave radiation), lwnet (net long wave radiation), tsol_rad (radiative
+	! ground temperature), netrad (net radiation), qsurf (surface humidity), vevapp (total evaporation),
+	! evapot (evaporation potential), evapot_corr (evaporation potential correction factor), 
+	! fluxlat (latent heat flux), fluxsubli (sublimination heat flux) and fluxsens (sensible heat flux).
+
+	CALL enerbil_flux (kjpindex, dtradia, emis, temp_sol, rau, u, v, q_cdrag, vbeta, valpha, vbeta1, vbeta5, &
+		& 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, jr_enerbil, beta_diffuco, &
+		& soilflx, soilcap)
+
+	!! 6. Diagnoses the values for evaporation and transpiration 
+	 
+	! Diagnoses the values for evaporation and transpiration: vevapsno (snow evaporation), vevapnu 
+	! (bare soil evaporation), transpir (transpiration), and vevapwet (interception)
+	CALL enerbil_evapveg (kjpindex, dtradia, vbeta1, vbeta2, &
+                & vbeta3, vbeta3pot, vbeta4, vbeta5, &
+		& rau, u, v, q_cdrag, &
+!!$                & cimean, ccanopy, rau, u, v, q_cdrag, &
+                & qair_new, humrel, vevapsno, vevapnu , vevapflo, vevapwet, &
+		& transpir, transpot, evapot)
+
+	!! 7. Assigns a temperature 2 metres above the ground 
+
+	! Assigns a temperature 2 metres above the ground. The output variable - t2mdiag, is used just for
+	! diagnostic purposes, for now.
+	CALL enerbil_t2mdiag (kjpindex, temp_air, t2mdiag)
+
+	! write(numout, *)  "YC standard energy budget:"
+
+	!CALL xios_orchidee_send_field("netrad",netrad)
+	CALL xios_orchidee_send_field("evapot",evapot*one_day/dt_sechiba)
+	CALL xios_orchidee_send_field("evapot_alma",evapot/dt_sechiba)
+	CALL xios_orchidee_send_field("evapot_corr",evapot_corr*one_day/dt_sechiba)
+	CALL xios_orchidee_send_field("evapot_corr_alma",evapot_corr/dt_sechiba)
+	CALL xios_orchidee_send_field("lwdown",lwabs)
+	CALL xios_orchidee_send_field("lwnet",lwnet)
+	CALL xios_orchidee_send_field("Qv",fluxsubli)
+	CALL xios_orchidee_send_field("PotSurfT",temp_sol_pot)
+          
+    	IF ( .NOT. almaoutput ) THEN
+       		!CALL histwrite_p(hist_id, 'netrad', kjit, netrad, kjpindex, index)
+       		CALL histwrite_p(hist_id, 'evapot', kjit, evapot, kjpindex, index)
+       		CALL histwrite_p(hist_id, 'evapot_corr', kjit, evapot_corr, kjpindex, index)
+       		CALL histwrite_p(hist_id, 'lwdown', kjit, lwabs,  kjpindex, index)
+       		CALL histwrite_p(hist_id, 'lwnet',  kjit, lwnet,  kjpindex, index)
+       	     IF ( hist2_id > 0 ) THEN
+          	!CALL histwrite_p(hist2_id, 'netrad', kjit, netrad, kjpindex, index)
+          	CALL histwrite_p(hist2_id, 'evapot', kjit, evapot, kjpindex, index)
+          	CALL histwrite_p(hist2_id, 'evapot_corr', kjit, evapot_corr, kjpindex, index)
+          	CALL histwrite_p(hist2_id, 'lwdown', kjit, lwabs,  kjpindex, index)
+          	CALL histwrite_p(hist2_id, 'lwnet',  kjit, lwnet,  kjpindex, index)
+             ENDIF
+    	ELSE
+       		CALL histwrite_p(hist_id, 'LWnet', kjit, lwnet, kjpindex, index)
+       		CALL histwrite_p(hist_id, 'Qv', kjit, fluxsubli, kjpindex, index)
+       		CALL histwrite_p(hist_id, 'PotEvap', kjit, evapot_corr, kjpindex, index)
+       		CALL histwrite_p(hist_id, 'PotEvapOld', kjit, evapot, kjpindex, index)
+       		CALL histwrite_p(hist_id, 'PotSurfT', kjit, temp_sol_pot, kjpindex, index)
+       	     IF ( hist2_id > 0 ) THEN
+          	CALL histwrite_p(hist2_id, 'LWnet', kjit, lwnet, kjpindex, index)
+          	CALL histwrite_p(hist2_id, 'Qv', kjit, fluxsubli, kjpindex, index)
+          	CALL histwrite_p(hist2_id, 'PotEvap', kjit, evapot_corr, kjpindex, index)
+             ENDIF
+    	ENDIF
+    
+    ELSE
+    
+!---If ok_enbile is TRUE, we write/set the vaiables out to histoty file here. 
+
+        !! New energy budget scheme don't follow the standard energy budget calling grapgh.
+	!! The calculation process from "Section 3" to "Section 7" were modified and called in the jdriver.f90, 
+	!! which could be called in the rountine of sechiba.f90 
+	!!     
+	!write(numout, *) "YC new energy budget:"
+    
+    	!CALL xios_orchidee_send_field("netrad",netrad)
+    	CALL xios_orchidee_send_field("evapot",evapot*one_day/dt_sechiba)
+    	CALL xios_orchidee_send_field("evapot_alma",evapot/dt_sechiba)
+    	CALL xios_orchidee_send_field("evapot_corr",evapot_corr*one_day/dt_sechiba)
+    	CALL xios_orchidee_send_field("evapot_corr_alma",evapot_corr/dt_sechiba)
+    	CALL xios_orchidee_send_field("lwdown",lwabs)
+    	CALL xios_orchidee_send_field("lwnet",lwnet)
+    	CALL xios_orchidee_send_field("Qv",fluxsubli)
+    	CALL xios_orchidee_send_field("PotSurfT",temp_sol_pot)
+          
+    	IF ( .NOT. almaoutput ) THEN
+       		!CALL histwrite_p(hist_id, 'netrad', kjit, netrad, kjpindex, index)
+       		CALL histwrite_p(hist_id, 'evapot', kjit, evapot, kjpindex, index)
+       		CALL histwrite_p(hist_id, 'evapot_corr', kjit, evapot_corr, kjpindex, index)
+       		CALL histwrite_p(hist_id, 'lwdown', kjit, lwabs,  kjpindex, index)
+       		CALL histwrite_p(hist_id, 'lwnet',  kjit, lwnet,  kjpindex, index)
+       	    IF ( hist2_id > 0 ) THEN
+          	!CALL histwrite_p(hist2_id, 'netrad', kjit, netrad, kjpindex, index)
+          	CALL histwrite_p(hist2_id, 'evapot', kjit, evapot, kjpindex, index)
+          	CALL histwrite_p(hist2_id, 'evapot_corr', kjit, evapot_corr, kjpindex, index)
+          	CALL histwrite_p(hist2_id, 'lwdown', kjit, lwabs,  kjpindex, index)
+          	CALL histwrite_p(hist2_id, 'lwnet',  kjit, lwnet,  kjpindex, index)
+            ENDIF
+    	ELSE
+       		CALL histwrite_p(hist_id, 'LWnet', kjit, lwnet, kjpindex, index)
+       		CALL histwrite_p(hist_id, 'Qv', kjit, fluxsubli, kjpindex, index)
+       		CALL histwrite_p(hist_id, 'PotEvap', kjit, evapot_corr, kjpindex, index)
+       		CALL histwrite_p(hist_id, 'PotEvapOld', kjit, evapot, kjpindex, index)
+       		CALL histwrite_p(hist_id, 'PotSurfT', kjit, temp_sol_pot, kjpindex, index)
+       	    IF ( hist2_id > 0 ) THEN
+          	CALL histwrite_p(hist2_id, 'LWnet', kjit, lwnet, kjpindex, index)
+          	CALL histwrite_p(hist2_id, 'Qv', kjit, fluxsubli, kjpindex, index)
+          	CALL histwrite_p(hist2_id, 'PotEvap', kjit, evapot_corr, kjpindex, index)
+            ENDIF
+    	ENDIF 
+       
+    ENDIF  
+
+    IF (long_print) WRITE (numout,*) ' enerbil_main Done '
+
+  END SUBROUTINE enerbil_main
+
+
+  !!  =============================================================================================================================
+  !! SUBROUTINE		 		    : enerbil_init
+  !!
+  !>\BRIEF			            Performs dynamic allocation for local arrays, and retrieves
+  !! previous data from restart file (if the switch is set to do so)
+  !!
+  !! DESCRIPTION			    : The purpose of this module is, firstly, to allocate space
+  !! in memory for key variables within the 'enerbil' module. The second task is to retrieve previous data
+  !! from the restart file, if the 'ldrestart-read' flag is set.
+  !!
+  !! RECENT CHANGE(S)			    : None
+  !!
+  !! MAIN OUTPUT VARIABLE(S)	            : temp_sol, temp_sol_new, qsurf, tsol_rad, vevapp, fluxsens,
+  !! fluxlat, evapot, evapot_corr
+  !!
+  !! REFERENCE(S)			    : None
+  !! 
+  !! FLOWCHART                              : None
+  !! \n
+  !_ ==============================================================================================================================
+  
+  SUBROUTINE enerbil_init (kjit, ldrestart_read, kjpindex, index, rest_id, qair, temp_sol, temp_sol_new, &
+       &                   qsurf, tsol_rad, vevapp, fluxsens, fluxlat, evapot, evapot_corr)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+  
+    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 (in)            :: qair               !! Lowest level specific humidity (kg kg^{-1})
+    
+    !! 0.2 Output variables
+    
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: temp_sol_new       !! New ground temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: qsurf              !! Near surface specific humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: tsol_rad           !! Tsol_rad (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: vevapp             !! Total of evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fluxsens           !! Sensible heat flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fluxlat            !! Latent heat flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: evapot             !! Soil Potential Evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: evapot_corr        !! Soil Potential Evaporation Correction 
+                                                                                   !! (mm day^{-1})
+
+    !! 0.3 Modified variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: temp_sol           !! Ground temperature (K)
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                           :: ier
+    CHARACTER(LEN=80)                                        :: var_name            !! To store variables names for I/O
+
+!_ ================================================================================================================================
+
+  !! 1 Initialisation of variables
+ 
+    !! Initialisation of variables psold (old surface static energy), qsol_sat (saturated surface air moisture), pdqsold
+    !! (derivative of satured specific humidity at the old temperature), psnew (new surface static energy), qsol_sat_new
+    !! (new saturated surface air moisture), netrad (net radiation), lwabs (long wave absolute radiation), lwup (long wave
+    !! (upwelling radiation), lwnet (long wave net radiation), fluxsubli (sublimination flux), qsat_air (saturated air humidity)
+    !! and tair (air temperature).
+    IF (l_first_enerbil) THEN 
+        l_first_enerbil=.FALSE.
+    ELSE 
+        WRITE (numout,*) ' l_first_enerbil false . we stop'
+        CALL ipslerr(3,'enerbil.f90','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
+        CALL ipslerr(3,'enerbil.f90','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
+        CALL ipslerr(3,'enerbil.f90','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
+        CALL ipslerr(3,'enerbil.f90','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
+        CALL ipslerr(3,'enerbil.f90','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
+        CALL ipslerr(3,'enerbil.f90','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
+        CALL ipslerr(3,'enerbil.f90','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
+        CALL ipslerr(3,'enerbil.f90','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
+        CALL ipslerr(3,'enerbil.f90','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
+        CALL ipslerr(3,'enerbil.f90','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
+        CALL ipslerr(3,'enerbil.f90','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
+        CALL ipslerr(3,'enerbil.f90','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
+        CALL ipslerr(3,'enerbil.f90','enerbil_init','','')
+    END IF
+
+
+    ALLOCATE (q_sol_pot(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in q_sol_pot allocation. We stop. We need kjpindex words = ',kjpindex
+        CALL ipslerr(3,'enerbil.f90','enerbil_init','','')
+    END IF
+
+    ALLOCATE (temp_sol_pot(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in temp_sol_pot allocation. We stop. We need kjpindex words = ',kjpindex
+        CALL ipslerr(3,'enerbil.f90','enerbil_init','','')
+    END IF
+
+
+  !! 2. Open restart input file and read data from the restart input file
+
+    !! Open restart input file done by enerbil_init and read data from the restart input file
+    !! that corresponds to processes within the 'enerbil' module (if the 'ldrestart_read' flag is set).\n
+    !! The variables read are: temp_sol (surface temperature), qsurf (near surface specific humidity),
+    !! evapot (soil potential evaporation), evapot_corr (corrected soil potential evaporation), tsolrad
+    !! (radiative surface temperature), evapora (evaporation), fluxlat (latent heat flux), fluxsens
+    !! (sensible heat flux), and temp_sol_new (new surface temperature).
+    IF (ldrestart_read) THEN
+
+        IF (long_print) WRITE (numout,*) ' we have to read a restart file for ENERBIL variables'
+
+        var_name='temp_sol'
+        CALL ioconf_setatt_p('UNITS', 'K')
+        CALL ioconf_setatt_p('LONG_NAME','Surface temperature')
+        CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., temp_sol, "gather", nbp_glo, index_g)
+
+!WRITE(*,*) 'tzjE restart', temp_sol
+
+        IF ( MINVAL(temp_sol) < 0. .OR. MAXVAL(temp_sol) > 500.) THEN
+           WRITE(numout, *) "Big problem with surface temperature at restart : ",  MINVAL(temp_sol), MAXVAL(temp_sol)
+           WHERE ( temp_sol < 0.) temp_sol = 280.
+        ENDIF
+
+        !
+        !Config Key   = ENERBIL_TSURF
+        !Config Desc  = Initial temperature if not found in restart
+        !Config If    = OK_SECHIBA
+        !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.
+        !Config Units = Kelvin [K]
+        CALL setvar_p (temp_sol, val_exp,'ENERBIL_TSURF', 280._r_std)
+        
+        var_name= 'qsurf'
+        CALL ioconf_setatt_p('UNITS', 'g/g')
+        CALL ioconf_setatt_p('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_p('UNITS', 'mm day^{-1}')
+        CALL ioconf_setatt_p('LONG_NAME','Soil Potential Evaporation')
+        CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., evapot, "gather", nbp_glo, index_g)
+        CALL setvar_p (evapot, val_exp, 'ENERBIL_EVAPOT', zero)
+        
+        var_name= 'evapot_corr'
+        ! if this variable is not initialized, it is tried to use in the setvar_p loop below uninitialised
+        evapot_corr(:)=zero
+        CALL ioconf_setatt_p('UNITS', 'mm day^{-1}')
+        CALL ioconf_setatt_p('LONG_NAME','Corrected Soil Potential Evaporation')
+        CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., evapot_corr, "gather", nbp_glo, index_g)
+        
+        !Config Key   = ENERBIL_EVAPOT
+        !Config Desc  = Initial Soil Potential Evaporation
+        !Config If    = OK_SECHIBA       
+        !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. 
+        !Config Units = 
+        CALL setvar_p (evapot_corr, val_exp, 'ENERBIL_EVAPOT', zero)
+                
+        var_name= 'tsolrad'
+        CALL ioconf_setatt_p('UNITS', 'K')
+        CALL ioconf_setatt_p('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
+        
+        !! 1.3 Set the fluxes so that we have something reasonable and not NaN on some machines
+        var_name= 'evapora'
+        CALL ioconf_setatt_p('UNITS', 'Kg/m^2/dt')
+        CALL ioconf_setatt_p('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_p('UNITS', 'W/m^2')
+        CALL ioconf_setatt_p('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_p('UNITS', 'W/m^2')
+        CALL ioconf_setatt_p('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
+        
+        var_name= 'tempsolpot'
+        CALL ioconf_setatt_p('UNITS', 'K')
+        CALL ioconf_setatt_p('LONG_NAME','Potential surface temperature')
+        CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., temp_sol_pot, "gather", nbp_glo, index_g)
+        IF ( ALL( temp_sol_pot(:) .EQ. val_exp ) ) THEN 
+           temp_sol_pot = temp_sol
+        ENDIF
+        !
+        var_name= 'qsolpot'
+        CALL ioconf_setatt_p('UNITS', 'kg/m^2')
+        CALL ioconf_setatt_p('LONG_NAME','Potential saturated surface humidity')
+        CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., q_sol_pot, "gather", nbp_glo, index_g)
+        IF ( ALL( q_sol_pot(:) .EQ. val_exp ) ) THEN 
+           q_sol_pot = qsurf
+        ENDIF
+
+        ! initialises temp_sol_new saved in thermosoil
+        var_name='temp_sol_new'
+        CALL ioconf_setatt_p('UNITS', 'K')
+        CALL ioconf_setatt_p('LONG_NAME','New Surface temperature')
+        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
+           ! Variables not found in restart file.
+           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
+  !!
+  !>\BRIEF				    Routine deallocates clear output variables if already allocated.
+  !!
+  !! DESCRIPTION			    : This is a 'housekeeping' routine that deallocates the key output
+  !! variables, if they have already been allocated. The variables that are deallocated are psold,
+  !! qsol_sat, pdqsold, psnew, qsol_sat_new, netrad, lwabs, lwup, lwnet, fluxsubli, qsat_air, tair
+  !!
+  !! RECENT CHANGE(S)			    : None
+  !!
+  !! MAIN OUTPUT VARIABLE(S)	            : None
+  !!
+  !! REFERENCES				    : None
+  !! 
+  !! FLOWCHART                              : None
+  !! \n
+  !_ ==============================================================================================================================
+
+  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)
+    IF ( ALLOCATED (q_sol_pot)) DEALLOCATE (q_sol_pot)
+    IF ( ALLOCATED (temp_sol_pot)) DEALLOCATE (temp_sol_pot)
+   
+    IF ( ALLOCATED (pad_deltah)) DEALLOCATE (pad_deltah)
+    IF ( ALLOCATED (box_height)) DEALLOCATE (box_height)   
+   ! ??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
+  !!
+  !>\BRIEF					Housekeeping routine that calls enerbil_t2mdiag.
+  !!
+  !! DESCRIPTION				: Housekeeping routine that calls the 2 metre temperature
+  !! diagnostic subroutine 'enerbil_2tmdiag'.
+  !!
+  !! MAIN OUTPUT VARIABLE(S)	                : t2mdiag
+  !!
+  !! REFERENCE(S)				: None
+  !!
+  !! FLOWCHART                                  : None
+  !! \n
+  !_ ==============================================================================================================================
+ 
+  SUBROUTINE enerbil_var_init (kjpindex, temp_air, t2mdiag)
+
+    !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+ 
+    INTEGER(i_std), INTENT(in)                         :: kjpindex       !! Domain size (-)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_air       !! Air temperature (K)
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: t2mdiag        !! Temperature at 2 metres above ground(K)
+!_ ================================================================================================================================
+
+    CALL enerbil_t2mdiag (kjpindex, temp_air, t2mdiag)
+
+    IF (long_print) WRITE (numout,*) ' enerbil_var_init done '
+
+  END SUBROUTINE enerbil_var_init
+
+
+  !!  =============================================================================================================================
+  !! SUBROUTINE		 			: enerbil_begin
+  !!
+  !>\BRIEF					Preliminary variables required for the calculation of
+  !! the energy budget are derived.
+  !!
+  !! DESCRIPTION				: This routines computes preliminary variables required
+  !! for the calculation of the energy budget: the old surface static energy (psold), the surface saturation
+  !! humidity (qsol_sat), the derivative of satured specific humidity at the old temperature (pdqsold) 
+  !! and the net radiation (netrad).
+  !!
+  !! MAIN OUTPUT VARIABLE(S)	                : psold, qsol_sat, pdqsold, netrad
+  !!
+  !! REFERENCE(S)				:
+  !! - Best, MJ, Beljaars, A, Polcher, J & Viterbo, P, 2004. A proposed structure for coupling tiled
+  !! surfaces with the planetary boundary layer. Journal of Hydrometeorology, 5, pp.1271-1278
+  !! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+  !! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+  !! Circulation Model. Journal of Climate, 6, pp.248-273
+  !! - Dufresne, J-L & Ghattas, J, 2009. Description du schÃ©ma de la couche limite turbulente et la
+  !! interface avec la surface planetaire dans LMDZ, Technical note, available (22/12/11):
+  !! http://lmdz.lmd.jussieu.fr/developpeurs/notes-techniques/ressources/pbl_surface.pdf
+  !! - Polcher, J. McAvaney, B, Viterbo, P, Gaertner, MA, Hahmann, A, Mahfouf, J-F, Noilhan, J
+  !! Phillips, TJ, Pitman, AJ, Schlosser, CA, Schulz, J-P, Timbal, B, Verseghy, D &
+  !! Xue, Y, 1998. A proposal for a general interface between land surface schemes and
+  !! general circulation models. Global and Planetary Change, 19, pp.261-276
+  !! - Richtmeyer, RD, Morton, KW, 1967. Difference Methods for Initial-Value Problems.
+  !! Interscience Publishers\n
+  !! - Schulz, Jan-Peter, Lydia DÃŒmenil, Jan Polcher, 2001: On the Land SurfaceâAtmosphere 
+  !! Coupling and Its Impact in a Single-Column Atmospheric Model. J. Appl. Meteor., 40, 642â663.
+  !!
+  !! FLOWCHART  : None                     
+  !! \n
+  !_ ==============================================================================================================================
+  
+  SUBROUTINE enerbil_begin (kjpindex, temp_sol, lwdown, swnet, pb, psold, qsol_sat, pdqsold, netrad, emis, &
+                            jr_enerbil, dev_qsol)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                         :: kjpindex         !! Domain size (-)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_sol         !! Soil temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: lwdown           !! Down-welling long-wave flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: swnet            !! Net surface short-wave flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: pb               !! Lowest level pressure (hPa)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: emis             !! Emissivity (-)
+    LOGICAL, INTENT(in)                                :: jr_enerbil    !! Flag that controls the activation of alternate enerbil scheme (true/false)
+    
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: psold            !! Old surface dry static energy (J kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: qsol_sat	   !! Saturated specific humudity for old temperature 
+                                                                           !! (kg kg^{-1})    
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: pdqsold	   !! Derivative of satured specific humidity at the old 
+                                                                           !! temperature (kg (kg s)^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: netrad           !! Net radiation (W m^{-2})
+    REAL(r_std), DIMENSION(kjpindex)                   :: dev_qsol
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                     :: ji
+    REAL(r_std), PARAMETER                             :: missing = 999998.
+!_ ================================================================================================================================
+  
+  !! 1. Computes psold (the surface static energy for the old timestep)
+   
+    !! We here define the surface static energy for the 'old' timestep, in terms of the surface
+    !! temperature and heat capacity.
+    !! \latexonly 
+    !!     \input{enerbilbegin1.tex}
+    !! \endlatexonly
+    psold(:) = temp_sol(:)*cp_air
+    
+  !! 2. Computes qsol_sat (the surface saturated humidity).
+ 
+    !! We call the routine 'qsatcalc' from within the module 'src_parameters/constantes_veg'.
+
+    ! WRITE(*,*) '181113a test, pre call to qsatcalc enerbil line 922; temp_sol is: ', temp_sol
+
+    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_p (3,'enerbil_begin', &
+ &           'qsol too high ','','')
+         ENDIF
+       ENDDO
+     ENDIF
+   ENDIF
+    
+
+  !! 3. Computes pdqsold 
+    
+    !! Computes pdqsold (the derivative of the saturated humidity with respect to temperature
+    !! analysed at the surface temperature at the 'old' timestep.
+    !! We call the routine 'dev_qsatcalc' from within the module 'src_parameters/constantes_veg'.
+    CALL dev_qsatcalc (kjpindex, temp_sol, pb, dev_qsol)
+ 
+ 
+
+    
+ !+++ According to r2093 in the trunk, this causes and instabilty in the coupling
+!    DO ji = 1, kjpindex
+!!$    
+!!$    !! \latexonly 
+!!$    !!     \input{enerbilbegin2.tex}
+!!$    !! \endlatexonly
+!      pdqsold(ji) = dev_qsol(ji) * ( pb(ji)**kappa ) / cp_air
+!    ENDDO
+
+    pdqsold(:) = dev_qsol(:)
+!+++++++++
+! tzj bug remove
+    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_p (3,'enerbil_begin', &
+ &           'pdqsold too high ','','')
+          ENDIF
+        ENDDO
+     ENDIF
+   ENDIF
+
+  !! 4. Computes the net radiation and the absorbed LW radiation absorbed at the surface.  
+
+    !! Long wave radiation absorbed by the surface is the product of emissivity and downwelling LW radiation    
+    !! \latexonly 
+    !!     \input{enerbilbegin3.tex}
+    !! \endlatexonly
+    lwabs(:) = emis(:) * lwdown(:)
+
+    !! Net radiation is calculated as:
+    !! \latexonly 
+    !!     \input{enerbilbegin4.tex}
+    !! \endlatexonly
+    netrad(:) = lwdown(:) + swnet (:) - (emis(:) * c_stefan * temp_sol(:)**4 + (un - emis(:)) * lwdown(:)) 
+
+    !
+    IF (long_print) WRITE (numout,*) ' enerbil_begin done '
+
+  END SUBROUTINE enerbil_begin
+
+
+  !!  =============================================================================================================================
+  !! SUBROUTINE		 			: enerbil_surftemp
+  !!
+  !>\BRIEF					This routine computes the new surface static energy
+  !! (psnew) and the saturated humidity at the surface (qsol_sat_new). 
+  !!
+  !! DESCRIPTION				: This is the key part of the enerbil module, for which
+  !! the energy budget in the surface layer is solved and changes over the model timestep 'dtradia' are
+  !! quantified for the surface static energy, surface temperature, surface humidity, the 'air' (or lowest
+  !! level atmospheric model) temperature, the 'air' (or lowest level atmospheric model) humidity, 
+  !! according to the method that is laid out by Dufresne \& Ghattas (2009) and Shultz et al. (2001).
+  !!
+  !! It computes the energy balance at the surface with an implicit scheme, that is connected to the 
+  !! Richtmyer and Morton algorithm of the PBL. By computing the surface temperature and surface humidity 
+  !! the routine also implicitly estimates the various fluxes which balance in order to give the new 
+  !! temperature. Thus once the surface temperature has been obtained all the fluxes need to be diagnosed. 
+  !!
+  !! MAIN OUTPUT VARIABLE(S)	: psnew, qsol_sat_new, temp_sol_new, qair_new, epot_air_new
+  !!
+  !! REFERENCE(S)					:
+  !! - Best, MJ, Beljaars, A, Polcher, J & Viterbo, P, 2004. A proposed structure for coupling tiled
+  !! surfaces with the planetary boundary layer. Journal of Hydrometeorology, 5, pp.1271-1278
+  !! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+  !! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+  !! Circulation Model. Journal of Climate, 6, pp.248-273
+  !! - Dufresne, J-L & Ghattas, J, 2009. Description du schÃ©ma de la couche limite turbulente et la
+  !! interface avec la surface planetaire dans LMDZ, Technical note, available (22/12/11):
+  !! http://lmdz.lmd.jussieu.fr/developpeurs/notes-techniques/ressources/pbl_surface.pdf
+  !! - Guimberteau, M, 2010. ModÃ©lisation de l'hydrologie continentale et influences de l'irrigation
+  !! sur le cycle de l'eau, PhD Thesis, available (22/12/11):
+  !! http://www.sisyphe.upmc.fr/~guimberteau/docs/manuscrit_these.pd 
+  !! - Polcher, J. McAvaney, B, Viterbo, P, Gaertner, MA, Hahmann, A, Mahfouf, J-F, Noilhan, J
+  !! Phillips, TJ, Pitman, AJ, Schlosser, CA, Schulz, J-P, Timbal, B, Verseghy, D &
+  !! Xue, Y, 1998. A proposal for a general interface between land surface schemes and
+  !! general circulation models. Global and Planetary Change, 19, pp.261-276
+  !! - Richtmeyer, RD, Morton, KW, 1967. Difference Methods for Initial-Value Problems.
+  !! Interscience Publishers
+  !! - Schulz, Jan-Peter, Lydia DÃŒmenil, Jan Polcher, 2001: On the Land SurfaceâAtmosphere 
+  !! Coupling and Its Impact in a Single-Column Atmospheric Model. J. Appl. Meteor., 40, 642â663.
+  !!
+  !! FLOWCHART    : None
+  !!
+  !_ ==============================================================================================================================  
+  
+
+  SUBROUTINE enerbil_surftemp (kjpindex, dtradia, zlev, emis, epot_air, &
+     & petAcoef, petBcoef, qair, peqAcoef, peqBcoef, soilflx, rau, u, v, q_cdrag, vbeta,&
+     & valpha, vbeta1, vbeta5, soilcap, lwdown, swnet, psnew, qsol_sat_new, temp_sol_new, &
+     & qair_new, epot_air_new, jr_enerbil, beta_diffuco, temp_sol, dev_qsol) 
+
+
+    !! 0. Variable and parameter declaration 
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                               :: kjpindex      !! Domain size (-)
+    REAL(r_std), INTENT(in)                                  :: dtradia       !! Time step (s)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: zlev          !! Height of first layer (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: emis          !! Emissivity (-)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: epot_air      !! Air potential energy (?? J)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: petAcoef      !! PetAcoef (see note)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: petBcoef      !! PetBcoef (see note)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qair          !! Lowest level specific humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: peqAcoef      !! PeqAcoef (see note)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: peqBcoef      !! PeqBcoef (see note)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: soilflx       !! Soil flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: rau           !! Air density (kg m^{-3})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u, v          !! Wind velocity by directional components 
+                                                                              !! u (Eastwards) and v (Northwards) (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q_cdrag       !! Surface drag (m s^{-1})
+    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)            :: vbeta5        !! Floodplains resistance
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: soilcap       !! Soil calorific capacity (J K^{-1])
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: lwdown        !! Down-welling long-wave flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: swnet         !! Net surface short-wave flux (W m^{-2})
+    LOGICAL, INTENT(in)                                      :: jr_enerbil    !! Flag that controls the activation of alternate enerbil scheme (true/false) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_sol         !! Soil temperature (K)
+    REAL(r_std), DIMENSION(kjpindex)                         :: dev_qsol
+
+
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: psnew         !! New surface static energy (J kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: qsol_sat_new  !! New saturated surface air moisture (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: temp_sol_new  !! New soil temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: qair_new      !! New air moisture (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: epot_air_new  !! New air temperature (K)
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    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
+
+
+    REAL(r_std)                      :: test_delta_temp, test_delta_temp2, test_delta_temp3
+    REAL(r_std)                      :: test_delta_temp4
+
+    REAL(r_std),DIMENSION (kjpindex) :: beta_diffuco, beta_diffuco_sub, beta_diffuco_evap
+
+    REAL(r_std)      :: M_1_h, N_1_h, M_1_q, N_1_q
+
+!_ ================================================================================================================================
+    
+    zicp = un / cp_air
+    
+    DO ji=1,kjpindex
+     
+     
+    !! 1. Derivation of auxiliary variables
+      
+      !! \latexonly 
+      !!     \input{enerbilsurftemp1.tex}
+      !! \endlatexonly
+      speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+      !
+      !! \latexonly 
+      !!     \input{enerbilsurftemp2.tex}
+      !! \endlatexonly
+      zikt = 1/(rau(ji) * speed * q_cdrag(ji))
+      zikq = 1/(rau(ji) * speed * q_cdrag(ji))
+      
+      beta_diffuco(ji) = 1.0d0 * vbeta1(ji) * (un - vbeta5(ji)) + &
+                        &  (un - vbeta1(ji)) * (un - vbeta5(ji)) * vbeta(ji) + vbeta5(ji)
+      
+      beta_diffuco_sub(ji) = vbeta1(ji) * (1.0d0 - vbeta5(ji))
+
+      beta_diffuco_evap(ji) = (1.0d0 - vbeta1(ji)) * (1.0d0 -vbeta5(ji)) * vbeta(ji) + &
+                        &   vbeta5(ji)
+
+
+    !! 2. Computation of fluxes for the old surface conditions
+     
+      !! As a reference, we first calculate the sensible and latent heat for the 'old' timestep.
+ 
+      !! 2.1 Sensible heat for the 'old' timestep
+      !! This is equation (64) of (Dufresne & Ghattas, 2009), rewritten in terms of H_old. We make the 
+      !! approximation that (P_r/P)^{kappa}=1 and convert the A and B coefficients to the ORCHIDEE
+      !! format (see introductory note, above). Also, the equation here is in terms of surface static
+      !! energy, which is defined as per section 3.1, above.
+      !! \latexonly 
+      !!     \input{enerbilsurftemp3.tex}
+      !! \endlatexonly
+      sensfl_old = (petBcoef(ji) -  psold(ji)) / (zikt -  petAcoef(ji))
+
+
+
+
+      !! 2.2 Latent heat for the 'old' timestep
+      !! This is equation (70) of (Dufresne & Ghattas, 2009), rewritten in terms of {\lambda E}_{old}.
+      !! Again we convert the A and B coefficients from the LMDZ format to the ORCHIDEE format.\n
+      !! There are two forms of the equation - first for the latent heat as a result of sublimination
+      !! processes and then as a result of evaporative processes:
+      !! \latexonly 
+      !!     \input{enerbilsurftemp4.tex}
+      !! \endlatexonly
+      larsub_old = chalsu0 * vbeta1(ji) * (un - vbeta5(ji)) * (peqBcoef(ji) -  qsol_sat(ji)) / (zikq - peqAcoef(ji))
+
+      !! \latexonly 
+      !!     \input{enerbilsurftemp5.tex}
+      !! \endlatexonly
+       lareva_old = chalev0 * (un - vbeta1(ji)) * (un - vbeta5(ji)) * vbeta(ji) * &
+           & (peqBcoef(ji) -  valpha(ji) * qsol_sat(ji)) / (zikq - peqAcoef(ji)) &
+           & + chalev0 * vbeta5(ji) * (peqBcoef(ji) -  qsol_sat(ji)) / (zikq - peqAcoef(ji))
+
+
+      
+    !! 3. Calculation of sensitivity terms
+     
+      !! We here calculate the sensitivity for the different fluxes to changes in dtheta, which is the
+      !! change in the surface static energy over the model time step (dtradia).
+      
+      !! 3.1 Net radiation sensitivity
+      !! This is an explicit-implicit representation of the Stefan-Boltzmann law - the explicit terms 
+      !! are ${ps}_{old}^3$, and it is completed when multiplied by dtheta (defined above).
+      !! \latexonly 
+      !!     \input{enerbilsurftemp6.tex}
+      !! \endlatexonly
+      netrad_sns = zicp(ji) * quatre * emis(ji) * c_stefan * ((zicp(ji) * psold(ji))**3)
+
+
+
+      !! 3.2 Sensible heat flux sensitivity
+      !! This is the temperature sensitivity term N_1^h derived in equation (66) of (Dufresne & Ghattas, 2009),
+      !! where we again assume that (P_r/P)^{kappa}=1, convert the A and B coefficients to the ORCHIDEE format,
+      !! and rewrite in terms of surface static energy, rather than temperature (see section 3.1, above).
+      !! \latexonly 
+      !!     \input{enerbilsurftemp7.tex}
+      !! \endlatexonly
+      sensfl_sns = un / (zikt -  petAcoef(ji))
+
+
+      !! 3.3 Latent heat flux sensitivity 
+      !! This is the humidity sensitivity term N_1^q derived in equation (72) of (Dufresne & Ghattas, 2009), where
+      !! the A and B coefficients are written in the ORCHIDEE format.
+      !! larsub_sns is the latent heat sensitivity for sublimination. The coefficient vbeta1 is the evaporation
+      !! coefficient. It represents the relationship between the real and potential evaporation. It is derived
+      !! in the module 'src_sechiba/diffuco_snow'.
+      !! \latexonly 
+      !!     \input{enerbilsurftemp8.tex}
+      !! \endlatexonly
+      larsub_sns = chalsu0 * vbeta1(ji) * (un - vbeta5(ji)) * zicp(ji) * pdqsold(ji) / (zikq - peqAcoef(ji))
+
+      !! lareva_sns is the latent heat sensitivity for evaporation. vbeta1 (src_sechiba/diffuco_snow), 
+      !! vbeta (src_sechiba/diffuco_comb) and valpha (src_sechiba/diffuco_comb) are the evaporation
+      !! coefficients.
+      !! \latexonly 
+      !!     \input{enerbilsurftemp9.tex}
+      !! \endlatexonly
+      lareva_sns = chalev0 * ((un - vbeta1(ji))*(un - vbeta5(ji)) * vbeta(ji) * valpha(ji) + vbeta5(ji)) * &
+              & zicp(ji) * pdqsold(ji) / (zikq - peqAcoef(ji))
+
+WRITE(numout,*) 'lareva_sns', lareva_sns
+     
+
+
+    !! 4. Solution of the energy balance
+      
+      !! 4.1 We calculate the total flux for the 'old' timestep.
+      !! \latexonly 
+      !!     \input{enerbilsurftemp10.tex}
+      !! \endlatexonly
+      sum_old = netrad(ji) + sensfl_old + larsub_old + lareva_old + soilflx(ji)
+WRITE(numout,*) 'sum_ols', sum_old
+
+
+      !! 4.2 We calculate the total sensitivity dtheta (the change in the
+      !! surface static energy over the timestep.
+      !! \latexonly 
+      !!     \input{enerbilsurftemp11.tex}
+      !! \endlatexonly
+      
+
+      
+      sum_sns = netrad_sns + sensfl_sns + larsub_sns + lareva_sns
+WRITE(numout,*) 'sum_sns', sum_sns
+
+
+      !! 4.3 Calculation of dtheta (change in surface static energy over the
+      !! timestep.
+      !! \latexonly 
+      !!     \input{enerbilsurftemp12.tex}
+      !! \endlatexonly
+WRITE(numout,*) 'soilcap', soilcap(ji)
+      dtheta = dtradia * sum_old / (zicp(ji) * soilcap(ji) + dtradia * sum_sns)
+WRITE(numout,*) 'dtheta', dtheta
+
+      !! The new surface saturated humidity can be calculated by equation (69)
+
+      !! 4.4 Determination of state variables for the 'new' timestep
+      !! No we have dtheta, we can determine the surface static energy that
+      !! corresponds to the 'new' timestep.
+      !! \latexonly 
+      !!     \input{enerbilsurftemp13.tex}
+      !! \endlatexonly
+      
+WRITE(numout,*) 'psold', psold(ji)
+      psnew(ji) =  psold(ji) + dtheta
+
+      !! The new surface saturated humidity can be calculated by equation (69)
+      !! of (Dufresne & Ghattas, 2009), in which we substitute dtheta for the
+      !! change between old and new temperature using the relationship from 3.1,
+      !! above.
+      !! \latexonly 
+      !!     \input{enerbilsurftemp14.tex}
+      !! \endlatexonly
+WRITE(numout,*) 'qsol_sat', qsol_sat(ji)
+WRITE(numout,*) 'zicp', zicp(ji)
+WRITE(numout,*) 'pdqsold', pdqsold(ji)
+
+      qsol_sat_new(ji) = qsol_sat(ji) + zicp(ji) * pdqsold(ji) * dtheta
+
+WRITE(numout,*) 'qsol_sat_new', qsol_sat_new(ji)
+      !! The new surface temperature is determined from the new surface static temperature,
+      !! again by using the relationship in section 3.1.
+      !! \latexonly 
+      !!     \input{enerbilsurftemp15.tex}
+      !! \endlatexonly
+
+! tzjE
+WRITE(numout,*) ' surf psnew', psnew(ji)
+      temp_sol_new(ji) = psnew(ji) / cp_air
+WRITE(numout,*) 'surf temp_sol_new', temp_sol_new(ji)
+
+     
+
+      !! 4.5 Calculation of new evaporation potential and new evaporation latent heat
+      !! flux (???)
+      !! \latexonly 
+      !!     \input{enerbilsurftemp16.tex}
+      !! \endlatexonly
+      epot_air_new(ji) = zikt * (sensfl_old - sensfl_sns * dtheta) + psnew(ji)
+      
+      !! \latexonly 
+      !!     \input{enerbilsurftemp17.tex}
+      !! \endlatexonly
+      fevap = (lareva_old - lareva_sns * dtheta) + (larsub_old - larsub_sns * dtheta)
+      IF ( ABS(fevap) < EPSILON(un) ) THEN
+        
+        !! \latexonly 
+        !!     \input{enerbilsurftemp18.tex}
+        !! \endlatexonly
+        qair_new(ji) = qair(ji)
+      ELSE
+        !! \latexonly 
+        !!     \input{enerbilsurftemp19.tex}
+        !! \endlatexonly     
+        qair_new(ji) = zikq * un / ( chalsu0 *  vbeta1(ji) * (un - vbeta5(ji)) + &
+           & chalev0 * ((un - vbeta1(ji))*(un - vbeta5(ji)) * vbeta(ji) * valpha(ji) + vbeta5(ji)) ) &
+           & * fevap + qsol_sat_new(ji)
+      ENDIF
+     
+    ENDDO
+
+
+
+
+    IF (long_print) WRITE (numout,*) ' enerbil_surftemp done '
+
+  END SUBROUTINE enerbil_surftemp
+
+
+ !! =============================================================================================================================
+ !! SUBROUTINE		 			: enerbil_pottemp
+ !!
+ !>\BRIEF		This subroutine computes the surface temperature and humidity should the surface been unstressed	
+ !!
+ !! DESCRIPTION				: 
+ !!
+ !! MAIN OUTPUT VARIABLE(S)	: 
+ !!
+ !! REFERENCE(S)		:
+ !!
+ !! FLOWCHART    : None
+ !!
+ !_ ==============================================================================================================================  
+
+  SUBROUTINE enerbil_pottemp (kjpindex, dtradia, zlev, emis, epot_air, &
+     & petAcoef, petBcoef, qair, peqAcoef, peqBcoef, soilflx, rau, u, v, q_cdrag, vbeta,&
+     & valpha, vbeta1, vbeta5, soilcap, lwdown, swnet, q_sol_pot, temp_sol_pot) 
+
+    ! 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)            :: vbeta5        !! Floodplains 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)           :: q_sol_pot     !! Potential surface air moisture
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: temp_sol_pot  !! Potential soil 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
+
+!_ ==============================================================================================================================
+
+    !++++ CHECK ++++
+    ! temp_sol_pot is an output variable?  Need to initialize it, otherwise
+    ! it goes into the loop with no value.
+    temp_sol_pot(:)=zero
+    q_sol_pot(:)=zero
+    !+++++++++++++++
+
+    zicp = un / cp_air
+    !
+    DO ji=1,kjpindex
+
+       dtheta = zero
+       fevap = zero
+       temp_sol_pot(ji) = temp_sol_pot(ji) + dtheta
+
+       q_sol_pot(ji) = q_sol_pot(ji) + fevap
+
+    ENDDO
+
+  END SUBROUTINE enerbil_pottemp
+
+
+  !!  =============================================================================================================================
+  !! SUBROUTINE		 			: enerbil_flux
+  !!
+  !>\BRIEF					Computes the new soil temperature, net radiation and
+  !! latent and sensible heat flux for the new time step.
+  !!
+  !! DESCRIPTION				: This routine diagnoses, based on the new soil temperature, 
+  !! the net radiation, the total evaporation, the latent heat flux, the sensible heat flux and the 
+  !! sublimination flux. It also diagnoses the potential evaporation used for the fluxes (evapot) and the potential
+  !! as defined by Penman & Monteith (Monteith, 1965) based on the correction term developed by Chris 
+  !! Milly (1992). This Penman-Monteith formulation is required for the estimation of bare soil evaporation 
+  !! when the 11 layer CWRR moisture scheme is used for the soil hydrology.
+  !!
+  !! MAIN OUTPUT VARIABLE(S)	: qsurf, fluxsens, fluxlat, fluxsubli, vevapp, lwup, lwnet,
+  !! tsol_rad, netrad, evapot, evapot_corr
+  !!
+  !! REFERENCE(S)					:
+  !! - Best, MJ, Beljaars, A, Polcher, J & Viterbo, P, 2004. A proposed structure for coupling tiled
+  !! surfaces with the planetary boundary layer. Journal of Hydrometeorology, 5, pp.1271-1278
+  !! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+  !! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+  !! Circulation Model. Journal of Climate, 6, pp.248-273
+  !! - Dufresne, J-L & Ghattas, J, 2009. Description du schÃ©ma de la couche limite turbulente et la
+  !! interface avec la surface planetaire dans LMDZ, Technical note, available (22/12/11):
+  !! http://lmdz.lmd.jussieu.fr/developpeurs/notes-techniques/ressources/pbl_surface.pdf
+  !! - Guimberteau, M, 2010. ModÃ©lisation de l'hydrologie continentale et influences de l'irrigation
+  !! sur le cycle de l'eau, PhD Thesis, available (22/12/11):
+  !! http://www.sisyphe.upmc.fr/~guimberteau/docs/manuscrit_these.pdf
+  !! - Monteith, JL, 1965. Evaporation and Environment, paper presented at Symposium of the Society
+  !! for Experimental Biology
+  !! - Monteith & Unsworth, 2008. Principles of Environmental Physics (third edition), published Elsevier
+  !! ISBN 978-0-12-505103-3
+  !! - Milly, P. C. D., 1992: Potential Evaporation and Soil Moisture in General Circulation Models. 
+  !! Journal of Climate, 5, pp. 209â226.
+  !! - Polcher, J. McAvaney, B, Viterbo, P, Gaertner, MA, Hahmann, A, Mahfouf, J-F, Noilhan, J
+  !! Phillips, TJ, Pitman, AJ, Schlosser, CA, Schulz, J-P, Timbal, B, Verseghy, D &
+  !! Xue, Y, 1998. A proposal for a general interface between land surface schemes and
+  !! general circulation models. Global and Planetary Change, 19, pp.261-276
+  !! - Richtmeyer, RD, Morton, KW, 1967. Difference Methods for Initial-Value Problems.
+  !! Interscience Publishers
+  !! - Schulz, Jan-Peter, Lydia DÃŒmenil, Jan Polcher, 2001: On the Land SurfaceâAtmosphere 
+  !! Coupling and Its Impact in a Single-Column Atmospheric Model. J. Appl. Meteor., 40, 642â663.
+  !!
+  !! FLOWCHART					: None
+  !! \n
+  !_ ==============================================================================================================================
+
+  SUBROUTINE enerbil_flux (kjpindex, dtradia, emis, temp_sol, rau, u, v, q_cdrag, vbeta, valpha, vbeta1, vbeta5, &
+       & qair, epot_air, psnew, qsurf, fluxsens, fluxlat, fluxsubli, vevapp, temp_sol_new, &
+       & lwdown, swnet, lwup, lwnet, pb, tsol_rad, netrad, evapot, evapot_corr, jr_enerbil, beta_diffuco, &
+       & soilflx, soilcap)
+
+    !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                               :: kjpindex      !! Domain size (-)
+    REAL(r_std), INTENT(in)                                  :: dtradia       !! Time step (s)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: emis          !! Emissivity (-)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_sol      !! Surface temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: rau           !! Density (kg m^{-3})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u,v           !! Wind velocity in components u and v (m s^{-1}) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q_cdrag       !! Surface drag (m s^{-1})
+    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)            :: vbeta5        !! Flood resistance 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qair          !! Lowest level specific humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: epot_air      !! Air potential energy (J)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: psnew         !! New surface static energy (J kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_sol_new  !! New soil temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: pb            !! Lowest level pressure (hPa)
+    LOGICAL, INTENT(in)                                      :: jr_enerbil    !! Flag that controls the activation of alternate enerbil scheme (true/false)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: soilflx          !! Soil flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: soilcap          !! Soil calorific capacity (J K^{-1])
+    
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: qsurf         !! Surface specific humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fluxsens      !! Sensible heat flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fluxlat       !! Latent heat flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fluxsubli     !! Energy of sublimation (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: vevapp        !! Total of evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: lwdown        !! Downward long wave radiation (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: swnet         !! Net short wave radiation (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: lwup          !! Long-wave up radiation (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: lwnet         !! Long-wave net radiation (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: tsol_rad      !! Radiative surface temperature (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: netrad        !! Net radiation (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: evapot        !! Soil Potential Evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: evapot_corr   !! Soil Potential Evaporation Correction 
+                                                                              !! (?? mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex)                         :: beta_diffuco
+
+    
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                               :: ji
+    REAL(r_std),DIMENSION (kjpindex)        		         :: grad_qsat
+    REAL(r_std)                               		         :: correction
+    REAL(r_std)                                			 :: speed              !! Speed (m s^{-1}), 
+    REAL(r_std)                                			 :: qc          !! Surface drag coefficient (??)
+    LOGICAL,DIMENSION (kjpindex)            		         :: warning_correction
+!_ ================================================================================================================================
+    
+    DO ji=1,kjpindex
+      
+    !! 1. Determination of 'housekeeping' variables
+      
+      !! The horizontal wind speed is calculated from the velocities along each axis using Pythagorus' theorem. 
+      !! \latexonly 
+      !!     \input{enerbilflux1.tex}
+      !! \endlatexonly
+      speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+      
+      !! From definition, the surface drag coefficient is defined:
+      !! \latexonly 
+      !!     \input{enerbilflux2.tex}
+      !! \endlatexonly
+      qc = speed * q_cdrag(ji)
+    
+    !! 2. Calculation of the net upward flux of longwave radiation
+      
+      !! We first of all calculate the radiation as a result of the Stefan-Boltzmann equation,
+      !! which is the sum of the calculated values at the surface temperature  at the 'old' 
+      !! temperature and the value that corresponds to the difference between the old temperature
+      !! and the temperature at the 'new' timestep.
+      !! \latexonly 
+      !!     \input{enerbilflux3.tex}
+      !! \endlatexonly
+
+      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))      
+      
+      !! We then add to this value that from the reflected longwave radiation:
+      !! \latexonly 
+      !!     \input{enerbilflux4.tex}
+      !! \endlatexonly
+      lwup(ji) = lwup(ji)  +  (un - emis(ji)) * lwdown(ji)
+      
+
+      
+      !! The radiative surface temperature is calculated according to the Stefan-Boltzmann relation:
+      !! \latexonly 
+      !!     \input{enerbilflux5.tex}
+      !! \endlatexonly      
+      ! tsol_rad(ji) = emis(ji) * c_stefan * temp_sol(ji)**4 + lwup(ji)
+
+
+      !! The implicit solution computes an emitted long-wave flux which is a limited Taylor expansion 
+      !! of the future surface temperature around the current values. Thus the long-wave flux does not  
+      !! correspond to the new surface temperature but some intermediate value. So we need to deduce the 
+      !! radiative surface temperature to which this flux corresponds. 
+      !! 
+       tsol_rad(ji) = (lwup(ji)/ (emis(ji) * c_stefan)) **(1./quatre) 
+
+
+     
+      !! qsurf (the surface specific humidity) is a simple diagnostic which will be used by the 
+      !! GCM to compute the dependence of of the surface layer stability on moisture.
+      !! \latexonly 
+      !!     \input{enerbilflux6.tex}
+      !! \endlatexonly
+      qsurf(ji) = (vbeta1(ji) * (un - vbeta5(ji)) + vbeta5(ji)) * qsol_sat_new(ji) + &
+           & (un - vbeta1(ji))*(un - vbeta5(ji)) * vbeta(ji) * valpha(ji) * qsol_sat_new(ji)
+      
+      !! \latexonly 
+      !!     \input{enerbilflux7.tex}
+      !! \endlatexonly
+      qsurf(ji) = MAX(qsurf(ji), qair(ji))
+      
+      !! Net downward radiation is the sum of the down-welling less the up-welling long wave flux, plus
+      !! the short wave radiation.
+      !! \latexonly 
+      !!     \emissivity absorbed lw radiationinput{enerbilflux8.tex}
+      !! \endlatexonly
+      netrad(ji) = lwdown(ji) + swnet(ji) - lwup(ji) 
+      
+      !! 'vevapp' is the sum of the total evaporative processes (snow plus non-snow processes).
+      !! \latexonly 
+      !!     \input{enerbilflux9.tex}
+      !! \endlatexonly
+      vevapp(ji) = dtradia * rau(ji) * qc * (vbeta1(ji) * (un - vbeta5(ji)) + vbeta5(ji)) * &
+           & (qsol_sat_new(ji) - qair(ji)) + &
+           &  dtradia * rau(ji) * qc * (un - vbeta1(ji))*(un-vbeta5(ji)) * vbeta(ji) * &
+           & (valpha(ji) * qsol_sat_new(ji) - qair(ji))
+      
+      !! The total latent heat flux is the sum of the snow plus non-snow processes.
+      !! \latexonly 
+      !!     \input{enerbilflux10.tex}
+      !! \endlatexonly
+      fluxlat(ji) = chalsu0 * rau(ji) * qc * vbeta1(ji) * (un - vbeta5(ji)) * &
+           & (qsol_sat_new(ji) - qair(ji)) + &
+           &  chalev0 * rau(ji) * qc * vbeta5(ji) *&
+           & (qsol_sat_new(ji) - qair(ji)) + &
+           &  chalev0 * rau(ji) * qc * (un - vbeta1(ji)) * (un - vbeta5(ji)) * vbeta(ji) * &
+           & (valpha(ji) * qsol_sat_new(ji) - qair(ji))
+
+
+      !! The sublimination flux concerns is calculated using vbeta1, the snow resistance.
+      !! \latexonly 
+      !!     \input{enerbilflux11.tex}
+      !! \endlatexonly
+      fluxsubli(ji) = chalsu0 * rau(ji) * qc * vbeta1(ji) * (un - vbeta5(ji)) * &
+           & (qsol_sat_new(ji) - qair(ji)) 
+      
+      !! The sensible heat flux is a factor of the difference between the new surface static energy
+      !! and the potential energy of air.
+      !! \latexonly 
+      !!     \input{enerbilflux12.tex}
+      !! \endlatexonly
+      fluxsens(ji) =  rau(ji) * qc * (psnew(ji) - epot_air(ji))
+      
+      !! This is the net longwave downwards radiation.
+      !! \latexonly 
+      !!     \input{enerbilflux13.tex}
+      !! \endlatexonly
+      lwnet(ji) = lwdown(ji) - lwup(ji)
+      
+      !! Diagnoses the potential evaporation used for the fluxes (evapot)
+      !! \latexonly 
+      !!     \input{enerbilflux14.tex}
+      !! \endlatexonly  
+      evapot(ji) =  MAX(zero, dtradia * rau(ji) * qc * (qsol_sat_new(ji) - qair(ji))) 
+     
+
+      
+
+      !! From definition we can say:
+      !! \latexonly 
+      !!     \input{enerbilflux15.tex}
+      !! \endlatexonly 
+      tair(ji)  =  epot_air(ji) / cp_air
+
+    
+
+
+     ENDDO 
+
+  !! 3. Define qsat_air with the subroutine src_parameter:
+
+    ! WRITE(*,*) '181113a test, pre call to qsatcalc enerbil line 1633; tair is: ', tair
+
+    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
+      
+      !! \latexonly 
+      !!     \input{enerbilflux16.tex}
+      !! \endlatexonly 
+      speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+      
+      !! \latexonly 
+      !!     \input{enerbilflux17.tex}
+      !! \endlatexonly 
+      qc = speed * q_cdrag(ji)
+       
+      !! Derive the potential as defined by Penman & Monteith (Monteith, 1965) based on the correction 
+      !! term developed by Chris Milly (1992).
+       IF ((evapot(ji) .GT. zero) .AND. ((psnew(ji) - epot_air(ji)) .NE. zero )) THEN
+          !
+          !! \latexonly 
+          !!     \input{enerbilflux18.tex}
+          !! \endlatexonly 
+          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) )
+          
+          !! \latexonly 
+          !!     \input{enerbilflux19.tex}
+          !! \endlatexonly 
+          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)
+      
+      !! \latexonly 
+      !!     \input{enerbilflux20.tex}
+      !! \endlatexonly 
+       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
+
+
+  !!  ===========================================================================================================================
+  !! SUBROUTINE		 			: enerbil_evapveg
+  !!
+  !>\BRIEF					Splits total evaporation loss into individual process
+  !! components and calculates the assimilation.
+  !!
+  !! DESCRIPTION				: Based on the estimation of the fluxes in enerbil_flux, 
+  !! this routine splits the total evaporation into transpiration interception loss from vegetation, 
+  !! bare soil evaporation and snow sublimation. It then calculates the assimilation.
+  !!
+  !! MAIN OUTPUT VARIABLE(S)	                : vevapsno, vevapnu, transpir, vevapwet
+  !!
+  !! REFERENCE(S)					:
+  !! - Best, MJ, Beljaars, A, Polcher, J & Viterbo, P, 2004. A proposed structure for coupling tiled
+  !! surfaces with the planetary boundary layer. Journal of Hydrometeorology, 5, pp.1271-1278
+  !! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+  !! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+  !! Circulation Model. Journal of Climate, 6, pp.248-273
+  !! - Dufresne, J-L & Ghattas, J, 2009. Description du schÃ©ma de la couche limite turbulente et la
+  !! interface avec la surface planetaire dans LMDZ, Technical note, available (22/12/11):
+  !! http://lmdz.lmd.jussieu.fr/developpeurs/notes-techniques/ressources/pbl_surface.pdf
+  !! - Guimberteau, M, 2010. ModÃ©lisation de l'hydrologie continentale et influences de l'irrigation
+  !! sur le cycle de l'eau, PhD Thesis, available (22/12/11): 
+  !! http://www.sisyphe.upmc.fr/~guimberteau/docs/manuscrit_these.pdf
+  !! - Polcher, J. McAvaney, B, Viterbo, P, Gaertner, MA, Hahmann, A, Mahfouf, J-F, Noilhan, J
+  !! Phillips, TJ, Pitman, AJ, Schlosser, CA, Schulz, J-P, Timbal, B, Verseghy, D &
+  !! Xue, Y, 1998. A proposal for a general interface between land surface schemes and
+  !! general circulation models. Global and Planetary Change, 19, pp.261-276
+  !! - Richtmeyer, RD, Morton, KW, 1967. Difference Methods for Initial-Value Problems.
+  !! Interscience Publishers
+  !! - Schulz, Jan-Peter, Lydia DÃŒmenil, Jan Polcher, 2001: On the Land SurfaceâAtmosphere 
+  !! Coupling and Its Impact in a Single-Column Atmospheric Model. J. Appl. Meteor., 40, 642â663. 
+  !!
+  !! FLOWCHART   : None
+  !! \n
+  !_ ==============================================================================================================================
+
+  SUBROUTINE enerbil_evapveg (kjpindex, dtradia, vbeta1, vbeta2, vbeta3, vbeta3pot, vbeta4, vbeta5, &
+     & rau, u, v, q_cdrag, qair, humrel, vevapsno, vevapnu , vevapflo, vevapwet, &
+!!$     & cimean, ccanopy, rau, u, v, q_cdrag, qair, humrel, vevapsno, vevapnu , vevapflo, vevapwet, &
+     & transpir, transpot, evapot)
+
+    !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                          :: kjpindex          !! Domain size (-)
+    REAL(r_std), INTENT(in)                             :: dtradia           !! Time step (s)
+    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)       :: vbeta5            !! Floodplains resistance
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: rau               !! Density (kg m^{-3})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: u, v              !! Wind velocity in directions u and v (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: q_cdrag           !! Surface drag (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: qair              !! Lowest level specific humidity (kg kg^{-1})
+!!$    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: ccanopy           !! CO2 concentration in the canopy (ppm)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: evapot            !! Soil Potential Evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex, nvm), INTENT (in)  :: humrel            !! Soil moisture stress (within range 0 to 1)
+!!$ DS 15022011 humrel was used in a previous version of Orchidee, developped by Nathalie. Need to be discussed if it should be introduce again             
+    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)   :: vbeta3pot         !! Vegetation resistance for potential transpiration
+!!$    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)   :: cimean            !! STOMATE: mean intercellular ci \mu mole m^{-2} s^{-1}
+    
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: vevapsno          !! Snow evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: vevapnu           !! Bare soil evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: vevapflo         !! Floodplains evaporation
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)  :: transpir          !! Transpiration (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)  :: transpot          !! Potential Transpiration
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)  :: vevapwet          !! Interception (mm day^{-1})
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                      :: ji, jv
+    REAL(r_std), DIMENSION(kjpindex)                    :: xx
+    REAL(r_std), DIMENSION(kjpindex)                    :: vbeta2sum, vbeta3sum
+    REAL(r_std)                                    	:: speed	     !! Speed (m s^{-1})
+!_ ==============================================================================================================================
+    ! initialisation: utile pour calculer l'evaporation des floodplains dans lesquelles il y a de la vegetation
+    vbeta2sum(:) = 0.
+    vbeta3sum(:) = 0.
+    DO jv = 1, nvm
+      vbeta2sum(:) = vbeta2sum(:) + vbeta2(:,jv)
+      vbeta3sum(:) = vbeta3sum(:) + vbeta3(:,jv)
+    ENDDO 
+    
+    !! 1. Compute vevapsno (evaporation from snow) and vevapnu (bare soil evaporation)
+
+    DO ji=1,kjpindex 
+
+      !! \latexonly 
+      !!     \input{enerbilevapveg1.tex}
+      !! \endlatexonly
+      speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+
+      
+      !! 1.1 Snow sublimation
+      !! \latexonly 
+      !!     \input{enerbilevapveg2.tex}
+      !! \endlatexonly
+      vevapsno(ji) = (un - vbeta5(ji)) * vbeta1(ji) * dtradia * rau(ji) * speed * q_cdrag(ji) * (qsol_sat_new(ji) - qair(ji))
+
+      !! 1.2 Bare soil evaporation
+      !! \latexonly 
+      !!     \input{enerbilevapveg3.tex}
+      !! \endlatexonly
+      vevapnu(ji) = (un - vbeta1(ji)) * (un-vbeta5(ji)) * vbeta4(ji) * dtradia * rau(ji) * speed * q_cdrag(ji) &
+         & * (qsol_sat_new(ji) - qair(ji))
+
+      !
+      ! 1.3 floodplains evaporation - transpiration et interception prioritaires dans les floodplains
+      !
+      vevapflo(ji) = vbeta5(ji) * (1 - vbeta2sum(ji) - vbeta3sum(ji)) &
+           & * dtradia * rau(ji) * speed * q_cdrag(ji) * (qsol_sat_new(ji) - qair(ji))
+
+    END DO
+
+    !! 2. Compute transpir (transpiration) and vevapwet (interception)
+  
+    !! Preliminaries
+    DO ji = 1, kjpindex
+       
+       !! \latexonly 
+       !!     \input{enerbilevapveg4.tex}
+       !! \endlatexonly
+       speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+       
+       !! \latexonly 
+       !!     \input{enerbilevapveg5.tex}
+       !! \endlatexonly
+       xx(ji) = dtradia * (un-vbeta1(ji)) * (qsol_sat_new(ji)-qair(ji)) * rau(ji) * speed * q_cdrag(ji)
+       !write(*,*) 'xx_CAN',xx(ji)
+       !write(*,*) 'vbeta1_CAN',vbeta1(ji)
+       !write(*,*) 'qsol_sat_new',qsol_sat_new(ji)
+       !write(*,*) 'qair_CAN',qair(ji)
+       !write(*,*) 'rau_CAN',rau(ji)
+       !write(*,*) 'speed_CAN',speed
+       !write(*,*) 'q_cdragCAN',q_cdrag(ji)
+    ENDDO
+    
+    DO jv=1,nvm 
+      DO ji=1,kjpindex 
+        
+        !! 2.1 Calculate interception loss
+        !! \latexonly 
+        !!     \input{enerbilevapveg6.tex}
+        !! \endlatexonly
+        vevapwet(ji,jv) = xx(ji) * vbeta2(ji,jv)
+        vevapwet(ji,jv) = MAX(0.0,vevapwet(ji,jv)) 
+        !! 2.2 Calculate transpiration
+        !! \latexonly 
+        !!     \input{enerbilevapveg7.tex}
+        !! \endlatexonly
+        transpir (ji,jv) = xx(ji) * vbeta3(ji,jv)
+        transpir(ji,jv)=MAX(0.0,transpir(ji,jv))
+
+        !write(*,*) 'transpirYYT',transpir(ji,jv)
+        !write(*,*) 'qsol_sat_newYYT',qsol_sat_new(ji)
+        !write(*,*) 'qair_YYT',qair(ji)
+        !write(*,*) 'vbeta3_YYT',vbeta3(ji,jv) 
+        !write(*,*) 'vevapwet_YYT',vevapwet(ji,jv)
+
+        transpot(ji,jv) = xx(ji) * vbeta3pot(ji,jv)
+
+      END DO
+    END DO
+
+    IF (long_print) WRITE (numout,*) ' enerbil_evapveg done '
+
+  END SUBROUTINE enerbil_evapveg
+
+ 
+  !!  =============================================================================================================================
+  !! SUBROUTINE		 			: enerbil_fusion
+  !!
+  !>\BRIEF					Computes new soil temperature due to
+  !! ice and snow melt. 
+  !!
+  !! DESCRIPTION				: This routine computes new soil temperature due to
+  !! ice and snow melt. It is the second part of main routine for enerbil module, and is called every
+  !! time step. 
+  !!
+  !! MAIN OUTPUT VARIABLE(S)			: temp_sol_new, fusion
+  !!
+  !! REFERENCE(S)				:
+  !! - Best, MJ, Beljaars, A, Polcher, J & Viterbo, P, 2004. A proposed structure for coupling tiled
+  !! surfaces with the planetary boundary layer. Journal of Hydrometeorology, 5, pp.1271-1278
+  !! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+  !! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+  !! Circulation Model. Journal of Climate, 6, pp.248-273
+  !! - Dufresne, J-L & Ghattas, J, 2009. Description du schÃ©ma de la couche limite turbulente et la
+  !! interface avec la surface planetaire dans LMDZ. Technical note, available (22/12/11):
+  !! http://lmdz.lmd.jussieu.fr/developpeurs/notes-techniques/ressources/pbl_surface.pdf
+  !! - Guimberteau, M, 2010. ModÃ©lisation de l'hydrologie continentale et influences de l'irrigation
+  !! sur le cycle de l'eau. PhD Thesis, available (22/12/11):
+  !! http://www.sisyphe.upmc.fr/~guimberteau/docs/manuscrit_these.pdf
+  !! - Polcher, J. McAvaney, B, Viterbo, P, Gaertner, MA, Hahmann, A, Mahfouf, J-F, Noilhan, J
+  !! Phillips, TJ, Pitman, AJ, Schlosser, CA, Schulz, J-P, Timbal, B, Verseghy, D &
+  !! Xue, Y, 1998. A proposal for a general interface between land surface schemes and
+  !! general circulation models. Global and Planetary Change, 19, pp.261-276
+  !! - Richtmeyer, RD, Morton, KW, 1967. Difference Methods for Initial-Value Problems.
+  !! Interscience Publishers
+  !! - Schulz, Jan-Peter, Lydia DÃŒmenil, Jan Polcher, 2001: On the Land SurfaceâAtmosphere 
+  !! Coupling and Its Impact in a Single-Column Atmospheric Model. J. Appl. Meteor., 40, 642â663.
+  !!
+  !! FLOWCHART  : None
+  !! \n
+  !_ ==============================================================================================================================
+
+  SUBROUTINE enerbil_fusion (kjpindex, dtradia, tot_melt, soilcap, temp_sol_new, fusion )
+
+    !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                               :: kjpindex       !! Domain size (-)
+    REAL(r_std), INTENT(in)                                  :: dtradia        !! Time step (s)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: tot_melt       !! Total melt (??)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: soilcap        !! Soil heat capacity (J K^{-1])
+    
+    !! 0.2 Output variables
+    
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fusion         !! Fusion (??)
+
+    !! 0.3 Modified variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: temp_sol_new   !! New soil temperature (K)
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                	     :: ji	       !! (-)
+  !_ ==============================================================================================================================
+    
+    !! Initialisation
+    IF (long_print) WRITE (numout,*) ' enerbil_fusion start ', MINVAL(soilcap), MINLOC(soilcap),&
+         & MAXVAL(soilcap), MAXLOC(soilcap)
+    
+    !! 1. Calculate new soil temperature due to ice and snow melt
+   
+    DO ji=1,kjpindex 
+      
+      !! \latexonly 
+      !!     \input{enerbilfusion1.tex}
+      !! \endlatexonly
+      fusion(ji) = tot_melt(ji) * chalfu0 / dtradia
+      
+      !! \latexonly 
+      !!     \input{enerbilfusion2.tex}
+      !! \endlatexonly
+      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
+
+
+  !!  =============================================================================================================================
+  !! SUBROUTINE		 			: enerbil_t2mdiag
+  !!
+  !> BRIEF					This routine diagnoses the air temperature at 2
+  !! metres above ground.
+  !!
+  !! DESCRIPTION				: The 2 metre above ground air temperature is currently
+  !! set to be the same as the general air temperaturem, as the surface model currently simulates the 
+  !! above ground atmosphere as a uniform box (and the lowest layer of the LMDZ atmospheric model).
+  !!
+  !! MAIN OUTPUT VARIABLE(S)			: t2mdiag
+  !!
+  !! REFERENCE(S)				:
+  !! - Best, MJ, Beljaars, A, Polcher, J & Viterbo, P, 2004. A proposed structure for coupling tiled
+  !! surfaces with the planetary boundary layer. Journal of Hydrometeorology, 5, pp.1271-1278
+  !! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+  !! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+  !! Circulation Model. Journal of Climate, 6, pp.248-273
+  !! - Dufresne, J-L & Ghattas, J, 2009. Description du schÃ©ma de la couche limite turbulente et la
+  !! interface avec la surface planetaire dans LMDZ, Technical note, available from:
+  !! http://lmdz.lmd.jussieu.fr/developpeurs/notes-techniques/ressources/pbl_surface.pdf
+  !! - Guimberteau, M, 2010. ModÃ©lisation de l'hydrologie continentale et influences de l'irrigation
+  !! sur le cycle de l'eau, PhD Thesis, available from:
+  !! http://www.sisyphe.upmc.fr/~guimberteau/docs/manuscrit_these.pdf
+  !! - Polcher, J. McAvaney, B, Viterbo, P, Gaertner, MA, Hahmann, A, Mahfouf, J-F, Noilhan, J
+  !! Phillips, TJ, Pitman, AJ, Schlosser, CA, Schulz, J-P, Timbal, B, Verseghy, D &
+  !! Xue, Y, 1998. A proposal for a general interface between land surface schemes and
+  !! general circulation models. Global and Planetary Change, 19, pp.261-276
+  !! - Richtmeyer, RD, Morton, KW, 1967. Difference Methods for Initial-Value Problems.
+  !! Interscience Publishers\n
+  !! - Schulz, Jan-Peter, Lydia DÃŒmenil, Jan Polcher, 2001: On the Land SurfaceâAtmosphere 
+  !! Coupling and Its Impact in a Single-Column Atmospheric Model. J. Appl. Meteor., 40, 642â663.
+  !!
+  !! FLOWCHART  : None
+  !! \n
+  !_ ==============================================================================================================================
+
+  SUBROUTINE enerbil_t2mdiag (kjpindex, temp_air, t2mdiag)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                         		:: kjpindex       !! Domain size (-)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      		:: temp_air       !! Air temperature (K)
+    
+    !! 0.2 Output variables
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)    		:: t2mdiag        !! 2-metre temperature (K)
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+  !_ ==============================================================================================================================
+
+    !! The 2 metre air temperature is assumed to be the same of the value of temp_air - the atmospheric air
+    !! temperature, which also taken as the temperature at the lowest level of the LMDZ. 't2mdiag' is just
+    !! a value used for diagnostic purposes, admd it is no applied amywhere else.
+    !! \latexonly 
+ 	!!     \input{enerbilt2mdiag1.tex}
+    !! \endlatexonly
+    t2mdiag(:) = temp_air(:)
+
+    IF (long_print) WRITE (numout,*) ' enerbil_t2mdiag done '
+
+  END SUBROUTINE enerbil_t2mdiag
+
+
+
+
+
+   ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+   SUBROUTINE jdriver (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
+                      & index, indexveg, zlev, lwdown, swnet, &
+                      & epot_air, temp_air, u, v, petAcoef, petBcoef, &
+                      & qair, peqAcoef, peqBcoef, pb, rau, &
+                      & vbeta, valpha, vbeta1, vbeta2, vbeta3, &
+                      & vbeta3pot, vbeta4, vbeta5, &
+!!$                      & vbeta3pot, vbeta4, vbeta5, cimean, ccanopy, &
+                      & emis, soilflx, soilcap, q_cdrag, &
+                      & humrel, fluxsens, fluxlat, vevapp, transpir, &
+                      & transpot, vevapnu, vevapwet, vevapsno, &
+!!$                      & transpot, gpp, vevapnu, vevapwet, vevapsno, &
+                      & vevapflo, t2mdiag, temp_sol, tsol_rad, temp_sol_new, &
+                      & qsurf, evapot, evapot_corr, rest_id, hist_id, & 
+                      & hist2_id, jr_enerbil, &
+                      & flux_ground_h, flux_ground_le, flux_h_grid, flux_le_grid, &
+                      & t_a_next_grid, q_a_next_grid, james_write, temp_surf_next, &
+                      & temp_atmos_pres_grid, q_atmos_pres_grid, &
+                      & james_netcdf_flag, james_step_count, &
+                      & temp_leaf_pres_grid, temp_surf_pres, E_supply, hydrol_flag, &
+                      & hydrol_flag2, hydrol_flag3, vbeta2sum, vbeta3sum, veget_max, &
+                      & qsol_sat_new_out, qair_new, delta_temp_save, netrad, veget)  
+
+     IMPLICIT NONE
+
+     !! 0 Variable and parameter description 
+
+     !! 0.1 Input variables
+
+     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 (s)
+     LOGICAL, INTENT(in)                                     :: jr_enerbil       !! Flag that controls the activation of alternate enerbil scheme (true/false)
+     LOGICAL, INTENT(in)                                     :: james_write      !! Flag for turning all of the verbose write statements on and off
+
+     LOGICAL, INTENT(in)                                     :: hydrol_flag      !! Flag that recalculates the energy budget for the new supply term (true/false)    
+     LOGICAL, DIMENSION (kjpindex), INTENT(in)               :: hydrol_flag2     !! flag that 'trips' the alternative energy budget for each grid square
+     LOGICAL, DIMENSION (kjpindex, nvm), INTENT(in)          :: hydrol_flag3     !! flag that 'trips' the alternative energy budget for each grid square and PFT
+ 
+     REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in)        :: E_supply         !! Supply of water for transpiration (mm timestep^{-1})
+     REAL(r_std), DIMENSION(kjpindex)                        :: E_supply_tot     !! total supply of water for transpiration for each domain (mm timestep^{-1}))
+
+     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), 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)          :: zlev             !! Height of first layer (m)
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: lwdown           !! Down-welling long-wave flux (W m^{-2})
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: swnet            !! Net surface short-wave flux (W m^{-2})
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: epot_air         !! Air potential energy (?? J)
+    
+     REAL(r_std), DIMENSION (kjpindex)                       :: temp_air         !! Air temperature (K)
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: u                !! Eastward Lowest level wind speed  (m s^{-1})
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: v                !! Northward Lowest level wind speed (m s^{-1})
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: petAcoef         !! PetAcoef (see note)
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: petBcoef         !! PetBcoef (see note)
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: peqAcoef         !! PeqAcoef (see note)
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: peqBcoef         !! PeqBcoef (see note)
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: pb               !! Lowest level pressure hPa)
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: rau              !! Air density (kg m^{-3})
+    
+     REAL(r_std), DIMENSION (kjpindex), INTENT (inout)          :: 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)          :: vbeta5           !! Floodplains resistance
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: emis             !! Emissivity (-)
+    
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: soilflx          !! Soil flux (W m^{-2})
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: soilcap          !! Soil calorific capacity (J K^{-1])
+    
+     REAL(r_std), DIMENSION (kjpindex), INTENT (inout)          :: q_cdrag          !! Surface drag (m s^{-1})
+!!$     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: ccanopy          !! CO_2 concentration in the canopy (ppm)
+     REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)      :: humrel           !! Soil moisture stress (within range 0 to 1)
+     REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)      :: vbeta2           !! Interception resistance (-)
+     REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)      :: vbeta3pot        !! Vegetation resistance for potential transpiration
+!!$     REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)      :: vbetaco2         !! Vegetation resistance to CO2 (-)
+!!$     REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)      :: cimean           !! mean intercellular ci (from STOMATE) 
+!!$                                                                                !! (\mu mole m^{-2} s^{-1})
+
+     REAL(r_std), DIMENSION (kjpindex)                       :: qair             !! Lowest level specific humidity (kg kg^{-1})
+
+     INTEGER, INTENT(in)                                     :: james_step_count
+
+     REAL(r_std),  DIMENSION (kjpindex, nvm), INTENT(in)     :: veget_max      !! Max. fraction of vegetation type (LAI -> infty, unitless)
+     REAL(r_std),  DIMENSION (kjpindex, nvm), INTENT(in)     :: veget          !! Vegetation fraction for each pft 
+  
+!!$     REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)       :: gpp              !! Assimilation ((gC m^{-2}), total area)                , INTENT (inout)
+
+     ! variables for netCDF preparation
+     LOGICAL, INTENT(in)                                     :: james_netcdf_flag !! Flag that controls the netCDF output routine
+
+     ! REAL(r_std), INTENT(in)                                 :: top_jnlvls
+     ! CHARACTER(LEN=256), INTENT(in)                          :: jamescdfname           !! To store the name of the multilayer netCDF output file (seperate to the rest)
+
+
+
+     !! 0.2 Output variables
+
+     REAL(r_std), DIMENSION (kjpindex), INTENT(out)          :: vevapnu          !! Bare soil evaporation (mm day^{-1})            , INTENT (out) 
+     REAL(r_std), DIMENSION (kjpindex), INTENT(out)          :: vevapsno         !! Snow evaporation (mm day^{-1})                 , INTENT (out)
+     REAL(r_std), DIMENSION (kjpindex), INTENT(out)          :: vevapflo         !! Floodplains evaporation                        , INTENT (out) 
+     REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(out)      :: transpir         !! Transpiration (mm day^{-1})                    , INTENT (out)
+     REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(out)      :: transpot         !! Potential transpiration                        , INTENT (out)
+     REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(out)      :: vevapwet         !! Interception (mm day^{-1})                     , INTENT (out)
+     REAL(r_std), DIMENSION (kjpindex), INTENT(out)          :: t2mdiag          !! JJJ Diagnostic temperature at 2m above ground (K)  , INTENT (out)
+
+       
+     REAL(r_std), INTENT(out)                           :: temp_surf_pres        ! temperature at surface (K) PRESENT STEP
+     REAL(r_std), INTENT(out)                           :: temp_surf_next        ! temperature at surface (K) NEXT STEP
+     REAL(r_std), INTENT(out)                           :: flux_ground_h         ! ground level sensible heat flux (W/m^2)
+     REAL(r_std), INTENT(out)                           :: flux_ground_le        ! ground level latent heat flux (W/m^2)
+
+     
+     REAL(r_std), DIMENSION(kjpindex,jnlvls), INTENT(out)       :: flux_h_grid                ! sensible heat flux down the column (W/m^2)
+     REAL(r_std), DIMENSION(kjpindex,jnlvls), INTENT(out)       :: flux_le_grid               ! latent heat flux down the column (W/m^2)
+     REAL(r_std), DIMENSION(kjpindex,jnlvls), INTENT(out)       :: q_atmos_pres_grid          ! atmospheric specific humididy down the column (kg/kg) PRESENT STEP
+     REAL(r_std), DIMENSION(kjpindex,jnlvls), INTENT(out)       :: t_a_next_grid              ! t
+     REAL(r_std), DIMENSION(kjpindex,jnlvls), INTENT(out)       :: q_a_next_grid
+
+     REAL(r_std), DIMENSION (kjpindex), INTENT(out)            :: qsol_sat_new_out  !! New saturated surface air moisture (kg kg^{-1})
+     REAL(r_std),DIMENSION (kjpindex), INTENT(out)             ::  qair_new
+
+     !! 0.3 Modified variables
+    
+     REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (inout)   :: vbeta3           !! Vegetation resistance (-)
+    
+     REAL(r_std), DIMENSION (kjpindex), INTENT(inout)        :: evapot           !! Soil Potential Evaporation (mm day^{-1})              , INTENT (inout)
+     REAL(r_std), DIMENSION (kjpindex), INTENT(inout)        :: evapot_corr      !! Soil Potential Evaporation Correction (mm day^{-1})   , INTENT (inout)
+     REAL(r_std), DIMENSION (kjpindex), INTENT(inout)        :: temp_sol         !!      JJJ     Soil temperature (K)                     , INTENT (inout)
+     REAL(r_std), DIMENSION (kjpindex), INTENT(inout)        :: qsurf            !! Surface specific humidity (kg kg^{-1})                , INTENT (inout)
+     REAL(r_std), DIMENSION (kjpindex), INTENT(inout)        :: fluxsens         !!     ! JJJ     Sensible heat flux (W m^{-2})           , INTENT (inout)
+     REAL(r_std), DIMENSION (kjpindex), INTENT(inout)        :: fluxlat          !!     ! JJJ      Latent heat flux (W m^{-2})            , INTENT (inout)
+     REAL(r_std), DIMENSION (kjpindex), INTENT(inout)        :: netrad           !!     ! YC     Net radiation flux (W m^{-2})            , INTENT (inout)
+     REAL(r_std), DIMENSION (kjpindex), INTENT(inout)        :: tsol_rad         !! Tsol_rad (W m^{-2})                                   , INTENT (inout)
+     REAL(r_std), DIMENSION (kjpindex), INTENT(inout)        :: vevapp           !! Total of evaporation (mm day^{-1})                    , INTENT (inout)
+
+     REAL(r_std), DIMENSION (kjpindex), INTENT(inout)        :: temp_sol_new     !!     ! JJJ     New soil temperature (K)                , INTENT (out)
+
+     REAL(r_std), DIMENSION(kjpindex), INTENT(inout)         :: vbeta2sum
+     REAL(r_std), DIMENSION(kjpindex), INTENT(inout)         :: vbeta3sum
+
+
+     REAL(r_std), DIMENSION (kjpindex,jnlvls), INTENT(inout) :: temp_atmos_pres_grid    ! atmospheric temperature down the column (K) PRESENT STEP
+     REAL(r_std), DIMENSION (kjpindex,jnlvls), INTENT(inout) :: temp_leaf_pres_grid     ! leaf temperature down the column (K) PRESENT STEP
+
+     REAL(r_std),DIMENSION (kjpindex), INTENT(inout)         :: delta_temp_save     
+
+
+     !! 0.4 Local variables
+
+     INTEGER(i_std)                          :: i, j
+
+     REAL(r_std), DIMENSION(jnlvls)          :: horiz_flux_t,  horiz_flux_q
+
+     REAL(r_std)                             :: u_star                ! friction velocity (m/s)
+
+     REAL(r_std), DIMENSION (jnlvls)         :: cum_pad_deltah        ! Cumulative Plant Area Density multiplied by layer height
+     REAL(r_std), DIMENSION (jnlvls)         :: h_flux, le_flux
+     REAL(r_std), DIMENSION (jnlvls)         :: u_speed               ! wind speed at specified canopy level (m/s)
+
+     REAL(r_std)                             :: q_surf_next           ! specific humidity at surface (kg/kg) NEXT STEP
+
+     REAL(r_std), DIMENSION (jnlvls)         :: temp_atmos_next       ! atmospheric temperature down the column (K) NEXT STEP
+     REAL(r_std), DIMENSION (jnlvls)         :: temp_leaf_next        ! leaf temperature down the column (K) NEXT STEP
+     REAL(r_std), DIMENSION (jnlvls)         :: q_leaf_pres           ! leaf specific humidity down the column (kg/kg) PRESENT STEP
+     REAL(r_std), DIMENSION (jnlvls)         :: q_atmos_next          ! atmospheric specific humididy down the column (kg/kg) NEXT STEP
+     REAL(r_std), DIMENSION (jnlvls)         :: q_leaf_next           ! leaf specific humidity down the column (kg/kg) NEXT STEP
+
+     REAL(r_std), DIMENSION (jnlvls)         :: jalpha  
+     REAL(r_std), DIMENSION (jnlvls)         :: jbeta 
+     REAL(r_std), DIMENSION (jnlvls)         :: k_eddy                 ! eddy transport coefficient (m^2 s-1)
+     REAL(r_std)                             :: k_eddy_surf            ! surface eddy transport coefficient (m^2 s-1)
+
+     REAL(r_std), DIMENSION (jnlvls)         :: down_sw_tab, down_lw_tab
+     REAL(r_std), DIMENSION (jnlvls)         :: big_r, big_r_prime
+
+     REAL(r_std), DIMENSION (timesteps)      :: ustar_ac               ! input friction velocity above the canopy (m/s)
+
+
+     REAL(r_std)                             :: layer_height
+     REAL(r_std), DIMENSION(jnlvls)          :: delta_h                ! height of each level (m)
+     REAL(r_std)                             :: delta_h_surf           ! height of surface level (m)
+     REAL(r_std), DIMENSION (jnlvls)         :: delta_z                ! vertical difference between the middle of each box (m)
+     REAL(r_std)                             :: delta_z_surf           ! vertical difference between the middle of the surface layer
+                                                                       !    and the middle of the first layer (m)
+
+     REAL(r_std)                             :: box_height_surf        ! height of bottom of surface layer box (m)
+     REAL(r_std), DIMENSION(kjpindex)        :: jalpha_surf, jbeta_surf
+     REAL(r_std), DIMENSION(jnlvls)          :: big_e, big_f, big_g
+     REAL(r_std), DIMENSION(jnlvls)          :: a_t, b_t, c_t, d_t
+     REAL(r_std), DIMENSION(jnlvls)          :: a_q, b_q, c_q, d_q
+     REAL(r_std), DIMENSION(jnlvls)          :: jemissivity
+     REAL(r_std), DIMENSION(jnlvls)          :: big_pad                ! plant area density at each level (m^2/m^3)
+     REAL(r_std), DIMENSION(jnlvls)          :: eta_1, eta_2, eta_3, eta_4, jomega
+     REAL(r_std)                             :: eta_1_surf, eta_2_surf
+     REAL(r_std)                             :: eta_3_surf, eta_4_surf, eta_3_above
+     REAL(r_std)                             :: eta_1_above, eta_4_above, eta_2_above           
+
+     REAL(r_std), DIMENSION (kjpindex,jnlvls)     :: temp_leaf_next_grid     ! leaf temperature down the column (K) PRESENT STEP
+
+     REAL(r_std)                                  :: delta_energy_surf
+     REAL(r_std), DIMENSION (kjpindex,jnlvls)     :: delta_energy
+     REAL(r_std), DIMENSION (jnlvls)              :: jtheta
+     REAL(r_std)                                  :: r_sto_v_fac, big_r_h2o_fac
+     REAL(r_std)                                  :: big_r_heat_fac, k_eddy_fac
+     REAL(r_std), DIMENSION(jnlvls)               :: jomega_sw
+     REAL(r_std)                                  :: jomega_surf
+     REAL(r_std)                                  :: jemissivity_surf
+     REAL(r_std)                                  :: jomega_sw_surf         ! emissivity of surface layer
+     REAL(r_std)                                  :: surf_lev
+     REAL(r_std), DIMENSION(jnlvls+1)               :: top_lev    
+     REAL(r_std), DIMENSION(kjpindex)             :: q_sat_surf
+     REAL(r_std)                                  :: zikt, zikq, speed
+     REAL(r_std)                                  :: delta_temp             ! change in temperature over the time step (Kelvins)
+     REAL(r_std), DIMENSION(kjpindex)             :: jpdqsold
+     REAL(r_std),DIMENSION (kjpindex)             :: epot_air_new
+     CHARACTER(LEN=256)                           :: var_name               !! To store variables names for I/O
+
+     REAL(r_std), DIMENSION (jnlvls)              :: t_l_pres, t_l_next
+
+
+     REAL, DIMENSION (0:jnlvls+1, 0:jnlvls+1)     :: ngu_alpha
+
+     REAL(r_std), DIMENSION(kjpindex)             :: dev_qsol
+
+     REAL(r_std), DIMENSION(kjpindex)             :: gs_effective   !! 'effective' stomatal conductance
+     REAL(r_std), DIMENSION(kjpindex)             :: vbeta3_effective
+
+     !! 0.4 Local variables (JR 050913 for the calculation of evapot_corr)
+
+     INTEGER(i_std)                               :: ji, jv
+     INTEGER(i_std)                               :: ier
+     REAL(r_std), DIMENSION (kjpindex)            :: grad_qsat
+     REAL(r_std)                                  :: correction
+     REAL(r_std)                                  :: qc                 !! Surface drag coefficient (??)
+     LOGICAL, DIMENSION (kjpindex)                :: warning_correction
+     REAL(r_std), DIMENSION (kjpindex)            :: E_supply_sum
+
+
+
+    ! each potential input variable is listed separately - can't see a good way that this 
+    !    can be avoided in Fortran
+
+    REAL(r_std)          :: pad_lev_1, pad_lev_2, pad_lev_3, pad_lev_4 
+    REAL(r_std)          :: pad_lev_5, pad_lev_6, pad_lev_7, pad_lev_8 
+    REAL(r_std)          :: pad_lev_9, pad_lev_10, pad_lev_11, pad_lev_12 
+    REAL(r_std)          :: pad_lev_13, pad_lev_14, pad_lev_15, pad_lev_16 
+    REAL(r_std)          :: pad_lev_17, pad_lev_18, pad_lev_19, pad_lev_20
+    REAL(r_std)          :: pad_lev_21, pad_lev_22, pad_lev_23, pad_lev_24 
+    REAL(r_std)          :: pad_lev_25, pad_lev_26, pad_lev_27, pad_lev_28 
+    REAL(r_std)          :: pad_lev_29, pad_lev_30, pad_lev_31, pad_lev_32 
+    REAL(r_std)          :: pad_lev_33, pad_lev_34, pad_lev_35, pad_lev_36 
+    REAL(r_std)          :: pad_lev_37, pad_lev_38, pad_lev_39, pad_lev_40
+    REAL(r_std)          :: pad_lev_41, pad_lev_42, pad_lev_43, pad_lev_44 
+    REAL(r_std)          :: pad_lev_45, pad_lev_46, pad_lev_47, pad_lev_48 
+    REAL(r_std)          :: pad_lev_49, pad_lev_50    
+
+    REAL(r_std)          :: height_lev_1, height_lev_2, height_lev_3, height_lev_4 
+    REAL(r_std)          :: height_lev_5, height_lev_6, height_lev_7, height_lev_8 
+    REAL(r_std)          :: height_lev_9, height_lev_10, height_lev_11, height_lev_12 
+    REAL(r_std)          :: height_lev_13, height_lev_14, height_lev_15, height_lev_16 
+    REAL(r_std)          :: height_lev_17, height_lev_18, height_lev_19, height_lev_20
+    REAL(r_std)          :: height_lev_21, height_lev_22, height_lev_23, height_lev_24 
+    REAL(r_std)          :: height_lev_25, height_lev_26, height_lev_27, height_lev_28 
+    REAL(r_std)          :: height_lev_29, height_lev_30, height_lev_31, height_lev_32 
+    REAL(r_std)          :: height_lev_33, height_lev_34, height_lev_35, height_lev_36 
+    REAL(r_std)          :: height_lev_37, height_lev_38, height_lev_39, height_lev_40
+    REAL(r_std)          :: height_lev_41, height_lev_42, height_lev_43, height_lev_44 
+    REAL(r_std)          :: height_lev_45, height_lev_46, height_lev_47, height_lev_48 
+    REAL(r_std)          :: height_lev_49, height_lev_50
+
+    REAL(r_std)          :: top_jnlvls
+    
+    CHARACTER(len=256)  :: jname
+    CHARACTER(len=256)  :: jname2
+    CHARACTER(len=256)  :: format_string
+
+
+    REAL(r_std), DIMENSION (0:jnlvls+1)                  :: ngu_bign
+
+    REAL(r_std), DIMENSION (0:jnlvls+1)                  :: ngu_alpha_insert
+
+
+
+!_ =======================================================================================
+    
+    
+    IF (l_first_jenerbil) THEN
+
+        l_first_jenerbil=.FALSE.
+
+        ALLOCATE (pad_deltah(0:jnlvls),stat=ier)
+        IF (ier.NE.0) THEN
+            WRITE (numout,*) ' error in pad_deltah allocation. '
+        END IF
+        
+        ALLOCATE (box_height(jnlvls+1),stat=ier)
+        IF (ier.NE.0) THEN
+            WRITE (numout,*) ' error in box_height allocation.'
+        END IF
+
+
+
+
+        ! no read-in profile for single layer case
+
+        ! set a default value of box_height
+        box_height(:) = 1.0d0        
+        
+        ! set a default value of pad_deltah
+        pad_deltah(:) = 1.0d0
+
+
+        
+
+        ! These variables will require the configuration infrastructure
+        !
+        !Config Key   = top_jnlvls
+        !Config If    = JENERBIL
+        !Config Desc  = Value of the boundary resistance factor
+        !Config Def   = one_day??
+        !Config Help  = This is the value of the boundary resistance factor. 
+        !Config         Default value is: 1.0
+        !Config Units = [-]
+        !
+        ! set a default value of top_jnlvls
+        top_jnlvls = 1.0d0
+
+        CALL getin_p('TOP_jnlvls', top_jnlvls)
+
+
+
+
+        ! set a default value of jamescdfname
+        jamescdfname = 'jamescdf.nc'
+
+        ! These variables will require the configuration infrastructure
+        !
+        !Config Key   = jamescdfname
+        !Config If    = JAMESCDFNAME
+        !Config Desc  = Name of the output CDF file
+        !Config Def   = one_day??
+        !Config Help  = This values gives the name of the output CDF file. 
+        !Config         Default value is: jamescdf.nc
+        !Config Units = [-]
+        !    
+        CALL getin_p('JAMESCDFNAME', jamescdfname)
+
+
+
+
+        ! WRITE(numout,*) 'in jdriver, james_step_count = ', james_step_count
+        jamescdfname = '/home/users/jryder/james.ryder/'//jamescdfname
+
+
+        ! read in both the plant area density and the height of each level      
+
+
+
+        ! These variables will require the configuration infrastructure
+        !
+        !Config Key   = pad_lev_
+        !Config If    = PAD_LEV_
+        !Config Desc  = Plant area density of level indicated
+        !Config Def   = one_day??
+        !Config Help  = This values provides the plant area density of the level indicated 
+        !Config         Default value is: 1.0d0
+        !Config Units = [-]
+        ! 
+        ! set a default value of pad_deltah
+        pad_deltah(:) = 1.0d0
+   
+        DO i=1, jnlvls
+            format_string = "(A8,I0)"
+            WRITE (jname,format_string) "PAD_LEV_", i
+            jname2 = TRIM(jname)
+            CALL getin_p(jname2, pad_deltah(i))
+        END DO
+
+
+
+
+       ! These variables will require the configuration infrastructure
+       !
+       !Config Key   = height_lev_
+       !Config If    = HEIGHT_LEV_
+       !Config Desc  = Height of individual level indicated
+       !Config Def   = one_day??
+       !Config Help  = This values provides the height of the individual level indicated 
+       !Config         Default value is: 1.0d0
+       !Config Units = [-]
+       !    
+       DO i=1, jnlvls+1
+          format_string = "(A11,I0)"
+          WRITE (jname,format_string) "HEIGHT_LEV_", i
+          jname2 = TRIM(jname)
+          CALL getin_p(jname2, box_height(i))
+       END DO
+
+
+
+
+       ! set a default value of big_k_lw (if there is nothing provided in run.def)
+       big_k_lw = 0.8d0
+	
+       ! These variables will require the configuration infrastructure
+       !
+       !Config Key   = LW_EXTINCTION_COEF
+       !Config If    = JENERBIL
+       !Config Desc  = Value of the extinction coeffecient
+       !Config Def   = one_day??
+       !Config Help  = This values gives the value of the LW extinction coefficient. 
+       !Config         Default value is: 0.8
+       !Config Units = [-]
+       !
+       CALL getin_p('LW_EXTINCTION_COEF', big_k_lw)
+
+
+	
+	
+       ! set a default value of big_k_sw (if there is nothing provided in run.def)
+       big_k_sw = 0.45d0
+	
+       ! These variables will require the configuration infrastructure
+       !
+       !Config Key   = SW_EXTINCTION_COEF
+       !Config If    = JENERBIL
+       !Config Desc  = Value of the extinction coeffecient
+       !Config Def   = one_day??
+       !Config Help  = This values gives the value of the LW extinction coefficient. 
+       !Config         Default value is: 0.45
+       !Config Units = [-]
+       !
+       CALL getin_p('SW_EXTINCTION_COEF', big_k_sw)
+
+
+
+
+       ! set a default value of k_eddy_fac
+       k_eddy_fac = 1.0_r_std
+
+       CALL getin_p('K_EDDY_FAC', k_eddy_fac)
+
+
+
+
+       ! set a default value of sr_fac
+       sr_fac = 1.0_r_std
+
+       ! These variables will require the configuration infrastructure
+       !
+       !Config Key   = SR_FAC
+       !Config If    = JENERBIL
+       !Config Desc  = Value of the stomatal resistance factor
+       !Config Def   = one_day??
+       !Config Help  = This is the value of the stomatal resistance factor. 
+       !Config         Default value is: 1.0
+       !Config Units = [-]
+       !
+       CALL getin_p('SR_FAC', sr_fac)
+
+
+
+
+       ! set a default value of hd_big_r_prime
+       hd_big_r_prime = 1.0_r_std
+       !
+       !Config Key   = HD_BIG_R_PRIME
+       !Config If    = JENERBIL
+       !Config Desc  = 'hardwired' big r resistance
+       !Config Def   = one_day??
+       !Config Help  = This is the 'hardwired' big r prime resistance, for testing 
+       !Config         Default value is: 1.0
+       !Config Units = [-]
+       !
+       CALL getin_p('HD_BIG_R_PRIME', hd_big_r_prime)
+
+
+       big_r=un
+
+
+
+    
+       ! set a default value of br_fac
+       br_fac = 1.0_r_std
+
+       ! These variables will require the configuration infrastructure
+       !
+       !Config Key   = BR_FAC
+       !Config If    = JENERBIL
+       !Config Desc  = Value of the boundary resistance factor
+       !Config Def   = one_day??
+       !Config Help  = This is the value of the boundary resistance factor. 
+       !Config         Default value is: 1.0
+       !Config Units = [-]
+       !
+       CALL getin_p('BR_FAC', br_fac)
+
+
+
+       !
+       ! set a default value of hd_big_r
+       hd_big_r = 1.0_r_std
+
+       !Config Key   = HD_BIG_R
+       !Config If    = JENERBIL
+       !Config Desc  = 'hardwired' big r resistance
+       !Config Def   = one_day??
+       !Config Help  = This is the 'hardwired' big r resistance, for testing 
+       !Config         Default value is: 1.0
+       !Config Units = [-]
+       !
+       CALL getin_p('HD_BIG_R', hd_big_r)
+
+    ENDIF
+
+
+    ! set a default value of top_jnlvls
+    top_jnlvls = 1.0d0
+  
+    pad_deltah(0) = 0.0d0
+
+
+
+
+
+    ! for cases in which we exit the loop if hydrol_flag2 is false
+    epot_air_new = epot_air
+    temp_sol_new = temp_sol
+
+    ! initialise variables that are required for multilayer scheme
+
+    u_h = 0.0d0
+    q_leaf_pres(:) = 0.0d0                
+    temp_atmos_next(:) = 0.0d0; temp_leaf_next(:) = 0.0d0     
+    q_atmos_next(:) = 0.0d0; q_leaf_next(:) = 0.0d0       
+    jalpha = 0.0d0; jbeta = 0.0d0
+    temp_surf_next = 0.0d0; q_surf_next = 0.0d0
+    jemissivity(:) = 0.96d0
+    r_sto_v_fac = 1.0d0
+    big_r_h2o_fac = 5.0d0
+    big_r_heat_fac = 1.0d0
+    k_eddy_fac = 1.0d0
+    jtheta = 4.18d3                      ! specific heat capacity of vegetation (assumed equal to water J/(kg K))
+    rho_veg = 1000.0d0                   ! assume that density of vegetation is as for pure water for now (1000 kg/m^3)
+    leaf_tks = 0.0017d0                  ! leaf thickness (derived from TRY database) 
+
+    a_t = 0; b_t = 0; c_t = 0; d_t = 0
+    a_q = 0; b_q = 0; c_q = 0; d_q = 0
+
+    top_lev(:) = box_height(:)
+    surf_lev = 0.0d0
+    box_height_surf = 0.0d0 ! infinitesimal surface layer
+    delta_h_surf = 0.0d0    ! infinitesimal surface layer
+    delta_z_surf = 0.5d0
+    delta_z(:) = 1.0d0 
+    delta_h(:) = 1.0d0
+
+
+    ! initialise variables that are required for the enerbil to hydrol interface
+    E_supply_sum(:) = 0.0d0
+    E_supply_tot(:) = 0.0d0
+
+
+    ! calculate wind speed based on input velocities
+    speed = MAX(min_wind, SQRT (u(1)*u(1) + v(1)*v(1)))
+
+
+    ! collate E_supply by grid square - this is necessary as the energy budget is calculated as a combination of all PFTs
+    !    within one grid square, whereas the hydrological architecture is calculated per individual PFT, per grid square.
+
+! tzjE here no ELSE case what happens when veget_max is set to zero
+    IF (hydrol_flag) THEN
+       DO ji = 1, kjpindex
+          DO jv = 1, nvm
+              IF (hydrol_flag3(ji,jv)) THEN
+                 E_supply_sum(ji) = E_supply_sum(ji) + E_supply(ji, jv) / veget_max(ji,jv)
+     !         WRITE(numout,*) 'E_supply_sum', E_supply_sum(ji)
+     !         WRITE(numout,*) 'veget_max', veget_max(ji,jv)
+             ! write(*,*) 'E_supply', E_supply(ji,jv)
+              ELSE
+!              WRITE(numout,*) 'NO hydrol_flag3'
+              END IF
+          END DO ! jv = 1, nvm
+       END DO ! ji = 1, kjpindex
+       E_supply_tot(:) = E_supply_sum(:)
+!              WRITE(numout,*) 'E_supply_tot', E_supply_tot
+    ELSE 
+       ! do nothing as the hydrol_flag has not been set (within sechiba)
+    END IF
+
+
+    ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
+
+
+
+    ! as per the original scheme
+
+    CALL jenerbil_begin (kjpindex, temp_sol, lwdown, swnet, pb, &
+                         & psold, qsol_sat, pdqsold, netrad, emis, &
+                         & jr_enerbil, dev_qsol)
+
+
+    ! calculates the in-canopy transport profile
+    ! IF (jnlvls .eq. 1) THEN
+        ! no transport profile for single layer case
+    ! ELSE
+        CALL jprofile (pad_deltah, cum_pad_deltah, layer_height, ustar_ac, delta_z, &
+                    & delta_h, box_height, k_eddy, delta_h_surf, delta_z_surf, &
+                    & box_height_surf, u_star, speed, u_speed, big_pad, &
+                    & k_eddy_fac, k_eddy_surf, surf_lev, top_lev)
+    ! END IF !(jnlvls .eq. 1)    
+
+    IF (jnlvls .eq. 1) THEN
+       ! no radiation profile for single layer case
+       eta_1(:)=zero
+       eta_2(:)=zero
+       eta_3(:)=zero
+       eta_4(:)=zero
+       jomega(:)=zero
+       jomega_sw(:)=zero
+       jemissivity(:)=zero
+       jemissivity_surf=zero
+       eta_1_surf=zero
+       eta_2_surf=zero
+       eta_3_surf=zero
+       eta_4_surf=zero
+       ngu_alpha(:,:)=zero
+       jomega_surf=zero
+       jomega_sw_surf=zero
+       eta_1_above=zero
+       eta_2_above=zero
+       eta_3_above=zero
+       eta_4_above=zero
+    ELSE
+        CALL calc_jradiation_scheme (eta_1, eta_2, eta_3, eta_4, jomega, &
+                    & jemissivity, temp_leaf_pres_grid, temp_surf_pres, &
+                    & pad_deltah, jomega_sw, eta_1_surf, eta_2_surf, &
+                    & eta_3_surf, eta_4_surf, jemissivity_surf, &
+                    & jomega_surf, jomega_sw_surf, & 
+                    & eta_3_above, eta_1_above, eta_4_above, &
+                    & eta_2_above, james_write, ngu_alpha, &
+                    & ngu_alpha_insert, kjpindex, &
+                    & big_k_lw, big_k_sw)
+    END IF !(jnlvls .eq. 1)    
+
+ 
+    ! calculates the stomatal resistance
+    ! IF (jnlvls .eq. 1) THEN
+        ! use assigned beta coefficients for single layer case
+    ! ELSE
+        CALL calc_stomatal_resistance (pad_deltah, swnet, lwdown, pb, & 
+                    & down_sw_tab, down_lw_tab, big_r_prime, &
+                    & temp_atmos_pres_grid, q_atmos_pres_grid, big_r, &
+                    & u_speed, r_sto_v_fac, big_r_h2o_fac, rau, kjpindex, &
+                    & sr_fac, hd_big_r_prime)
+    ! END IF !(jnlvls .eq. 1)        
+
+
+    ! calculates the boundary layer resistance
+    ! IF (jnlvls .eq. 1) THEN
+        ! use assigned beta coefficients for single layer case
+    ! ELSE
+        CALL calc_boundarylayer_resistance (big_r, u_speed, temp_atmos_pres_grid, &
+                   & big_r_heat_fac, kjpindex, br_fac, hd_big_r) 
+    ! END IF !(jnlvls .eq. 1)        
+
+    ! calculates the jalpha and jbeta coefficients (only required in the multilayer case)
+    CALL calc_jalpha_and_jbeta (temp_atmos_pres_grid, temp_leaf_pres_grid, &
+                    & jalpha, jbeta, jalpha_surf, jbeta_surf, & 
+                    & temp_surf_pres, q_sat_surf, &
+                    & kjpindex, pb, temp_sol, &
+                    & james_write, jpdqsold)
+
+
+    ! the central energy budget calculation routine
+
+    CALL jcalc (pad_deltah, layer_height, big_r, big_r_prime, delta_z, &
+                 & k_eddy, swnet, lwdown, &
+                 & temp_atmos_pres_grid, q_atmos_pres_grid, & 
+                 & a_t, b_t, c_t, d_t, & 
+                 & a_q, b_q, c_q, d_q, & 
+                 & big_e, big_f, big_g, &
+                 & jalpha, jbeta, temp_leaf_pres_grid, delta_h, &
+                 & eta_1, eta_2, eta_3, eta_4, &
+                 & k_eddy_surf, delta_z_surf, jtheta, & 
+                 & jalpha_surf, jbeta_surf, & 
+                 & rau, temp_surf_pres, &
+                 & soilcap, soilflx, speed, & 
+                 & q_cdrag, &
+                 & kjpindex, jr_enerbil, &
+                 & flux_ground_h, flux_ground_le, flux_h_grid, flux_le_grid, &
+                 & u_speed, t_a_next_grid, q_a_next_grid, & 
+                 & james_write, temp_surf_next, &
+                 & eta_1_surf, eta_2_surf, eta_3_surf, eta_4_surf, &
+                 & temp_leaf_next_grid, &
+                 & epot_air_new, delta_temp, &
+                 & horiz_flux_t, horiz_flux_q, &
+                 & ngu_bign, ngu_alpha, ngu_alpha_insert, qair_new, qair, &
+                 & emis, temp_sol_new, vbeta1, vbeta4, vbeta5, vbeta2, &
+                 & vbeta3, vbeta3pot, vbeta, fluxsens, fluxlat, netrad, &
+                 & petAcoef, petBcoef, peqAcoef, peqBcoef, &
+                 & u, v, dtradia, &
+                 & E_supply, E_supply_sum, E_supply_tot, hydrol_flag, hydrol_flag2, &
+                 & hydrol_flag3, &
+                 & vbeta2sum, vbeta3sum, veget_max, veget, delta_temp_save)
+
+
+
+    ! call the modified potential temperature subroutine
+
+    CALL jenerbil_pottemp (kjpindex, dtradia, zlev, emis, &
+       & epot_air, petAcoef, petBcoef, qair, peqAcoef, peqBcoef, &
+       & soilflx, rau, u, v, q_cdrag, &
+       & vbeta, valpha, vbeta1, vbeta5, soilcap, lwdown, swnet, &
+       & q_sol_pot, temp_sol_pot)
+
+
+
+
+    ! call the modified flux calculation subroutine 
+
+   CALL jenerbil_flux (kjpindex, dtradia, emis, temp_sol, rau, u, v, &
+        & q_cdrag, vbeta, valpha, vbeta1, vbeta5, &
+        & 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, jr_enerbil)
+
+
+
+
+    ! Diagnoses the values for evaporation and transpiration: vevapsno (snow evaporation), vevapnu 
+    ! (bare soil evaporation), transpir (transpiration), gpp (assimilation) and vevapwet (interception)
+    CALL jenerbil_evapveg (kjpindex, dtradia, vbeta1, vbeta2, vbeta3, &
+                           & vbeta3pot, vbeta4, vbeta5,     &
+                           & rau, u, v, q_cdrag,     &
+!!$                           & cimean, ccanopy, rau, u, v, q_cdrag,     &
+                           & qair_new, humrel, &
+                           & vevapsno, vevapnu, vevapflo, vevapwet, &
+                           & transpir, transpot, evapot)
+
+
+     CALL enerbil_t2mdiag (kjpindex, temp_air, t2mdiag)
+
+     
+     IF(ld_enerbil)THEN
+        WRITE(numout,*) 'before q_leaf_next calculation'
+        WRITE(numout,*) 'jalpha(:) is: ', jalpha(:)
+        WRITE(numout,*) 'jbeta(:) is: ', jbeta(:)
+        WRITE(numout,*) 'temp_leaf_next(:) is: ', temp_leaf_next(:)
+     ENDIF
+
+     q_leaf_next(:) = jalpha(:) * temp_leaf_next(:) + jbeta(:)
+
+
+        
+     ! surface layer check
+     delta_energy_surf = (temp_surf_next - temp_surf_pres) * rho_soil * soilcap(1)
+
+
+
+     ! outputs the multilayer components to a seperate netCDF file - call removed for now
+     IF (jnlvls .eq. 1) THEN
+        ! rely on history file output single layer case
+     ELSE
+        CALL jnetcdf(james_netcdf_flag, t_a_next_grid(1,:), q_a_next_grid(1,:), &
+            & temp_leaf_next_grid(1,:), q_leaf_next, &
+            & flux_h_grid(1,:), flux_le_grid(1,:), flux_ground_h, flux_ground_le, &
+            & k_eddy, u_speed, temp_surf_next, &
+            & eta_1, eta_2, eta_3, eta_4, jomega, &
+            & eta_1_surf, eta_2_surf, eta_3_surf, eta_4_surf, &
+            & lwdown(1), swnet(1), &
+            & temp_atmos_pres_grid(1,:), q_atmos_pres_grid(1,:), b_t, b_q, soilflx(1), &
+            & jomega_surf, jemissivity_surf, jomega_sw_surf, jemissivity, &
+            & jomega_sw, temp_leaf_pres_grid(1,:), temp_surf_pres, &
+            & big_r, big_r_prime, horiz_flux_t,  horiz_flux_q, &
+            & soilcap(1), eta_3_above, eta_1_above, eta_4_above, &
+            & eta_2_above, pad_deltah, jamescdfname, &
+            & ngu_bign)              
+     END IF !(jnlvls .eq. 1)        
+ 
+     ! Write to history files
+!!$     CALL histwrite_p(hist_id, 'evapot', kjit, evapot, kjpindex, index)
+!!$     CALL histwrite_p(hist_id, 'evapot_corr', kjit, evapot_corr, kjpindex, index)
+!!$     CALL histwrite_p(hist2_id, 'transpot', kjit, transpot, kjpindex, index)
+
+     ! prepare for the next timestep
+     temp_atmos_pres_grid(:,:) = t_a_next_grid(:,:)
+     q_atmos_pres_grid(:,:) = q_a_next_grid(:,:)
+     temp_leaf_pres_grid(:,:) = temp_leaf_next_grid(:,:)
+
+     temp_surf_pres = temp_surf_next
+
+     qsol_sat_new_out(:) = qsol_sat_new
+          
+ END SUBROUTINE jdriver
+
+ 
+ ! ---------------------------------------------------------------------------------------
+
+
+ !!  ===========================================================================================================================
+ !! SUBROUTINE		 		    : jnetcdf
+ !!
+ !!
+ !>\BRIEF				    : produces an output netCDF file for the multilayer scheme (though significantly
+ !!                                           slows the runtime, so this is not for general use) 
+ !!
+ !! DESCRIPTION			   	    :
+ !! 
+ !!
+ !! RECENT CHANGE(S): None
+ !!
+ !! MAIN OUTPUT VARIABLE(S)	: none
+ !!
+ !! REFERENCE(S)		:
+ !!
+ !! FLOWCHART			:
+ !_ ==============================================================================================================================
+
+
+
+ SUBROUTINE jnetcdf(james_netcdf_flag, temp_atmos_next, q_atmos_next, &
+                     & temp_leaf_next, q_leaf_next, &
+                     & flux_h, flux_le, flux_ground_h, flux_ground_le, &
+                     & k_eddy, u_speed, temp_surf_next, &
+                     & eta_1, eta_2, eta_3, eta_4, jomega, &
+                     & eta_1_surf, eta_2_surf, eta_3_surf, eta_4_surf, &
+                     & down_lw_ac, down_sw_ac, &
+                     & temp_atmos_pres, q_atmos_pres, b_t, b_q, heat_soil, &
+                     & jomega_surf, jemissivity_surf, jomega_sw_surf, jemissivity, & 
+                     & jomega_sw, temp_leaf_pres, temp_surf_pres, &
+                     & big_r, big_r_prime, horiz_flux_h, horiz_flux_le, &
+                     & theta_zero, eta_3_above, eta_1_above, eta_4_above, &
+                     & eta_2_above, pad_deltah, jamescdfname, &
+                     & ngu_bign) 
+ 
+    USE netcdf
+
+    IMPLICIT NONE
+
+    !! 0.1 Input variables
+
+    CHARACTER(LEN=80), INTENT(in)                        :: jamescdfname          
+
+    REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: jemissivity       
+    REAL(r_std), DIMENSION (jnlvls), INTENT(in)               :: temp_atmos_pres    
+    REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: b_t, b_q
+    REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: q_atmos_pres     
+    REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: big_r, big_r_prime  
+    REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: temp_atmos_next     
+    REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: temp_leaf_next, temp_leaf_pres         ! leaf temperature down the column (K) PRESENT STEP
+    REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: q_atmos_next        ! atmospheric specific humididy down the column (kg/kg) PRESENT STEP
+    REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: q_leaf_next         ! leaf specific humidity down the column (kg/kg) PRESENT STEP
+    REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: flux_h, flux_le     ! leaf temperature down the column (K) PRESENT STEP
+    ! REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: horiz_flux_h,  horiz_flux_le        
+    REAL(r_std), DIMENSION (jnlvls)                      :: horiz_flux_h,  horiz_flux_le        
+    REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: k_eddy              ! eddy transport coefficient (m^2 s-1)
+    REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: u_speed             ! (m/s)
+    REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: jomega_sw
+    REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: eta_1, eta_2, eta_3, eta_4, jomega
+
+    REAL(r_std), DIMENSION (0:jnlvls), INTENT(in)        :: pad_deltah         ! eddy transport coefficient (m^2 s-1)    
+    REAL(r_std), DIMENSION (0:jnlvls+1), INTENT(in)      :: ngu_bign
+
+    REAL(r_std), INTENT(in)                              :: flux_ground_h, flux_ground_le
+    REAL(r_std), INTENT(in)                              :: jomega_surf   
+    REAL(r_std), INTENT(in)                              :: jemissivity_surf    
+    REAL(r_std), INTENT(in)                              :: jomega_sw_surf    
+    REAL(r_std), INTENT(in)                              :: temp_surf_next, temp_surf_pres    
+    REAL(r_std), INTENT(in)                              :: eta_1_surf, eta_2_surf
+    REAL(r_std), INTENT(in)                              :: eta_3_surf, eta_4_surf, eta_3_above
+    REAL(r_std), INTENT(in)                              :: eta_1_above, eta_4_above, eta_2_above   
+    REAL(r_std), INTENT(in)                              :: down_lw_ac             ! input downwelling lw radiation above the canopy (watts/m^2)
+    REAL(r_std), INTENT(in)                              :: down_sw_ac             ! input downwelling sw radiation above the canopy (watts/m^2) 
+    REAL(r_std), INTENT(in)                              :: heat_soil              ! heat flux from or to deeper soil (layered scheme in ORCHIDEE) (W m^-2)
+    REAL(r_std), INTENT(in)                              :: theta_zero             ! heat capacity of the infinitesimal surface layer (J/ (K m^2))
+
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std), SAVE                     :: tap_id, qap_id, tlp_id, qlp_id              ! ID integers
+    INTEGER(i_std), SAVE                     :: tan_id, qan_id, tln_id, qln_id              ! ID integers
+    INTEGER(i_std), SAVE                     :: bt_id, bq_id                                ! ID integers
+    INTEGER(i_std), SAVE                     :: bigr_id, bigrprime_id                       ! ID integers
+    INTEGER(i_std), SAVE                     :: horiz_f_h_id, horiz_f_le_id                 ! ID integers
+    INTEGER(i_std), SAVE                     :: hflux_id, leflux_id, keddy_id, uspeed_id    ! ID integers
+    INTEGER(i_std), SAVE                     :: tsn_id, tsp_id                              ! ID integers
+    INTEGER(i_std), SAVE                     :: e1_id, e2_id, e3_id, e4_id                  ! ID integers
+    INTEGER(i_std), SAVE                     :: e1s_id, e2s_id, e3s_id, e4s_id              ! ID integers
+    INTEGER(i_std), SAVE                     :: e3a_id, e1a_id, e2a_id, e4a_id              ! ID integers
+    INTEGER(i_std), SAVE                     :: lw_id, sw_id, hs_id                         ! ID integers
+    INTEGER(i_std), SAVE                     :: jos_id, jes_id, josws_id                    ! ID integers
+    INTEGER(i_std), SAVE                     :: je_id, jo_id, josw_id                       ! ID integers
+    INTEGER(i_std), SAVE                     :: tz_id, pad_id                               ! ID integers  
+    INTEGER(i_std), SAVE                     :: ngu_bign_id, ngu_bign_s_id, ngu_bign_a_id   ! ID integers
+    INTEGER(i_std), SAVE                     :: james_step_count    
+    INTEGER(i_std), SAVE                     :: iret, iret2, fid, fid2
+
+    INTEGER(i_std)                           :: ii, jj, nlonid, nlatid, varid
+    INTEGER(i_std)                           :: TimeDimID, jtid, ts_id, HeightDimID, i
+    INTEGER(i_std)                           :: height_dim_id, height_dim_id2, time_dim_id
+    INTEGER(i_std)                           :: jstartnc_b, jcountnc_b
+    INTEGER(i_std)                           :: dimids_b
+    INTEGER(i_std)                           :: dimids(2) 
+    INTEGER(i_std)                           :: dimids2(2) 
+    INTEGER, DIMENSION(2)                    :: jstartnc, jcountnc    
+    LOGICAL                                  :: james_netcdf_flag    
+
+    REAL(r_std), DIMENSION(jnlvls)           :: flux_h_combo, flux_le_combo
+    REAL(r_std), DIMENSION (jnlvls)          :: array_jomega_surf
+    REAL(r_std), DIMENSION (jnlvls)          :: array_jemissivity_surf 
+    REAL(r_std), DIMENSION (jnlvls)          :: array_jomega_sw_surf 
+    REAL(r_std), DIMENSION (jnlvls)          :: array_temp_surf_pres
+    REAL(r_std), DIMENSION (jnlvls)          :: array_temp_surf_next
+    REAL(r_std), DIMENSION (jnlvls)          :: array_theta_zero
+    REAL(r_std), DIMENSION (jnlvls)          :: array_eta_1_surf, array_eta_2_surf
+    REAL(r_std), DIMENSION (jnlvls)          :: array_eta_3_surf, array_eta_4_surf 
+    REAL(r_std), DIMENSION (jnlvls)          :: array_eta_3_above, array_eta_1_above
+    REAL(r_std), DIMENSION (jnlvls)          :: array_eta_2_above, array_eta_4_above
+    REAL(r_std), DIMENSION (jnlvls)          :: array_down_lw_ac, array_down_sw_ac
+    REAL(r_std), DIMENSION (jnlvls)          :: array_heat_soil
+    REAL(r_std), DIMENSION (jnlvls)          :: array_ngu_bign_surf
+    REAL(r_std), DIMENSION (jnlvls)          :: array_ngu_bign_above
+    REAL(r_std), DIMENSION (jnlvls)          :: array_ngu_bign
+
+
+
+
+ 
+    ! parameters, dimensions and variable set-ups (only runs once)
+ 
+    IF (james_netcdf_flag) THEN
+
+        james_netcdf_flag = .FALSE.
+        
+        ! james_step_count = 0
+ 
+        ! WRITE(numout,*) 'james_netcdf_flag call here'
+
+        ! âŠ define the parameters here
+ 
+        iret = nf90_create(jamescdfname, nf90_write, fid)
+        
+  
+        ! define the dimensions
+        
+        iret = nf90_def_dim(fid, "height", jnlvls, height_dim_id)
+        iret = nf90_def_dim(fid, "time", nf90_unlimited, time_dim_id)
+
+        dimids = (/ height_dim_id, time_dim_id /)
+
+ 
+        ! define the variables
+        iret = nf90_def_var(fid,"temp_atmos_pres",nf90_real4, dimids, tap_id)
+        iret = nf90_def_var(fid,"q_atmos_pres",nf90_real4, dimids, qap_id)
+
+        iret = nf90_def_var(fid,"temp_atmos_next",nf90_real4, dimids, tan_id)
+        iret = nf90_def_var(fid,"q_atmos_next",nf90_real4, dimids, qan_id)
+
+        iret = nf90_def_var(fid,"temp_leaf_pres",nf90_real4, dimids, tlp_id)
+        
+        iret = nf90_def_var(fid,"temp_leaf_next",nf90_real4, dimids, tln_id)
+        iret = nf90_def_var(fid,"q_leaf_next",nf90_real4, dimids, qln_id)
+
+        iret = nf90_def_var(fid,"big_r",nf90_real4, dimids, bigr_id)
+        iret = nf90_def_var(fid,"big_r_prime",nf90_real4, dimids, bigrprime_id)
+
+        iret = nf90_def_var(fid,"h_flux",nf90_real4, dimids, hflux_id)
+        iret = nf90_def_var(fid,"le_flux",nf90_real4, dimids, leflux_id)
+
+        iret = nf90_def_var(fid,"horiz_flux_h",nf90_real4, dimids, horiz_f_h_id)
+        iret = nf90_def_var(fid,"horiz_flux_le",nf90_real4, dimids, horiz_f_le_id)
+
+        iret = nf90_def_var(fid,"k_eddy",nf90_real4, dimids, keddy_id)
+
+        iret = nf90_def_var(fid,"pad_deltah",nf90_real4, dimids, pad_id)
+
+        iret = nf90_def_var(fid,"u_speed",nf90_real4, dimids, uspeed_id)
+
+        iret = nf90_def_var(fid,"b_t",nf90_real4, dimids, bt_id)
+        iret = nf90_def_var(fid,"b_q",nf90_real4, dimids, bq_id)
+
+        iret = nf90_def_var(fid,"temp_surf_pres",nf90_real4, dimids, tsp_id)
+        iret = nf90_def_var(fid,"temp_surf_next",nf90_real4, dimids, tsn_id)
+
+        iret = nf90_def_var(fid,"theta_zero",nf90_real4, dimids, tz_id)
+
+        iret = nf90_def_var(fid,"eta_1",nf90_real4, dimids, e1_id)
+        iret = nf90_def_var(fid,"eta_2",nf90_real4, dimids, e2_id)
+        iret = nf90_def_var(fid,"eta_3",nf90_real4, dimids, e3_id)
+        iret = nf90_def_var(fid,"eta_4",nf90_real4, dimids, e4_id)
+
+        iret = nf90_def_var(fid,"eta_1_surf",nf90_real4, dimids, e1s_id)
+        iret = nf90_def_var(fid,"eta_2_surf",nf90_real4, dimids, e2s_id)
+        iret = nf90_def_var(fid,"eta_3_surf",nf90_real4, dimids, e3s_id)
+        iret = nf90_def_var(fid,"eta_4_surf",nf90_real4, dimids, e4s_id)
+
+        iret = nf90_def_var(fid,"eta_1_above",nf90_real4, dimids, e1a_id)
+        iret = nf90_def_var(fid,"eta_2_above",nf90_real4, dimids, e2a_id)
+        iret = nf90_def_var(fid,"eta_3_above",nf90_real4, dimids, e3a_id)
+        iret = nf90_def_var(fid,"eta_4_above",nf90_real4, dimids, e4a_id)
+
+        iret = nf90_def_var(fid,"lw_down_ac",nf90_real4, dimids, lw_id)
+        iret = nf90_def_var(fid,"sw_down_ac",nf90_real4, dimids, sw_id)
+
+        iret = nf90_def_var(fid,"heat_soil",nf90_real4, dimids, hs_id)
+
+        iret = nf90_def_var(fid,"jomega",nf90_real4, dimids, jo_id)
+        iret = nf90_def_var(fid,"jomega_sw",nf90_real4, dimids, josw_id)
+        iret = nf90_def_var(fid,"jomega_surf",nf90_real4, dimids, jos_id)
+        iret = nf90_def_var(fid,"jemissivity",nf90_real4, dimids, je_id)
+        iret = nf90_def_var(fid,"jemissivity_surf",nf90_real4, dimids, jes_id)
+        iret = nf90_def_var(fid,"jomega_sw_surf",nf90_real4, dimids, josws_id)
+
+        iret = nf90_def_var(fid,"ngu_bign",nf90_real4, dimids, ngu_bign_id)
+        iret = nf90_def_var(fid,"ngu_bign_surf",nf90_real4, dimids, ngu_bign_s_id)
+        iret = nf90_def_var(fid,"ngu_bign_above",nf90_real4, dimids, ngu_bign_a_id)
+
+        iret = nf90_enddef (fid)
+         
+    END IF !(james_netcdf_flag)
+
+
+    ! open the netCDF file at each step
+    iret = nf90_open(jamescdfname, nf90_Write, fid) 
+
+    jstartnc = (/ 1, 1 /)  ! vector of integers specifying the index in the variable from 
+                           !   which the first of the data values will be read
+    jcountnc = (/ jnlvls, 1 /)  ! vector of integers specifying the number of indices 
+                                 !   selected along each dimension
+
+    james_step_count = james_step_count + 1    ! this is the time step counter
+    
+    jstartnc(2) = james_step_count   ! (2) refers to the time dimension at present (it 
+                                     !   must always come last)
+ 
+    flux_h_combo(1) = flux_ground_h
+    flux_h_combo(2:jnlvls) = flux_h(2:jnlvls)
+    
+    flux_le_combo(1) = flux_ground_le
+    flux_le_combo(2:jnlvls) = flux_le(2:jnlvls) 
+
+    array_temp_surf_pres(1) = temp_surf_pres
+    array_temp_surf_pres(2:jnlvls) = 0.0d0
+    
+    array_temp_surf_next(1) = temp_surf_next
+    array_temp_surf_next(2:jnlvls) = 0.0d0
+    
+    array_eta_1_surf(1) = eta_1_surf
+    array_eta_1_surf(2:jnlvls) = 0.0d0
+    
+    array_eta_2_surf(1) = eta_2_surf
+    array_eta_2_surf(2:jnlvls) = 0.0d0    
+ 
+    array_eta_3_surf(1) = eta_3_surf
+    array_eta_3_surf(2:jnlvls) = 0.0d0    
+
+    array_eta_1_above(1) = eta_1_above
+    array_eta_1_above(2:jnlvls) = 0.0d0  
+
+    array_eta_2_above(1) = eta_2_above
+    array_eta_2_above(2:jnlvls) = 0.0d0  
+
+    array_eta_3_above(1) = eta_3_above
+    array_eta_3_above(2:jnlvls) = 0.0d0  
+
+    array_eta_4_above(1) = eta_4_above
+    array_eta_4_above(2:jnlvls) = 0.0d0  
+
+    array_eta_4_surf(1) = eta_4_surf
+    array_eta_4_surf(2:jnlvls) = 0.0d0
+    
+    array_down_lw_ac(1) = down_lw_ac
+    array_down_lw_ac(2:jnlvls) = 0.0d0 
+    array_down_sw_ac(1) = down_sw_ac
+    array_down_sw_ac(2:jnlvls) = 0.0d0
+    
+    array_heat_soil(1) = heat_soil
+    array_heat_soil(2:jnlvls) = 0.0d0
+
+    array_jomega_surf(1) = jomega_surf
+    array_jomega_surf(2:jnlvls) = 0.0d0
+
+    array_theta_zero(1) = theta_zero
+    array_theta_zero(2:jnlvls) = 0.0d0
+    
+    array_jemissivity_surf(1) = jemissivity_surf
+    array_jemissivity_surf(2:jnlvls) = 0.0d0
+
+    array_jomega_sw_surf(1) = jomega_sw_surf    
+    array_jomega_sw_surf(2:jnlvls) = 0.0d0     
+
+    array_ngu_bign_surf(1) = ngu_bign(0)    
+    array_ngu_bign_surf(2:jnlvls) = 0.0d0            
+
+    array_ngu_bign_above(1) = ngu_bign(jnlvls+1)
+    array_ngu_bign_above(2:jnlvls) = 0.0d0 
+
+    array_ngu_bign(1:jnlvls) = ngu_bign(1:jnlvls)    
+
+
+    iret = nf90_put_var(fid, bt_id, b_t(:), start = jstartnc, count = jcountnc) 
+    iret = nf90_put_var(fid, bq_id, b_q(:), start = jstartnc, count = jcountnc)
+
+    iret = nf90_put_var(fid, tap_id, temp_atmos_pres(:), start = jstartnc, count = jcountnc) 
+    iret = nf90_put_var(fid, qap_id, q_atmos_pres(:), start = jstartnc, count = jcountnc)
+     
+    iret = nf90_put_var(fid, tan_id, temp_atmos_next(:), start = jstartnc, count = jcountnc) 
+    iret = nf90_put_var(fid, qan_id, q_atmos_next(:), start = jstartnc, count = jcountnc)         
+
+    iret = nf90_put_var(fid, tlp_id, temp_leaf_pres(:), start = jstartnc, count = jcountnc)         
+
+    iret = nf90_put_var(fid, tln_id, temp_leaf_next(:), start = jstartnc, count = jcountnc)         
+    iret = nf90_put_var(fid, qln_id, q_leaf_next(:), start = jstartnc, count = jcountnc)         
+
+    iret = nf90_put_var(fid, bigr_id, big_r(:), start = jstartnc, count = jcountnc)         
+    iret = nf90_put_var(fid, bigrprime_id, big_r_prime(:), start = jstartnc, count = jcountnc)
+     
+    iret = nf90_put_var(fid, hflux_id, flux_h_combo(:), start = jstartnc, count = jcountnc)         
+    iret = nf90_put_var(fid, leflux_id, flux_le_combo(:), start = jstartnc, count = jcountnc)         
+
+    iret = nf90_put_var(fid, horiz_f_h_id, horiz_flux_h(:), start = jstartnc, count = jcountnc)         
+    iret = nf90_put_var(fid, horiz_f_le_id, horiz_flux_le(:), start = jstartnc, count = jcountnc)
+
+    iret = nf90_put_var(fid, keddy_id, k_eddy(:), start = jstartnc, count = jcountnc)              
+    
+    iret = nf90_put_var(fid, pad_id, pad_deltah(:), start = jstartnc, count = jcountnc)              
+    
+    iret = nf90_put_var(fid, uspeed_id, u_speed(:), start = jstartnc, count = jcountnc)              
+
+    iret = nf90_put_var(fid, e1_id, eta_1(:), start = jstartnc, count = jcountnc)              
+    iret = nf90_put_var(fid, e2_id, eta_2(:), start = jstartnc, count = jcountnc)              
+    iret = nf90_put_var(fid, e3_id, eta_3(:), start = jstartnc, count = jcountnc)              
+    iret = nf90_put_var(fid, e4_id, eta_4(:), start = jstartnc, count = jcountnc)              
+
+    iret = nf90_put_var(fid, tsp_id, array_temp_surf_pres(:), start = jstartnc, count = jcountnc)              
+
+    iret = nf90_put_var(fid, tsn_id, array_temp_surf_next(:), start = jstartnc, count = jcountnc)              
+
+    iret = nf90_put_var(fid, e1s_id, array_eta_1_surf(:), start = jstartnc, count = jcountnc)              
+    iret = nf90_put_var(fid, e2s_id, array_eta_2_surf(:), start = jstartnc, count = jcountnc)              
+    iret = nf90_put_var(fid, e3s_id, array_eta_3_surf(:), start = jstartnc, count = jcountnc)              
+    iret = nf90_put_var(fid, e4s_id, array_eta_4_surf(:), start = jstartnc, count = jcountnc)              
+
+    iret = nf90_put_var(fid, e1a_id, array_eta_1_above(:), start = jstartnc, count = jcountnc)              
+    iret = nf90_put_var(fid, e2a_id, array_eta_2_above(:), start = jstartnc, count = jcountnc)              
+    iret = nf90_put_var(fid, e3a_id, array_eta_3_above(:), start = jstartnc, count = jcountnc)              
+    iret = nf90_put_var(fid, e4a_id, array_eta_4_above(:), start = jstartnc, count = jcountnc)              
+
+
+    iret = nf90_put_var(fid, lw_id, array_down_lw_ac(:), start = jstartnc, count = jcountnc)              
+    iret = nf90_put_var(fid, sw_id, array_down_sw_ac(:), start = jstartnc, count = jcountnc) 
+
+    iret = nf90_put_var(fid, hs_id, array_heat_soil(:), start = jstartnc, count = jcountnc) 
+
+    iret = nf90_put_var(fid, tz_id, array_theta_zero(:), start = jstartnc, count = jcountnc) 
+
+    iret = nf90_put_var(fid, jo_id, jomega(:), start = jstartnc, count = jcountnc) 
+    iret = nf90_put_var(fid, josw_id, jomega_sw(:), start = jstartnc, count = jcountnc) 
+    iret = nf90_put_var(fid, jos_id, array_jomega_surf(:), start = jstartnc, count = jcountnc) 
+    iret = nf90_put_var(fid, je_id, jemissivity(:), start = jstartnc, count = jcountnc) 
+    iret = nf90_put_var(fid, jes_id, array_jemissivity_surf(:), start = jstartnc, count = jcountnc) 
+    iret = nf90_put_var(fid, josws_id, array_jomega_sw_surf(:), start = jstartnc, count = jcountnc) 
+
+    iret = nf90_put_var(fid, ngu_bign_id, array_ngu_bign(:), start = jstartnc, count = jcountnc)              
+    iret = nf90_put_var(fid, ngu_bign_s_id, array_ngu_bign_surf(:), start = jstartnc, count = jcountnc)              
+    iret = nf90_put_var(fid, ngu_bign_a_id, array_ngu_bign_above(:), start = jstartnc, count = jcountnc)     
+
+    ! close the netCDF file and write to disk                   
+    iret = nf90_close(fid)
+
+ 
+ END SUBROUTINE jnetcdf
+
+ 
+ ! ------------------------------------------------------------------------------------------------------------------------------------- 
+
+ !!  ===========================================================================================================================
+ !! SUBROUTINE		 		    : calc_jradiation_scheme
+ !!
+ !!
+ !>\BRIEF				    : calculates the radiation balance with a multilayer canopy 
+ !!
+ !! DESCRIPTION			   	    :
+ !! 
+ !!
+ !! RECENT CHANGE(S): None
+ !!
+ !! MAIN OUTPUT VARIABLE(S)	: eta_1, eta_2, eta_3, eta_4, jomega, jemissivity, temp_leaf_pres_grid, temp_surf_pres,
+ !!                               pad_deltah, jomega_sw, eta_1_surf, eta_2_surf, eta_3_surf, eta_4_surf,
+ !!                               jemissivity_surf, jomega_surf, jomega_sw_surf, eta_3_above, eta_1_above, eta_4_above, eta_2_above,
+ !!                               james_write, ngu_alpha, ngu_alpha_insert, kjpindex, big_k_lw, big_k_sw
+ !!
+ !! REFERENCE(S)		: Gu, L. et al., 1999. Micrometeorology, biophysical exchanges and NEE decomposition in a two-storey
+ !!                                   boreal forest - development and test of an integrated model. Agricultural and Forest 
+ !!                                   Meteorology, 94, pp.123â148.
+ !!
+ !! FLOWCHART			:
+ !_ ==============================================================================================================================
+
+ SUBROUTINE calc_jradiation_scheme (eta_1, eta_2, eta_3, eta_4, &
+                                & jomega, jemissivity, temp_leaf_pres_grid, temp_surf_pres, &
+                                & pad_deltah, jomega_sw, &
+                                & eta_1_surf, eta_2_surf, eta_3_surf, eta_4_surf, &
+                                & jemissivity_surf, jomega_surf, jomega_sw_surf, &
+                                & eta_3_above, eta_1_above, eta_4_above, eta_2_above, &
+                                & james_write, ngu_alpha, ngu_alpha_insert, kjpindex, &
+                                & big_k_lw, big_k_sw)
+
+
+     IMPLICIT NONE
+
+
+     !! 0.1 Input variables
+     INTEGER(i_std), INTENT(in)                             :: kjpindex               !! Domain size (-)
+     LOGICAL, INTENT(in)                                    :: james_write            !! Flag for turning all of the verbose write statements on and off
+     REAL(r_std), DIMENSION (kjpindex,jnlvls), INTENT(in)   :: temp_leaf_pres_grid    ! leaf temperature down the column (K) PRESENT STEP
+     REAL(r_std), INTENT(in)                                :: temp_surf_pres
+     REAL(r_std), DIMENSION (0:jnlvls), INTENT(in)          :: pad_deltah
+     REAL(r_std), INTENT(in)                                :: big_k_lw
+     REAL(r_std), INTENT(in)                                :: big_k_sw
+
+     !! 0.2 Output variables
+     REAL(r_std), DIMENSION(jnlvls), INTENT(out)            :: eta_1, eta_2, eta_3, eta_4
+     REAL(r_std), DIMENSION(jnlvls), INTENT(out)            :: jomega
+     REAL(r_std), DIMENSION (jnlvls), INTENT(out)           :: jomega_sw
+     REAL(r_std), DIMENSION(jnlvls), INTENT(out)            :: jemissivity
+     REAL(r_std), INTENT(out)                               :: jemissivity_surf                     ! emissivity of surface layer
+     REAL(r_std), INTENT(out)                               :: jomega_surf
+     REAL(r_std), INTENT(out)                               :: jomega_sw_surf
+     REAL(r_std), INTENT(out)                               :: eta_1_surf, eta_2_surf
+     REAL(r_std), INTENT(out)                               :: eta_3_surf, eta_4_surf
+     REAL(r_std), INTENT(out)                               :: eta_3_above, eta_1_above
+     REAL(r_std), INTENT(out)                               :: eta_4_above, eta_2_above 
+     REAL, DIMENSION (0:jnlvls+1, 0:jnlvls+1), INTENT(out)  :: ngu_alpha
+
+     !! 0.3 Modified variables
+
+
+     !! 0.4 Local variables
+     INTEGER(i_std)                                         :: i, j, k, ji, jk
+     REAL(r_std), DIMENSION(jnlvls)                         :: series_sub1, series_sub2
+     REAL(r_std), DIMENSION(jnlvls)                         :: series_sub1_sw, series_sub2_sw  
+     REAL(r_std), DIMENSION(jnlvls)                         :: rho_albedo                           ! albedo of each vegetation layer
+     REAL(r_std)                                            :: rho_albedo_surf
+
+     REAL(r_std)                                            :: jcounter, jcounter2
+     REAL(r_std)                                            :: series_sub1_surf
+     REAL(r_std)                                            :: series_sub2_surf, series_sub1_sw_surf
+     REAL(r_std)                                            :: temp_surf
+     REAL(r_std)                                            :: jfactor
+     REAL(r_std), DIMENSION (0:jnlvls+1)                    :: ngu_alpha_insert
+     REAL(r_std), DIMENSION (jnlvls)                        :: temp_leaf_pres    ! leaf temperature down the column (K) PRESENT STEP
+
+
+     ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+     DO jk = 1, kjpindex
+
+             temp_leaf_pres(:) = temp_leaf_pres_grid(jk,:)	
+	     jemissivity(:) = 0.96d0 != 0.96d0
+	     jomega_sw_surf = 1.0d0
+	     jomega_surf = 1.0d0	     
+	     jemissivity_surf = 0.96d0 != 0.96d0
+	     temp_surf =  0.0d0  !(not used)	 	     
+	     series_sub1(:) = 1.0d0
+	     series_sub2(:) = 1.0d0	
+	     series_sub1_sw(:) = 1.0d0
+	     series_sub2_sw(:) = 1.0d0	
+	     rho_albedo(:) = 0.4d0 !0.4d0
+	     rho_albedo_surf = 0.4d0 !0.4d0		    	
+	     rho_albedo(:) = 0.1d0
+	     rho_albedo_surf = 0.1d0	
+	     jomega_surf = 1.0d0
+	     jomega_sw_surf = 1.0d0
+	     jemissivity_surf = 0.96d0
+	     jemissivity(:) = 0.96d0
+	     jcounter = 1.0d0
+	     series_sub1(:) = 1.0d0	
+	
+	     ! calculate omega coefficient for each level
+	     DO i=1, jnlvls
+	         jomega(i) = 1 - (exp(-1.0d0 * big_k_lw * pad_deltah(i) ) )
+	     END DO ! i = 1, jnlvls
+	
+	     DO i=1, jnlvls
+	         jomega_sw(i) = 1 - (exp(-1.0d0 * big_k_sw * pad_deltah(i) ) ) 
+	     END DO ! i = 1, jnlvls	
+	
+	     DO i = jnlvls, 1, -1
+	         DO j = jnlvls-1, i, -1
+	             series_sub1(i) = series_sub1(i) * ( 1.0d0 - jomega(j+1) ) 
+	         END DO ! j = jnlvls, i, -1
+	     END DO ! i = jnlvls, 1, -1
+	
+	     series_sub1_surf = series_sub1(1) * (1.0d0 - jomega(1))
+	
+	     eta_1(1) = (series_sub1(1) * jomega(1) * jemissivity(1))                  
+	
+	     DO i = 2, jnlvls-1
+	         eta_1(i) = (series_sub1(i) * jomega(i) * jemissivity(i)) 
+	     END DO ! i = 2, jnlvls-2
+	
+	     eta_1(jnlvls) = series_sub1(jnlvls) * jomega(jnlvls) * jemissivity(jnlvls)
+		
+	     eta_1_surf = jomega_surf * series_sub1_surf * jemissivity_surf
+		
+	     eta_1_above = 0.0d0     
+	
+	     eta_1_above = (series_sub1(1) * jomega(i) * (1.0d0 - jemissivity(1))) 
+	
+	     DO i = 2, jnlvls-1
+	         eta_1_above = eta_1_above + &
+	                        & (series_sub1(i) * jomega(i) * (1.0d0 - jemissivity(i))) 
+	     END DO ! i = 2, jnlvls-2
+	
+	     eta_1_above = eta_1_above + &
+	                & series_sub1(jnlvls) * jomega(jnlvls) * (1.0d0 - jemissivity(jnlvls))
+	
+	     eta_1_above = eta_1_above + &
+	                & series_sub1_surf * jomega_surf * (1.0d0 - jemissivity(jnlvls))
+	
+	     series_sub1_sw(:) = 1.0d0
+	
+	     DO i = jnlvls, 1, -1
+	         DO j = jnlvls-1, i, -1
+	             series_sub1_sw(i) = series_sub1_sw(i) * ( 1.0d0 - jomega_sw(j+1) ) 
+	         END DO ! j = jnlvls, i, -1
+	     END DO ! i = jnlvls, 1, -1
+	
+	     series_sub1_sw_surf = series_sub1_sw(1) * (1.0d0 - jomega_sw(1))
+	
+	     eta_4(1) = (series_sub1_sw(1) * jomega_sw(1) * (1.0d0 - rho_albedo(1))) !+ &
+	
+	     DO i = 2, jnlvls-1
+	         eta_4(i) = (series_sub1_sw(i) * jomega_sw(i) * (1.0d0 - rho_albedo(i))) !+ &
+	     END DO ! i = 2, jnlvls-2
+	
+	     eta_4(jnlvls) = series_sub1_sw(jnlvls) &
+	                       & * jomega_sw(jnlvls) * (1.0d0 - rho_albedo(jnlvls))
+	
+	     eta_4_surf = series_sub1_sw_surf * jomega_sw_surf * (1.0d0 - rho_albedo_surf)
+	
+	     
+	     ! 200613 old version
+	
+	     eta_4_above = 0.0d0     
+	
+	     eta_4_above = (series_sub1_sw(1) * jomega_sw(1) * rho_albedo_surf) ! - &
+	
+	
+	     DO i = 2, jnlvls-1
+	         eta_4_above = eta_4_above + (series_sub1_sw(i) * jomega_sw(i) * rho_albedo(i))
+	     END DO ! i = 2, jnlvls-2
+	
+	     eta_4_above = eta_4_above + &
+	                & series_sub1_sw(jnlvls) * jomega_sw(jnlvls) * rho_albedo(jnlvls)
+	     
+	     eta_4_above = eta_4_above + &
+	                & series_sub1_sw_surf* jomega_sw_surf * rho_albedo_surf
+	
+	     jcounter = 1.0d0
+	     jcounter2 = 1.0d0
+	     DO j = jnlvls, 1, -1
+	         jcounter = jcounter * ( 1.0d0 - jomega(j) ) 
+	         jcounter2 = jcounter2 * ( 1.0d0 - jomega(j) ) 
+	     END DO ! j = 2, jnlvls  
+	     series_sub1_surf = jcounter
+	     series_sub2_surf = jcounter2
+	     
+	     jcounter = 1.0d0
+	     jcounter2 = 1.0d0
+	     series_sub1_sw(jnlvls) = (1.0d0-rho_albedo(jnlvls)) * jomega_sw(jnlvls)    
+	     series_sub2_sw(jnlvls) = (1.0d0-rho_albedo(jnlvls)) * jomega_sw(jnlvls)    
+	     DO i = jnlvls-1, 1, -1
+	         jcounter = 1.0d0 * jomega_sw(i)
+	         DO j = jnlvls, i+1, -1
+	             jcounter = jcounter * ( 1.0d0 - jomega_sw(j) ) 
+	         END DO ! j = 2, jnlvls
+	         series_sub1_sw(i) = (1.0d0-rho_albedo(i)) * jcounter
+	     END DO ! i = 1, jnlvls 
+	
+	     jcounter = 1.0d0
+	     DO j = jnlvls, 1, -1
+	         jcounter = jcounter * ( 1.0d0 - jomega_sw(j) ) 
+	     END DO ! j = 2, jnlvls  
+	     series_sub1_sw_surf = (1.0d0-rho_albedo(1)) * jcounter
+	
+	
+	     DO i=1, jnlvls
+	         eta_3(i) = 0.0d0    ! initialise variable
+	         DO j=1, jnlvls
+	             jfactor = 1.0d0
+	
+	             IF (j .gt. i) THEN
+	                 IF (j-1 .eq. i) THEN
+	                     ! no transmission coefficient for layer directly above
+	                 ELSE
+	                     DO k = j-1, i+1
+	                         jfactor = jfactor * (1.0d0 - jomega(k))                
+	                     END DO ! k = j-1, i+1
+	                 END IF ! (j-1 .eq. i)                 
+	                 eta_3(i) = eta_3(i) + &
+	                      &   ( jomega(i) * jomega(j) * jemissivity (j) * &
+	                      &     (jfactor) * c_stefan * temp_leaf_pres(j)**4.0d0 )
+	              END IF ! (j .gt. i)
+	
+	
+	              IF (j .eq. i) THEN
+	                  eta_3(i) = eta_3(i)
+	              END IF ! (j .eq. i)
+	
+	
+	              IF (j .lt. i) THEN
+	                  IF (j+1 .eq. i) THEN
+	                      ! no transmission coefficient for layer directly below
+	                  ELSE
+	                      DO k = j+1, i-1               
+	                          jfactor = jfactor * (1.0d0 - jomega(k))                      
+	                      END DO ! k = j+1, i-1
+	                  END IF ! (j+1 .eq. i)                 
+	                  eta_3(i) = eta_3(i) + &
+	                       &     ( jomega(i) * jomega(j) * jemissivity (j) * &
+	                       &     (jfactor) * c_stefan * temp_leaf_pres(j)**4.0d0 )
+	              END IF ! (j .lt. i)
+	         END DO ! j = 1, jnlvls
+	     END DO ! i = 1, jnlvls    
+	
+	
+	     ! for radiation from surface layer
+	
+	     DO i=1, jnlvls
+	
+	          jfactor = 1.0d0
+	
+	          IF (i .eq. 1) THEN
+	              ! no transmission coefficient for layer directly above
+	          ELSE
+	              DO k = i, 1
+	                  jfactor = jfactor * (1.0d0 - jomega(k))                
+	              END DO ! k = j-1, i+1
+	          END IF ! (i .eq. 1)                 
+	
+	          eta_3(i) = eta_3(i) + &
+	                &   ( jomega(i) * jomega_surf * jemissivity_surf * &
+	                &     (jfactor) * c_stefan * temp_surf_pres**4.0d0 )
+	
+	     END DO ! i = 1, jnlvls    
+	
+	
+	
+	
+	     ! now to calculate eta_3_surf for the surface
+	
+	     eta_3_surf = 0.0d0
+	
+	     DO j = 1, jnlvls
+	         jfactor = 1.0d0  
+	         DO k = j, 1
+	             jfactor = jfactor * (1.0d0 - jomega(k))
+	         END DO ! k = jnlvls, 1
+	         eta_3_surf = eta_3_surf + &
+	               & (jomega_surf * jomega(j) * jfactor * c_stefan * temp_leaf_pres(j)**4.0d0)
+	     END DO ! j = 1, jnlvls
+	
+	
+	
+	    ! now to calculate eta_3_above to check the above canopy radiation balance
+	
+	    eta_3_above = 0.0d0
+	
+	    DO j = jnlvls, 1
+	        jfactor = 1.0d0
+	        DO k = jnlvls, j
+	            jfactor = jfactor * (1.0d0 - jomega(k))
+	        END DO ! k = jnlvls, j
+	        eta_3_above = eta_3_above + & 
+	                       & (jomega(j) * jfactor * c_stefan * temp_leaf_pres(j)**4.0d0)
+	    END DO ! j = jnlvls, 1
+	
+	
+	
+	     eta_3_above = eta_3_above + (jomega_surf * jfactor * c_stefan * temp_surf_pres**4.0d0)
+	                      
+	     eta_2(1) = -2.0d0 *  jemissivity(1) * jomega(1) * c_stefan * 4.0d0 *                 &
+	       & (temp_leaf_pres(1)**3.0d0)                                                      &
+	       & + jomega(1) *(1-jemissivity(2))* jomega(2) * jemissivity(1) * c_stefan * 4.0d0 * &
+	       & (temp_leaf_pres(1)**3.0d0)                                                      &                                                  
+	       & + jomega(1) *(1-jemissivity_surf)* jomega_surf *                                &
+	       & jemissivity(1) * c_stefan * 4.0d0 * (temp_leaf_pres(1)**3.0d0)                                                                  
+	
+	     eta_3(1) = eta_3(1) + &
+	       & 2.0d0* jemissivity(1) * jomega(1) * c_stefan *3.0d0* (temp_leaf_pres(1)**4.0d0)  &
+	       & - jomega(1) * (1-jemissivity(2)) * jomega(2) * jemissivity(1) * c_stefan *       &
+	       & (3.0d0*temp_leaf_pres(1)**4.0d0)                                                &
+	       & - jomega(1) * (1-jemissivity_surf) * jomega_surf * jemissivity(1) * c_stefan *   &
+	       & (3.0d0 * temp_leaf_pres(1)**4.0d0) 
+	
+	     ! eta_4(1) = series_sub1_sw(1)
+	
+	
+	
+	     DO i = 2, jnlvls-1
+	    
+	        eta_2(i) = -2.0d0 *  jemissivity(i) * jomega(i) * c_stefan * 4.0d0 *              &
+	          & (temp_leaf_pres(i)**3.0d0)                                                   &
+	          & + jomega(i)*(1-jemissivity(i+1))*jomega(i+1)*jemissivity(i)*c_stefan*4.0d0*   &
+	          &   (temp_leaf_pres(i)**3.0d0)                                                 &
+	          & + jomega(i)*(1-jemissivity(i-1))*jomega(i-1)*jemissivity(i)*c_stefan*4.0d0*   &
+	          &   (temp_leaf_pres(i)**3.0d0)
+	
+	                   
+	         eta_3(i) = eta_3(i) + 2.0d0 * jemissivity(i) * jomega(i) * c_stefan * 3.0d0 *    &
+	           & (temp_leaf_pres(i)**4.0d0)                                                  &
+	           & - jomega(i) *(1-jemissivity(i+1))* jomega(i+1)*jemissivity(i) * c_stefan *   &
+	           & (3.0d0 * temp_leaf_pres(i)**4.0d0)                                          &
+	           & - jomega(i) *(1-jemissivity(i-1))* jomega(i-1) * jemissivity(i) * c_stefan * &
+	           & (3.0d0 * temp_leaf_pres(i)**4.0d0) 
+	         
+	     END DO ! i = 1, jnlvls
+	
+	
+	
+	     eta_2(jnlvls) =-2.0d0* jemissivity(jnlvls) * jomega(jnlvls) * c_stefan * 4.0d0 *  &
+	           & (temp_leaf_pres(jnlvls)**3.0d0)                                            &
+	           & + jomega(jnlvls)*(1-jemissivity(jnlvls-1)*jomega(jnlvls-1)               &
+	           & * jemissivity(jnlvls) * c_stefan * 4.0d0 * (temp_leaf_pres(jnlvls)**3.0d0))
+	     eta_3(jnlvls) = eta_3(jnlvls) + &
+	            & 2.0d0 * jemissivity(jnlvls) * jomega(jnlvls) * c_stefan * 3.0d0 *         &
+	            & (temp_leaf_pres(jnlvls)**4.0d0)                                           &
+	            & - jomega(jnlvls) * (1-jemissivity(jnlvls-1)) * jomega(jnlvls-1)         &
+	            & * jemissivity(jnlvls) * c_stefan * (3.0d0 * temp_leaf_pres(jnlvls)**4.0d0) 
+	
+	     
+	
+	     eta_2_surf = -1.0d0 * jemissivity_surf * jomega_surf * c_stefan *                    &
+	            & 4.0d0 * (temp_surf_pres)**3 +                                              &
+	            & jomega_surf *(1-jemissivity(1)) * jomega(1) * jemissivity_surf * c_stefan * &
+	            & 4.0d0 * (temp_surf_pres)**3
+	
+	     eta_3_surf = eta_3_surf + 1.0d0 * jemissivity_surf * jomega_surf * c_stefan *        &
+	           & (3.0d0 * (temp_surf_pres)**4) +                                             &
+	           & jomega_surf * (1-jemissivity(1)) * jomega(1) * jemissivity_surf * c_stefan * &
+	           & (3.0d0 * (temp_surf_pres)**4)
+	
+	
+	     eta_2_above = 0.0d0
+		
+	
+	     IF (james_write) THEN
+	
+	         DO i = jnlvls, 1, -1
+	             WRITE(numout,*) 'eta_1 level ', i, ' is: ', eta_1(i)
+	         END DO ! i = jnlvls, 1, -1
+	         DO i = jnlvls, 1, -1
+	             WRITE(numout,*) 'eta_2 level ', i, ' is: ', eta_2(i)
+	         END DO ! i = jnlvls, 1, -1
+	         DO i = jnlvls, 1, -1
+	             WRITE(numout,*) 'eta_3 level ', i, ' is: ', eta_3(i)
+	         END DO ! i = jnlvls, 1, -1
+	         DO i = jnlvls, 1, -1
+	             WRITE(numout,*) 'eta_4 level ', i, ' is: ', eta_4(i)
+	         END DO ! i = jnlvls, 1, -1
+	
+	         !WRITE(numout,*) 'eta_1_surf level is: ', eta_1_surf
+	         !WRITE(numout,*) 'eta_2_surf level is: ', eta_2_surf
+	         !WRITE(numout,*) 'eta_3_surf level is: ', eta_3_surf
+	         !WRITE(numout,*) 'eta_4_surf level i/s: ', eta_4_surf
+	 
+	         !WRITE(numout,*) '080313 leaving calc_jradiation_scheme'
+	
+	     END IF ! (james_write)
+	
+	     CALL calc_jradiation_matrix(pad_deltah, ngu_alpha, ngu_alpha_insert)
+
+     END DO ! jk = 1, kjpindex
+
+
+ END SUBROUTINE calc_jradiation_scheme
+
+ ! ---------------------------------------------------------------------------------------
+
+ !!  ===========================================================================================================================
+ !! SUBROUTINE		 		    : calc_jradiation_matrix
+ !!
+ !!
+ !>\BRIEF				    : calculates the radiation matrix, as outlined in reference below 
+ !!
+ !! DESCRIPTION			   	    :
+ !! 
+ !!
+ !! RECENT CHANGE(S): None
+ !!
+ !! MAIN OUTPUT VARIABLE(S)	: ngu_alpha, ngu_alpha_insert
+ !!
+ !! REFERENCE(S)		: Gu, L. et al., 1999. Micrometeorology, biophysical exchanges and NEE decomposition in a two-storey
+ !!                                   boreal forest - development and test of an integrated model. Agricultural and Forest 
+ !!                                   Meteorology, 94, pp.123â148.
+ !!
+ !! FLOWCHART			:
+ !_ ==============================================================================================================================
+
+
+
+ SUBROUTINE calc_jradiation_matrix(pad_deltah, ngu_alpha, ngu_alpha_insert)
+
+    IMPLICIT NONE
+
+    !! 0.1 Input variables
+    REAL(r_std), DIMENSION (0:jnlvls), INTENT(in)                   :: pad_deltah
+
+    !! 0.2 Output variables
+    REAL(r_std), DIMENSION (0:jnlvls+1, 0:jnlvls+1), INTENT(out)    :: ngu_alpha
+    REAL(r_std), DIMENSION (0:jnlvls+1)                             :: ngu_alpha_insert    
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                                  :: i, j
+    INTEGER(i_std)                                                  :: m
+     
+    REAL(r_std), DIMENSION (0:jnlvls)                               :: jpad    
+    REAL(r_std), DIMENSION (0:jnlvls)                               :: acc_pad        
+    REAL(r_std)                                                     :: total_ngu_bign        
+
+    ! read in pad (JR 220713)
+
+    m = jnlvls
+
+    DO i = 0, jnlvls
+
+       jpad(i) = pad_deltah(i)
+
+    END DO ! i = 0, jnlvls
+
+
+    ! define acc_pad
+    
+    acc_pad(jnlvls) = 0.0d0
+    
+    DO i = m-1, 0, -1
+    
+       acc_pad(i) = jpad(i+1) + acc_pad(i+1)
+    
+    END DO ! i = m-1, 0, -1
+    
+    ! WRITE(numout,*) '300713 acc_pad: ', acc_pad(:)
+ 
+    DO i = 0, m+1   
+       DO j = 0, m+1
+ 
+          IF ((i .eq. 0) .and. (j .eq. 0)) THEN
+             ngu_alpha(i,j) = -1.0d0
+
+          ELSE IF ((i .eq. 0) .and. ((j .ge. 1) .and. (j .le. m))) THEN
+             ngu_alpha(i,j) = gu(acc_pad(0) - acc_pad(j-1)) - gu(acc_pad(0)-acc_pad(j))
+
+          ELSE IF ((i .eq. 0) .and. (j .eq. (m+1)))  THEN
+             ngu_alpha(i,j) = gu(acc_pad(0))
+	
+          ELSE IF (((i .ge. 1) .and. (i .le. m)) &
+                    &  .and. ((j .ge. 1) .and. (j .le. (i-1)))) THEN
+             ngu_alpha(i,j) = gu(acc_pad(j) - acc_pad(i-1)) - gu(acc_pad(j-1)-acc_pad(i-1)) &
+		            & - gu(acc_pad(j) - acc_pad(i)) + gu(acc_pad(j-1)-acc_pad(i))
+	
+          ELSE IF (((i .ge. 1) .and. (i .le. m)) .and. (j .eq. i))  THEN
+
+             ! 220713 this is a departure from the matrix scheme, because I am treating 
+             !   the temperature of the infinitesimal soil surface layer, and each 
+             !   vegetation layer, as implicit when (i = j). Radiation from each of the 
+             !   other levels is treated explicitly - i.e. by using the Gu scheme
+
+             ! following line is from the full scheme, for completeness
+             ! ngu_alpha(i,j) = 2.0d0 * gu(acc_pad(i-1) - acc_pad(i)) - 2.0d0 
+             ngu_alpha_insert(i) = gu(acc_pad(i-1) - acc_pad(i)) 
+             ! test to see influence of absorbed/emitted from the same layer in the cycle
+             ngu_alpha(i,j) = 0.0d0 
+
+          ELSE IF (((i .ge. 1).and.(i .le. m)).and.(((j .ge. (i+1)) .and. (j .le. m))))  THEN
+             ngu_alpha(i,j) = gu(acc_pad(i) - acc_pad(j-1)) - gu(acc_pad(i)-acc_pad(j))  &
+                         & - gu(acc_pad(i-1) - acc_pad(j-1)) + gu(acc_pad(i-1)-acc_pad(j))
+
+          ELSE IF ((i .eq. (m+1)) .and. (j .eq. 0))  THEN
+             ngu_alpha(i,j) = gu(acc_pad(0))
+
+          ELSE IF ((i .eq. (m+1)) .and. ((j .ge. 1) .and. (j .le. m)))  THEN
+             ngu_alpha(i,j) = gu(acc_pad(j)) - gu(acc_pad(j-1))   
+
+          ELSE IF ((i .eq. (m+1)) .and. (j .eq. (m+1)))  THEN
+             ngu_alpha(i,j) = -1.0d0   
+
+          ! 220713 extra components, not in the Gu manuscript, but seem logical, 
+          !   (probably they were omitted by accident?)
+
+          ELSE IF (((i .ge. 1) .and. (i .le. m)) .and. (j .eq. (0)))  THEN
+             ngu_alpha(i,j) = gu(acc_pad(0) - acc_pad(i-1)) - gu(acc_pad(0) - acc_pad(i))
+
+          ELSE IF (((i .ge. 1) .and. (i .le. m)) .and. (j .eq. (m+1)))  THEN
+             ngu_alpha(i,j) = gu(acc_pad(i)) - gu(acc_pad(i-1))  
+
+          ELSE 
+
+          END IF
+
+       END DO ! j = 0, m+1
+    
+    END DO ! i = 0, m+1
+
+
+ END SUBROUTINE calc_jradiation_matrix
+
+
+
+
+ ! ---------------------------------------------------------------------------------------------------------------------------------
+
+ !!  ===========================================================================================================================
+ !! SUBROUTINE		 		    : jcalc
+ !!
+ !!
+ !>\BRIEF				    : calculates the energy, for either the multilayer or the single layer case 
+ !!
+ !! DESCRIPTION			   	    : This module calculates the coefficients that are required to determine the energy 
+ !!                                               budget at each time step.
+ !! 
+ !!
+ !! RECENT CHANGE(S): None
+ !!
+ !! MAIN OUTPUT VARIABLE(S)	: big_e, big_f, big_g, flux_h_grid, flux_le_grid, a_t, b_t, c_t, d_t, a_q, b_q, c_q, d_q, 
+ !!                               t_a_next_grid, q_a_next_grid, horiz_flux_t, horiz_flux_q, temp_surf_next, flux_ground_h, 
+ !!                               flux_ground_le, delta_temp, temp_leaf_next_grid, temp_sol_new, delta_temp_save, epot_air_new, 
+ !!                               big_r, big_r_prime, speed, vbeta3, eta_1, eta_2, eta_3, eta_4, eta_1_surf, eta_2_surf, 
+ !!                               eta_3_surf, eta_4_surf, qair_new, qair, fluxsens, fluxlat, vbeta2sum, vbeta3sum
+ !!
+ !! REFERENCE(S)		: Best, M.J. et al., 2004. A proposed structure for coupling tiled surfaces with the planetary boundary 
+ !!                               layer. Journal of Hydrometeorology, 5, pp.1271â1278.
+ !!
+ !!                               Polcher, J. et al., 1998. A proposal for a general interface between land surface schemes and general 
+ !!                               circulation models. Global and Planetary Change, 19, pp.261â276
+ !!    
+ !!                               Ryder, J. Towards a multi-layer representation of the energy balance in a land surface model...
+ !!                               working document (see DOFOCO cloud)
+ !!
+ !! FLOWCHART			: 
+ !_ ==============================================================================================================================
+
+
+ SUBROUTINE jcalc (pad_deltah, layer_height, big_r, big_r_prime, delta_z,                 &
+                      & k_eddy, swnet, lwdown, temp_atmos_pres_grid, q_atmos_pres_grid,   &
+                      & a_t, b_t, c_t, d_t,                                               &
+                      & a_q, b_q, c_q, d_q,                                               &
+                      & big_e, big_f, big_g,                                              &
+                      & jalpha, jbeta, temp_leaf_pres_grid, delta_h,                      &
+                      & eta_1, eta_2, eta_3, eta_4,                                       &
+                      & k_eddy_surf, delta_z_surf, jtheta,                                &
+                      & jalpha_surf, jbeta_surf, rau,                                     &
+                      & temp_surf_pres, soilcap, soilflx, speed,                          &
+                      & q_cdrag,                                                          &
+                      & kjpindex, jr_enerbil,                                             &
+                      & flux_ground_h, flux_ground_le, flux_h_grid, flux_le_grid,         &
+                      & u_speed, t_a_next_grid, q_a_next_grid, james_write,               &
+                      & temp_surf_next,                                                   &
+                      & eta_1_surf, eta_2_surf, eta_3_surf, eta_4_surf,                   &
+                      & temp_leaf_next_grid, epot_air_new, delta_temp,                    &
+                      & horiz_flux_t, horiz_flux_q,                                       &
+                      & ngu_bign, ngu_alpha, ngu_alpha_insert, qair_new, qair,            &
+                      & emis, temp_sol_new, vbeta1, vbeta4, vbeta5, vbeta2,               &
+                      & vbeta3, vbeta3pot, vbeta, fluxsens, fluxlat, netrad,              &
+                      & petAcoef, petBcoef, peqAcoef, peqBcoef,                           &
+                      & u, v, dtradia, E_supply, E_supply_sum, E_supply_tot,              &
+                      & hydrol_flag, hydrol_flag2,                                        &
+                      & hydrol_flag3, vbeta2sum, vbeta3sum, veget_max, veget,             &
+                      & delta_temp_save)
+
+
+
+     ! 
+
+     IMPLICIT NONE
+
+
+     ! 0.1 input variables
+
+     LOGICAL, INTENT(in)                                  :: jr_enerbil             !! Flag that controls the activation of alternate enerbil scheme (true/false)    
+     LOGICAL, INTENT(in)                                  :: james_write            !! Flag for turning all of the verbose write statements on and off
+
+     INTEGER(i_std), INTENT(in)                           :: kjpindex               !! Domain size (-)
+
+     REAL(r_std), INTENT (in)                             :: dtradia                !! Time (s)
+     REAL(r_std), INTENT (in)                             :: layer_height           ! layer height (m)
+
+     REAL(r_std), DIMENSION (kjpindex, jnlvls), INTENT(in)          :: temp_leaf_pres_grid         ! leaf temperature down the column (K) PRESENT STEP
+     REAL(r_std), DIMENSION (kjpindex, jnlvls), INTENT(in)          :: temp_atmos_pres_grid        ! atmospheric temperature at the present timestep (K)
+     REAL(r_std), DIMENSION (kjpindex, jnlvls), INTENT(in)          :: q_atmos_pres_grid           ! specific humidity at the present timestep (kg/kg)
+
+
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)       :: q_cdrag                !! Surface drag (m s^{-1})
+     REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: jtheta                 ! specific heat capacity of air (J / (kg K) )
+
+     REAL(r_std), DIMENSION (jnlvls), INTENT (in)         :: k_eddy                 ! eddy diffusivity between each level (m^2 / s)
+     REAL(r_std), INTENT (in)                             :: k_eddy_surf            ! eddy diffusivity at the lowest level (if used)
+
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)       :: lwdown                 !! Down-welling long-wave flux (W m^{-2})
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)       :: swnet                  !! Net surface short-wave flux (W m^{-2})
+     REAL(r_std), DIMENSION (0:jnlvls), INTENT(in)        :: pad_deltah             ! leaf area density at each level (m^2 / m^3)
+     REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: jalpha, jbeta
+     REAL(r_std), DIMENSION(kjpindex), INTENT(in)         :: jalpha_surf, jbeta_surf
+     REAL(r_std), INTENT(in)                              :: temp_surf_pres
+     REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: delta_z                ! seperation of levels (m)
+     REAL(r_std), INTENT(in)                              :: delta_z_surf           ! surface layer thickness (m)
+     REAL(r_std), DIMENSION(jnlvls), INTENT(in)           :: delta_h                ! height of each level (m)
+
+
+     REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: soilcap          !! Soil calorific capacity (J K^{-1])
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)       :: soilflx          !!     JJJ     Soil flux (W m^{-2})
+
+
+
+
+     REAL(r_std), DIMENSION (jnlvls), INTENT(in)          :: u_speed                !    wind speed at each level (m/s)
+
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)       :: emis             !! Emissivity (-)
+
+     REAL(r_std), DIMENSION (kjpindex), INTENT(in)        :: rau              !!    JJJ     Air density (kg m^{-3})
+
+     REAL(r_std), DIMENSION (0:jnlvls+1, 0:jnlvls+1), INTENT(in)      :: ngu_alpha
+
+
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: u                !! Eastward Lowest level wind speed  (m s^{-1})
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: v                !! Northward Lowest level wind speed (m s^{-1})
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: petAcoef         !! PetAcoef (see note)
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: petBcoef         !! PetBcoef (see note)
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: peqAcoef         !! PeqAcoef (see note)
+     REAL(r_std), DIMENSION (kjpindex), INTENT (in)          :: peqBcoef         !! PeqBcoef (see note) 
+     REAL(r_std), DIMENSION (kjpindex), INTENT (inout)       :: vbeta            !! 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)          :: vbeta5           !! Floodplains resistance
+     REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)      :: vbeta2           !! Interception resistance (-)
+     REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)      :: vbeta3pot        !! Vegetation resistance for potential transpiration
+ !    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)      :: vbetaco2         !! Vegetation resistance to CO2 (-)
+     REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)      :: E_supply          !! Supply of water for transpiration @tex $(m.s^{-1})$ @endtex
+     REAL(r_std), DIMENSION(kjpindex), INTENT (in)           :: E_supply_tot     !! total supply of water for transpiration for each domain (m s^{-1}))
+     REAL(r_std),  DIMENSION (kjpindex, nvm), INTENT(in)     :: veget_max      !! Max. fraction of vegetation type (LAI -> infty, unitless)
+     REAL(r_std),  DIMENSION (kjpindex, nvm), INTENT(in)     :: veget          !! Vegetation fraction for each pft 
+
+     ! 0.2 output variables
+     REAL(r_std), DIMENSION (jnlvls), INTENT(out)            :: big_e, big_f, big_g
+     REAL(r_std), DIMENSION (kjpindex, jnlvls), INTENT(out)  :: flux_h_grid, flux_le_grid        ! sensible and latent heat flux respectively at each level (both W/m^2)
+     REAL(r_std), DIMENSION (jnlvls), INTENT(out)            :: a_t, b_t, c_t, d_t
+     REAL(r_std), DIMENSION (jnlvls), INTENT(out)            :: a_q, b_q, c_q, d_q 
+     REAL(r_std), DIMENSION (kjpindex, jnlvls), INTENT(out)  :: t_a_next_grid
+     REAL(r_std), DIMENSION (kjpindex, jnlvls), INTENT(out)  :: q_a_next_grid
+     REAL(r_std), DIMENSION (jnlvls), INTENT(out)            :: horiz_flux_t,  horiz_flux_q
+
+
+     REAL(r_std), INTENT(out)                                :: temp_surf_next         ! temperature of surface at respectively present and next timestep (K)
+
+     REAL(r_std), INTENT(out)                                :: flux_ground_h, flux_ground_le    ! sensible and latent heat flux respectively from the ground (both W/m^2)
+     REAL(r_std), INTENT(out)                                :: delta_temp             ! change in temperature over the time step (Kelvins)
+     REAL(r_std), DIMENSION (kjpindex, jnlvls), INTENT(out)  :: temp_leaf_next_grid
+
+
+     ! 0.3 modified variables
+
+     REAL(r_std), DIMENSION (kjpindex), INTENT(inout)        :: temp_sol_new       !! New ground temperature (K)
+
+     REAL(r_std),DIMENSION (kjpindex), INTENT(inout)         :: delta_temp_save     
+
+     REAL(r_std), DIMENSION (kjpindex), INTENT(inout)                    :: epot_air_new
+
+     REAL(r_std), DIMENSION (jnlvls), INTENT(inout)                      :: big_r, big_r_prime     ! stomatal resistance for sensible and latent heat flux at each level (s/m)    
+
+     REAL(r_std), INTENT(inout)                                          :: speed                  ! wind speed above the canopy (m/s), as defined by old enerbil
+
+     REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (inout)               :: vbeta3           !! Vegetation resistance (-)
+
+     REAL(r_std), DIMENSION (jnlvls), INTENT (inout)                     :: eta_1, eta_2
+     REAL(r_std), DIMENSION (jnlvls), INTENT (inout)                     :: eta_3, eta_4
+     REAL(r_std), INTENT (inout)                                         :: eta_1_surf, eta_2_surf
+     REAL(r_std), INTENT (inout)                                         :: eta_3_surf, eta_4_surf
+
+
+     REAL(r_std), DIMENSION (kjpindex), INTENT (inout)                   :: qair_new, qair
+     REAL(r_std), DIMENSION (kjpindex), INTENT(inout)                    :: fluxsens         !! Sensible heat flux (W m^{-2})
+     REAL(r_std), DIMENSION (kjpindex), INTENT(inout)                    :: fluxlat          !! Latent heat flux (W m^{-2})     
+     REAL(r_std), DIMENSION (kjpindex), INTENT (inout)                   :: vbeta2sum, vbeta3sum
+     REAL(r_std), DIMENSION (kjpindex), INTENT(inout)                    :: netrad           !! Net radiation flux (W m^{-2})   added by YC 
+     ! 0.4 local variables
+
+     INTEGER(i_std)                                 :: i, j, m, n, ji, jv, jk, jm
+     REAL(r_std), DIMENSION (jnlvls)                :: x_1, x_2, x_3, x_4, x_5, x_6
+     REAL(r_std), DIMENSION (jnlvls)                :: y_1, y_2, y_3, y_4, y_5, y_6 
+     REAL(r_std), DIMENSION (jnlvls)                :: t_a_pres
+     REAL(r_std), DIMENSION (jnlvls)                :: q_a_pres
+     REAL(r_std), DIMENSION (jnlvls)                :: t_l_pres, t_l_next
+     REAL(r_std), DIMENSION (jnlvls)                :: q_l_pres, q_l_next
+     REAL(r_std), DIMENSION (jnlvls)                :: big_e_top
+     REAL(r_std), DIMENSION (jnlvls)                :: big_f_top
+     REAL(r_std), DIMENSION (jnlvls)                :: big_g_top
+     REAL(r_std), DIMENSION (jnlvls)                :: big_efg_bottom
+     REAL(r_std), DIMENSION (jnlvls)                :: source_sink_t, source_sink_q
+     REAL(r_std), DIMENSION (jnlvls)                :: source_sink_sum_t, source_sink_sum_q
+     REAL(r_std), DIMENSION (jnlvls)                :: source_sink_t_l
+
+     REAL(r_std), DIMENSION (jnlvls)                :: temp_leaf_pres         ! leaf temperature down the column (K) PRESENT STEP
+     REAL(r_std), DIMENSION (jnlvls)                :: temp_atmos_pres        ! atmospheric temperature at the present timestep (K)
+     REAL(r_std), DIMENSION (jnlvls)                :: q_atmos_pres           ! specific humidity at the present timestep (kg/kg)
+     REAL(r_std), DIMENSION (jnlvls)                :: flux_h                 ! sensible heat flux at each level (both W/m^2)
+     REAL(r_std), DIMENSION (jnlvls)                :: flux_le                ! latent heat flux at each level (both W/m^2)
+     REAL(r_std), DIMENSION (jnlvls)                :: t_a_next
+     REAL(r_std), DIMENSION (jnlvls)                :: q_a_next
+
+     REAL(r_std)                                    :: big_omega_1, big_omega_2
+     REAL(r_std)                                    :: big_omega_3, big_omega_4
+     REAL(r_std)                                    :: big_omega_5, big_omega_6
+     REAL(r_std)                                    :: big_omega_7, big_omega_8
+     REAL(r_std)                                    :: big_omega_5_sub, big_omega_6_sub
+     REAL(r_std)                                    :: big_omega_7_sub, big_omega_8_sub
+     REAL(r_std)                                    :: xi_1, xi_2, xi_3, xi_4
+
+     REAL(r_std)                                    :: fevap, turb_factor
+     REAL(r_std)                                    :: M_1_h, N_1_h, M_1_q, N_1_q
+
+     REAL(r_std), DIMENSION (kjpindex)              :: beta_diffuco           ! the 'beta coefficient' from the existing scheme, for the surface layer (-) 
+     REAL(r_std), DIMENSION (kjpindex)              :: beta_diffuco_evap           ! the 'beta coefficient' from the existing scheme, for the surface layer (-)
+     REAL(r_std), DIMENSION (kjpindex)              :: beta_diffuco_sub           ! the 'beta coefficient' from the existing scheme, for the surface layer (-)
+     REAL(r_std), DIMENSION (kjpindex)              :: beta_diffuco_evap_notrans
+     REAL(r_std), DIMENSION (kjpindex)              :: beta_diffuco_evap_trans
+     REAL(r_std), DIMENSION (kjpindex)              :: E_supply_sum
+
+     REAL(r_std), DIMENSION (jnlvls)                :: delta_t_a, sum_flux_a
+     REAL(r_std), DIMENSION (jnlvls)                :: delta_q_a, sum_flux_q_a
+
+     REAL(r_std), DIMENSION (jnlvls)                :: delta_temp_leaf
+     REAL(r_std), DIMENSION (jnlvls)                :: sum_flux_leaf
+
+     REAL(r_std), DIMENSION (0:jnlvls+1)            :: gu_alpha_sum
+     REAL(r_std), DIMENSION (0:jnlvls+1)            :: ngu_temp_solid, ngu_bign
+     REAL(r_std), DIMENSION (0:jnlvls+1)            :: ngu_alpha_insert    
+
+     LOGICAL, INTENT (in)                           :: hydrol_flag            !! Flag that recalculates the energy budget for the new supply term (true/false)    
+     LOGICAL, DIMENSION (kjpindex), INTENT(in)      :: hydrol_flag2
+     LOGICAL, DIMENSION (kjpindex, nvm), INTENT(in) :: hydrol_flag3           !! flag that 'trips' the alternative energy budget for each grid square
+
+
+     INTEGER                                        :: convergence_count
+
+
+     ! initialise variables
+
+
+     flux_h(:) = 0.0d0; flux_le(:) = 0.0d0
+
+     source_sink_t(:) = 0.0d0; source_sink_q(:) = 0.0d0
+     temp_surf_next = 0.0d0
+
+     big_e = 0.0d0; big_f = 0.0d0; big_g = 0.0d0
+
+     i = 0; ji = 0
+    
+     x_1 = 0.0d0; x_2 = 0.0d0; x_3 = 0.0d0; 
+     x_4 = 0.0d0; x_5 = 0.0d0; x_6 = 0.0d0
+     y_1 = 0.0d0; y_2 = 0.0d0; y_3 = 0.0d0; 
+     y_4 = 0.0d0; y_5 = 0.0d0; y_6 = 0.0d0
+
+     ! t_a_pres = temp_atmos_pres
+     t_a_next = 0.0d0
+     ! q_a_pres = q_atmos_pres
+     q_a_next = 0.0d0
+
+     t_l_next = 0.0d0; q_l_pres = 0.0d0; q_l_next = 0.0d0
+    
+     ! n.b. set resistance of uppermost layer to <approaching infinity>
+     big_r(jnlvls) = 1.0d20; big_r_prime(jnlvls) = 1.0d20
+
+     
+     gridloop: DO ji=1, kjpindex  ! -----------------------------------------------------------------
+
+
+         ! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$  start convergence loop here  $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+	     
+         convergence_loop: DO jm = 1, 20
+
+             ! calculate the revised vbeta3sum, based on the revised vbeta3
+
+             IF (hydrol_flag) THEN  ! overall hydrol flag
+
+               
+                vbeta3sum(ji) = 0.0d0
+                DO jv = 1, nvm
+!!$                   !++++++++++
+!!$                   IF(ji == test_grid .AND. jv == test_pft)THEN
+!!$                      WRITE(numout,*) 'vbeta3 vnkldsvd 1',vbeta3(ji,jv)
+!!$                   ENDIF
+!!$                   !+++++++++++
+                   vbeta3sum(ji) = vbeta3sum(ji) + vbeta3(ji,jv)
+                ENDDO ! jv = 1, nvm    
+
+                vbeta(ji) = vbeta4(ji) + vbeta2sum(ji) + vbeta3sum(ji)
+
+             END IF ! IF (hydrol_flag .eq. .TRUE.) 
+
+             temp_leaf_pres(:) = temp_leaf_pres_grid(ji,:)
+	     t_a_pres(:) = temp_atmos_pres_grid(ji,:) 
+	     q_a_pres(:) = q_atmos_pres_grid(ji,:)
+	     t_l_pres(:) = temp_leaf_pres_grid(ji,:)
+	
+   	
+!+++++ CHECK ++++++
+! Commenting out this loop to fix a bug which caused incorrect results on large scale simulations.
+! Apparently, if we exit here some variables are not getting properly calculated for the pixels
+! which have no water stress.  This will cause a performance problem, so best to continue
+! looking into this.  One variable where it was very noticable was temp_sol_new.
+!!$	     IF (hydrol_flag) THEN
+!!$	        ! are we on the second call of enerbil, with the corrections to transpiration
+!!$	        IF (.NOT. hydrol_flag2(ji)) THEN
+!!$	           ! no need to run jcalc again if (E_supply .gt. transpir_mod) for all PFTs at this
+!!$	           !   particular grid point
+!!$	           ! WRITE (*,*) '091013 hydrol_flag2 is false so we are exiting the gridloop'
+!!$                   t_a_next_grid(ji,:) = temp_atmos_pres_grid(ji,:)
+!!$                   q_a_next_grid(ji,:) = q_atmos_pres_grid(ji,:)
+!!$                   temp_leaf_next_grid(ji,:) = temp_leaf_pres_grid(ji,:)
+!!$
+!!$                   temp_sol_new(ji) = temp_sol_new(ji)
+!!$                   IF(test_grid == ji) WRITE(numout,*) "ruieozenerbil jcalc 1",temp_sol_new(ji)
+!!$                 temp_surf_next = temp_surf_next
+!!$                   qsol_sat_new(ji) = qsol_sat_new(ji)
+!!$                   qair(ji) = qair(ji)
+!!$                   qair_new(ji) = qair(ji)
+!!$
+!!$                   fluxsens(ji) = fluxsens(ji)
+!!$                   fluxlat(ji) = fluxlat(ji)
+!!$                   vbeta2sum(ji) = vbeta2sum(ji)
+!!$                   vbeta3sum(ji) = vbeta3sum(ji)
+!!$                   vbeta3(ji,:) = vbeta3(ji,:)
+!!$
+!!$	           CYCLE gridloop
+!!$
+!!$	        ELSE
+!!$
+!!$	           ! hydrol_flag is not set, so carry on with the energy budget calculation
+!!$
+!!$	        END IF ! IF (hydrol_flag2(ji) .eq. .FALSE.)
+!!$	     ELSE
+!!$	        ! we are on the first call of enerbil
+!!$	     END IF ! IF (hydrol_flag .eq. .TRUE.) 
+!+++++++++++++++++++++++++++++++++++++++++++
+	
+             ! we are inside the loop over grid squares - speed is calculated from the horizontal
+             !   velocities u and v, which are the input parameters
+	     speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+	
+	
+	     ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+	
+             !! A note on the A and B coefficients:
+             !! The values passed down from the coupled model are petAcoef, petBcoef, peqAcoef and
+             !!   peqBcoef, allocated per gridsquare.
+             !!
+	     !! n.b. for the uncoupled mode, only b_t and b_q (at the uppermost level) have a value. 
+	     !!      All of the other coefficients are zero.
+             !!
+             !! however, for the coupled mode, a_t, b_t, a_q and b_q should all have values.
+             !! c_t, d_t, c_q and d_q should not have values as they are derived internal to enerbil
+             !! (they represent the interaction between the atmosphere in the canopy and the vegetation)
+             !! and so are all initialised here.
+             !!
+             !! The interaction between the coefficients within the module 'surf_land_orchidee' (within LMDZ) 
+             !! is as follows:
+             !! 
+             !! petAcoef (orchidee) = petBcoef (lmdz) * delta_t
+             !!
+             !! petBcoef (orchidee) = petAcoef (lmdz)
+             !!
+             !! peqAcoef (orchidee) = peqBcoef (lmdz) * delta_t
+             !!
+             !! peqBcoef (orchidee) = peqAcoef (lmdz)
+	
+	     !! enerbil_equiv ========================================
+	     a_t(jnlvls) = petAcoef(ji)        ! n.b. kjpindex = 1 corresponds to the bare soil PFT
+	     b_t(jnlvls) = petBcoef(ji)/cp_air ! n.b. kjpindex = 1 corresponds to the bare soil PFT 
+	                                       ! (petBcoef is in units of surface static energy - 
+                                               ! (cp_air * temp) as pressure difference between the 
+                                               ! surface and the lowest layer of the atmosphere is 
+                                               ! assumed negligable)
+	     ! ======================================================
+	     c_t(jnlvls) = 0.0d0
+	     d_t(jnlvls) = 0.0d0
+	
+	
+	     ! ====================================================================================
+	     a_q(jnlvls) = peqAcoef(ji) ! n.b. kjpindex = 1 corresponds to the bare soil PFT
+	     b_q(jnlvls) = peqBcoef(ji) ! n.b. kjpindex = 1 corresponds to the bare soil PFT 
+	                                !      (peqBcoef is already in units of (kg/kg)
+	     ! ====================================================================================
+	     c_q(jnlvls) = 0.0d0
+	     d_q(jnlvls) = 0.0d0
+	
+	
+	     beta_diffuco(ji) =  1.0d0 * vbeta1(ji) * (un - vbeta5(ji)) + &
+	           & (un - vbeta1(ji)) * (un - vbeta5(ji)) * vbeta(ji) + vbeta5(ji)
+	
+	
+	     ! seperating the beta_diffuco term above into expressions for sublimination (snow) and
+	     !   evaporation
+	     beta_diffuco_sub(ji) = vbeta1(ji) * (1.0d0 - vbeta5(ji))
+	     beta_diffuco_evap(ji) = (1.0d0 - vbeta1(ji)) * &
+	                              & (1.0d0 -vbeta5(ji)) * vbeta(ji) + vbeta5(ji)
+	
+	
+	     ! the version of the evaporation expression above for which the transpiration term is 
+	     !   removed
+	     beta_diffuco_evap_notrans(ji) = (1.0d0 - vbeta1(ji)) * &
+	                              & (1.0d0 - vbeta5(ji)) * (vbeta4(ji) + vbeta2sum(ji)) + vbeta5(ji)
+	
+	     ! the version of the evaporation expression above for which the transpiration term is 
+	     !   included? (check this...)
+	     beta_diffuco_evap_trans(ji) = (1.0d0 - vbeta1(ji)) * &
+	                              & (1.0d0 - vbeta5(ji)) * vbeta3sum(ji)
+	
+	
+	
+	     ! Gu radiation total calculation 
+	
+	     IF (jnlvls .eq. 1) THEN
+	
+	        eta_1_surf = 1.0d0 - (1.0d0 - emis(ji))
+	        eta_4_surf = 1.0d0
+	
+	        eta_2_surf = - c_stefan * 4.0d0 * emis(ji) * (psold(ji)/cp_air)**3
+	        eta_3_surf = - 3.0d0 * c_stefan * emis(ji) * ((psold(ji)/cp_air)**4)
+	
+                DO i = 1, jnlvls
+	
+	            eta_1(i) = 0.0d0 
+	
+	            eta_2(i) = c_stefan * 4.0d0 * temp_leaf_pres(i)**3
+	
+	            eta_3(i) = c_stefan * 3.0d0 * temp_leaf_pres(i)**4 
+
+                    eta_4(i) = 0.0d0
+	
+	        END DO ! i = 1, jnlvls
+
+	        ELSE
+
+	           ngu_temp_solid(0) = c_stefan * ((psold(ji)/cp_air)**4)
+		
+	           DO i = 1, jnlvls
+	              ngu_temp_solid(i) = c_stefan * (temp_leaf_pres(i)**4) 
+	           END DO ! i = 1, jnlvls
+	
+	           ngu_temp_solid(jnlvls+1) = lwdown(ji)
+	
+	           ngu_bign(:) = 0.0d0
+	
+	           DO i = 0, jnlvls + 1 
+	              DO j = 0, jnlvls + 1
+	                 IF (i .ne. j) THEN
+	                    ngu_bign(i) = ngu_bign(i) + ( ngu_alpha(i,j) * ngu_temp_solid(j) )
+	                 ELSE
+	                    ngu_bign(i) = ngu_bign(i) + 0.0d0
+	                 END IF ! (i .ne. j)            
+	              END DO ! j = 0, jnlvls + 1
+	           END DO ! i = 0, jnlvls + 1
+	
+	           ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+		
+	           DO i = 1, jnlvls
+	
+	               eta_1(i) = 0.0d0 
+	
+	               eta_2(i) = (2.0d0*ngu_alpha_insert(i)-2.0d0) &
+	                        &  * c_stefan * 4.0d0 * temp_leaf_pres(i)**3
+	
+	               eta_3(i) = -(2.0d0*ngu_alpha_insert(i) - 2.0d0) &
+	                        &  * c_stefan * 3.0d0 * temp_leaf_pres(i)**4 + ngu_bign(i)
+	
+	           END DO ! i = 1, jnlvls
+		
+	           ! The Gu method assumes black body emitters for simplicity
+	   
+	           eta_1_surf = 0.0d0
+	
+	           eta_2_surf = - 4.0d0 * c_stefan * (((1.0d0/cp_air) * psold(ji))**3)      
+	
+	           eta_3_surf = - (c_stefan * (3.0d0 * (psold(ji)/cp_air)**4) + ngu_bign(0))
+	
+	       END IF
+		
+	      ! this is just for the lowermost vegetation layer
+	      ! there is a special case for 'single layer model', which reduces to the ORCHIDEE trunk
+	
+	      IF (jnlvls .eq. 1) THEN
+	
+	          x_1(1) = 0.0d0; x_2(1) = 0.0d0; x_3(1) = 0.0d0; x_4(1) = 0.0d0; x_5(1) = 0.0d0
+	
+	          y_1(1) = 0.0d0; y_2(1) = 0.0d0; y_3(1) = 0.0d0; y_4(1) = 0.0d0; y_5(1) = 0.0d0
+		
+	          DO i = jnlvls, jnlvls
+	
+	               big_e_top(i) = (-(dtradia*a_q(i)*chalev0*rau(ji))/                                &
+	                  &  (rho_veg*leaf_tks*pad_deltah(i)*delta_h(i)*                                 &
+	                  &  big_r_prime(i)*jtheta(i)))                                                  &
+	                  &  - ((dtradia* d_t(i) * cp_air * rau(ji)) /                                   & 
+	                  & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * big_r(i) * jtheta(i)))   
+	
+	               big_f_top(i) = (-(dtradia*a_t(i)*cp_air*rau(ji))/                                 &
+	                  & (rho_veg*leaf_tks*pad_deltah(i)*delta_h(i)*                                  &
+	                  & big_r(i)*jtheta(i)))                                                         &
+	                  & -((dtradia* d_q(i) * chalev0 * rau(ji)) /                                    &
+	                  & (rho_veg*leaf_tks * pad_deltah(i)* delta_h(i) * big_r_prime(i) * jtheta(i)))
+	
+	               big_g_top(i) = (t_l_pres(i) + dtradia* eta_3(i)/                                  &
+	                  & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * jtheta(i))                  &  
+	                  &  + (eta_1(i) * lwdown(ji) * dtradia)/                                        &
+	                  & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * jtheta(i))                  &
+	                  &  + (eta_4(i) * swnet(ji) * dtradia)/                                         &
+	                  & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * jtheta(i))                  &
+	                  &  + (chalev0 * rau(ji) * dtradia* jbeta(i))/                                  &
+	                  & (rho_veg*leaf_tks * pad_deltah(i) *delta_h(i) *  big_r_prime(i) * jtheta(i)) &
+	                  &  - (dtradia* cp_air * rau(ji) * b_t(i))/                                     &
+	                  & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * big_r(i) * jtheta(i))       &
+	                  &  - (dtradia* chalev0 * rau(ji) * b_q(i))/                                    &
+	                  & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * big_r_prime(i) * jtheta(i)))
+	
+	               big_efg_bottom(i) =                                                               &
+	                  & ( 1.0d0 - (dtradia* jalpha(i) * chalev0 * rau(ji))/                          &
+	                  &  (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * big_r_prime(i)*jtheta(i))  &
+	                  &  - (dtradia* cp_air * rau(ji)) /                                             &
+	                  & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * jtheta(i) * big_r(i))       &
+	                  &  - (eta_2(i) * dtradia) /                                                    & 
+	                  & (rho_veg *leaf_tks * pad_deltah(i) * delta_h(i) * jtheta(i))                 &
+	                  &  + (dtradia* chalev0 * rau(ji) * cp_air * c_t(i)) /                          &
+	                  & (rho_veg *leaf_tks * pad_deltah(i) * delta_h(i) *                            &
+	                  &  jtheta(i) * big_r(i)) )
+	
+	               big_e(i) = big_e_top(i) / big_efg_bottom(i)
+	 
+	               big_f(i) = big_f_top(i) / big_efg_bottom(i)
+	
+	               big_g(i) = big_g_top(i) / big_efg_bottom(i)
+	
+	          END DO ! i = jnlvls, jnlvls
+		
+	      ELSE ! IF (jnlvls doesn't equal 1)....
+		
+	          DO i = jnlvls, jnlvls
+	
+	              big_e_top(i) = (+(dtradia*a_q(i)*chalev0*rau(ji))/                                 &
+	                  &  (rho_veg*leaf_tks*pad_deltah(i)*delta_h(i)*                                 &
+	                  &  big_r_prime(i)*jtheta(i)))                                                  &
+	                  &  + ((dtradia* d_t(i) * cp_air * rau(ji)) /                                   & 
+	                  & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * big_r(i) * jtheta(i)))   
+	
+	              big_f_top(i) = (+(dtradia*a_t(i)*cp_air*rau(ji))/                                  &
+	                  & (rho_veg*leaf_tks*pad_deltah(i)*delta_h(i)*                                  &
+	                  & big_r(i)*jtheta(i)))                                                         &
+	                  & +((dtradia* d_q(i) * chalev0 * rau(ji)) /                                    & 
+	                  & (rho_veg*leaf_tks * pad_deltah(i)* delta_h(i) * big_r_prime(i) * jtheta(i)))
+	
+	              big_g_top(i) = (t_l_pres(i) + dtradia* eta_3(i)/                                   &
+	                  & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * jtheta(i))                  & 
+	                  &  + (eta_1(i) * lwdown(ji) * dtradia)/                                        &
+	                  & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * jtheta(i))                  &
+	                  &  + (eta_4(i) * swnet(ji) * dtradia)/                                         & 
+	                  & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * jtheta(i))                  &
+	                  &  - (chalev0 * rau(ji) * dtradia* jbeta(i))/                                  &
+	                  & (rho_veg*leaf_tks * pad_deltah(i) *delta_h(i) *  big_r_prime(i) * jtheta(i)) &
+	                  &  + (dtradia* cp_air * rau(ji) * b_t(i))/                                     &
+	                  & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * big_r(i) * jtheta(i))       &
+	                  &  + (dtradia* chalev0 * rau(ji) * b_q(i))/                                    & 
+	                  & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * big_r_prime(i) * jtheta(i)) )
+	
+	              big_efg_bottom(i) =                                                                &
+	                  & ( 1.0d0 + (dtradia* jalpha(i) * chalev0 * rau(ji))/                          &
+	                  &  (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * big_r_prime(i)*jtheta(i))  &
+	                  &  + (dtradia* cp_air * rau(ji)) /                                             &
+	                  & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * jtheta(i) * big_r(i))       &
+	                  &  - (eta_2(i) * dtradia) /                                                    & 
+	                  & (rho_veg *leaf_tks * pad_deltah(i) * delta_h(i) * jtheta(i))                 &
+	                  &  - (dtradia* chalev0 * rau(ji) * cp_air * c_t(i)) /                          &
+	                  & (rho_veg *leaf_tks * pad_deltah(i) * delta_h(i) *                            &
+	                  &  jtheta(i) * big_r(i)) )
+	
+	              big_e(i) = big_e_top(i) / big_efg_bottom(i)
+	   
+	              big_f(i) = big_f_top(i) / big_efg_bottom(i)
+	
+	              big_g(i) = big_g_top(i) / big_efg_bottom(i)
+	
+	         END DO ! i = jnlvls, jnlvls
+		
+	      DO i=jnlvls-1, 2, -1
+	
+	          ! --------------------------------------------------------------------
+	
+	          x_1(i) = 1 - ( dtradia* ( (a_t(i+1) * (k_eddy(i)/(delta_z(i)*delta_h(i))))   &
+	                    &           - (k_eddy(i)/(delta_z(i)*delta_h(i)))                  &
+	                    &           - (k_eddy(i-1)/(delta_z(i-1)*delta_h(i)))              &
+	                    &           - ((1.0d0)/(big_r(i)*delta_h(i)))))                    &
+	                    &           - ((k_eddy(i) * c_t(i+1)) /                            &
+	                    &             (delta_z(i)*delta_h(i))) * big_f(i+1) * dtradia
+	
+	          x_2(i) = t_a_pres(i) + ((b_t(i+1)*k_eddy(i)*dtradia)/(delta_z(i) * delta_h(i)))  &
+	             & + ((k_eddy(i) * c_t(i+1)) / (delta_z(i) * delta_h(i))) * big_g(i+1) * dtradia
+	
+	          x_3(i) = (k_eddy(i-1)/(delta_z(i-1)*delta_h(i))) * dtradia
+	
+	          x_4(i) = (k_eddy(i) * d_t(i+1) / (delta_z(i) * delta_h(i))) * dtradia            &
+	             &  + ((k_eddy(i) * c_t(i+1)) / (delta_z(i) * delta_h(i))) * big_e(i+1) * dtradia
+	
+	          x_5(i) = + (dtradia) / (delta_h(i) * big_r(i))
+	
+	          ! -------------------------------------------------------------------
+	
+	          y_1(i) = 1 - ( dtradia* ( (a_q(i+1) * (k_eddy(i)/(delta_z(i)*delta_h(i))))       &
+	             &  - (k_eddy(i)/(delta_z(i)*delta_h(i)))                                      &
+	             &  - (k_eddy(i-1)/(delta_z(i-1)*delta_h(i)))                                  &
+	             &  - ((1.0d0)/(big_r_prime(i)*delta_h(i)))))                                  &
+	             &  - ((k_eddy(i) * c_q(i+1)) / (delta_z(i)*delta_h(i))) * big_e(i+1) * dtradia
+	
+	          y_2(i) = q_a_pres(i) +                                                           &
+	             & ((b_q(i+1) * k_eddy(i) * dtradia)/(delta_z(i) * delta_h(i)))                &
+	             & + (jbeta(i) * dtradia)  / (big_r_prime(i)*delta_h(i))                       &
+	             & + ((k_eddy(i) * c_q(i+1)) / (delta_z(i) * delta_h(i))) * big_g(i+1) * dtradia
+	
+	          y_3(i) = (k_eddy(i-1)/(delta_z(i-1)*delta_h(i))) * dtradia
+	
+	          y_4(i) = (k_eddy(i) * d_q(i+1) / (delta_z(i) * delta_h(i))) * dtradia            &
+	             &  + ((k_eddy(i) * c_q(i+1)) / (delta_z(i) * delta_h(i))) * big_f(i+1) * dtradia
+	
+	          y_5(i) = + (jalpha(i) * dtradia) / (delta_h(i) * big_r_prime(i))
+	
+	          ! -------------------------------------------------------------------
+	
+	          a_t(i) = x_3(i) / (x_1(i) - (x_4(i) * (y_4(i) / y_1(i))))
+	          b_t(i) = ( x_2(i) + (x_4(i) * (y_2(i)/y_1(i))) )  /        &
+	                 & (x_1(i) - (x_4(i) *(y_4(i)/y_1(i))))
+	          c_t(i) = ( (x_4(i) * (y_5(i)/y_1(i))) + x_5(i)) /          &
+	                 & (x_1(i) - (x_4(i)*(y_4(i)/y_1(i))))
+	          d_t(i) = ( x_4(i) * (y_3(i)/y_1(i))  )   /                 &
+	                 & (x_1(i) - (x_4(i) * (y_4(i) / y_1(i))))
+	
+	          ! -------------------------------------------------------------------
+	
+	          a_q(i) = y_3(i) / (y_1(i) - (y_4(i) * (x_4(i) / x_1(i))))
+	          b_q(i) = ( y_2(i) + (y_4(i) * (x_2(i)/x_1(i))) )  /        &
+	                 & (y_1(i) - (y_4(i) *(x_4(i)/x_1(i))))
+	          c_q(i) = ( (y_4(i) * (x_5(i)/x_1(i))) + y_5(i)) /          &
+	                 & (y_1(i) - (y_4(i)*(x_4(i)/x_1(i))))
+	          d_q(i) = ( y_4(i) * (x_3(i)/x_1(i))  )   /                 &
+	                 & (y_1(i) - (y_4(i) * (x_4(i) / x_1(i))))
+	
+	          ! -------------------------------------------------------------------
+	
+	          big_e_top(i) = (+(dtradia*a_q(i)*chalev0*rau(ji))/                             &
+	              & (rho_veg*leaf_tks * pad_deltah(i)*delta_h(i)*big_r_prime(i)*jtheta(i)))  &
+	              & + ((dtradia* d_t(i) * cp_air * rau(ji)) /                                &
+	              & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i) * big_r(i) * jtheta(i)))   
+	
+	          big_f_top(i) = ( + (dtradia* a_t(i) * cp_air * rau(ji))/                       &
+	              & (rho_veg*leaf_tks * pad_deltah(i)* delta_h(i)                            &
+	              & * big_r(i) * jtheta(i)) )                                                &
+	              & + ((dtradia* d_q(i) * chalev0 * rau(ji)) /                               &
+	              & (rho_veg*leaf_tks * pad_deltah(i) * delta_h(i)                           &
+	              & * big_r_prime(i) * jtheta(i)))
+	
+	          big_g_top(i) = (t_l_pres(i)+dtradia*eta_3(i)/                                  &
+	              & (rho_veg*leaf_tks*pad_deltah(i)*delta_h(i)*jtheta(i))                    & 
+	              & + (eta_1(i)*lwdown(ji)*dtradia)/                                         &
+	              & (rho_veg*leaf_tks*pad_deltah(i)*delta_h(i)*jtheta(i))                    &
+	              & + (eta_4(i)*swnet(ji)*dtradia)/                                          &
+	              & (rho_veg*leaf_tks*pad_deltah(i)*delta_h(i)*jtheta(i))                    &
+	              & - (chalev0*rau(ji)*dtradia*jbeta(i))/                                    &
+	              & (rho_veg*leaf_tks*pad_deltah(i)*delta_h(i) *                             &
+	              &  big_r_prime(i)*jtheta(i))                                               &
+	              & + (dtradia*cp_air*rau(ji)*b_t(i))/                                       &
+	              & (rho_veg*leaf_tks*pad_deltah(i)*delta_h(i)*big_r(i)* jtheta(i))          &
+	              & + (dtradia*chalev0*rau(ji)*b_q(i))/                                      &
+	              & (rho_veg*leaf_tks*pad_deltah(i)*delta_h(i)*                              &
+	              & big_r_prime(i)*jtheta(i)) )
+	
+	          big_efg_bottom(i) =                                                            &
+	              & ( 1.0d0 + (dtradia* jalpha(i) * chalev0 * rau(ji)) /                     &
+	              & (rho_veg *leaf_tks * pad_deltah(i) * delta_h(i) *                        &
+	              & big_r_prime(i) * jtheta(i))                                              &
+	              & + (dtradia* cp_air * rau(ji)) /                                          &
+	              & (rho_veg *leaf_tks * pad_deltah(i) * delta_h(i) * jtheta(i) * big_r(i))  &
+	              & - (eta_2(i) * dtradia) /                                                 &
+	              & (rho_veg*leaf_tks * pad_deltah(i)  * delta_h(i) * jtheta(i))             &
+	              & - (dtradia* chalev0 * rau(ji) * c_q(i)) /                                & 
+	              & (rho_veg *leaf_tks* pad_deltah(i) * delta_h(i) * jtheta(i)               &
+	              & * big_r_prime(i))                                                        &
+	              & - (dtradia* cp_air * rau(ji) * c_t(i))/                                  &
+	              & (rho_veg *leaf_tks * pad_deltah(i) * delta_h(i) * jtheta(i) * big_r(i)))
+	
+	          big_e(i) = big_e_top(i) / big_efg_bottom(i)
+	 
+	          big_f(i) = big_f_top(i) / big_efg_bottom(i)
+	
+	          big_g(i) = big_g_top(i) / big_efg_bottom(i)
+	           
+	          ! -------------------------------------------------------------------
+	
+	      END DO !i = jnlvls-1, 2, -1
+		
+	          x_1(1) = 1.0d0 - dtradia* ((a_t(2) * k_eddy(1)) / (delta_z(1)*delta_h(1))      &
+	                  &  +  (k_eddy(1) * c_t(2) * big_f(2)) / (delta_z(1) * delta_h(1))      &
+	                  &  -  (k_eddy(1) / (delta_z(1) * delta_h(1)))                          &
+	                  &  -  ( 1.0d0 / (delta_h(1) * big_r(1))) )
+	
+	          x_2(1) = t_a_pres(1)+dtradia*(  (k_eddy(1) * b_t(2))/(delta_z(1) * delta_h(1))  &
+	                  &   +  (k_eddy(1) * c_t(2) * big_g(2))/(delta_z(1) * delta_h(1)) )
+	
+	          x_3(1) = dtradia* (1.0d0 / delta_h(1)) * ( 1.0d0 / (rau(ji) * cp_air) )    
+	
+	          x_4(1) = dtradia* ( (k_eddy(1) * c_t(2) * big_e(2)) + (k_eddy(1) * d_t(2)) ) / &
+	                  & (delta_z(1) * delta_h(1)) 
+	 
+	          x_5(1) = + dtradia* ( 1.0d0 / (delta_h(1) * big_r(1)) )
+	
+	          ! -------------------------------------------------------------------
+	
+	          y_1(1) = 1.0d0 - dtradia* (    (a_q(2) * k_eddy(1)) / (delta_z(1)*delta_h(1))  &
+	                  &  +  (k_eddy(1) * c_q(2) * big_e(2)) / (delta_z(1) * delta_h(1))      &
+	                  &  -  (k_eddy(1) / (delta_z(1) * delta_h(1)))                          &
+	                  &  -  ( 1.0d0 / (delta_h(1) * big_r_prime(1))) )
+	
+	          y_2(1) = q_a_pres(1)+dtradia*(  (k_eddy(1) * b_q(2))/(delta_z(1) * delta_h(1)) &
+	                  &   +  (k_eddy(1) * c_q(2) * big_g(2))/(delta_z(1) * delta_h(1))       &
+	                  &   + jbeta(1) / (delta_h(1) * big_r_prime(1)) )
+	
+	          y_3(1) = dtradia* (1.0d0 / delta_h(1)) * ( 1.0d0 / (rau(ji) * chalev0) )
+	
+	          y_4(1) = dtradia* ( (k_eddy(1) * c_q(2) * big_f(2)) + (k_eddy(1) * d_q(2)) ) /  &
+	                  &   (delta_z(1) * delta_h(1)) 
+	 
+	          y_5(1) = + dtradia* ( jalpha(1) / (delta_h(1) * big_r_prime(1)) )
+	
+	          ! -------------------------------------------------------------------
+	
+	          a_t(1) = x_3(1) / (x_1(1) - (x_4(1) * (y_4(1) / y_1(1))))
+	          b_t(1) = ( x_2(1) + (x_4(1) * (y_2(1)/y_1(1))) )  /         &
+	                   & (x_1(1) - (x_4(1) *(y_4(1)/y_1(1))))
+	          c_t(1) = ( (x_4(1) * (y_5(1)/y_1(1))) + x_5(1)) /           &
+	                   & (x_1(1) - (x_4(1)*(y_4(1)/y_1(1))))
+	          d_t(1) = ( x_4(1) * (y_3(1)/y_1(1))  )   /                  &
+	                   & (x_1(1) - (x_4(1) * (y_4(1) / y_1(1))))
+	
+	          ! -------------------------------------------------------------------
+	
+	          a_q(1) = y_3(1) / (y_1(1) - (y_4(1) * (x_4(1) / x_1(1))))
+	          b_q(1) = ( y_2(1) + (y_4(1) * (x_2(1)/x_1(1))) )  /         &
+	                   & (y_1(1) - (y_4(1) *(x_4(1)/x_1(1))))
+	          c_q(1) = ( (y_4(1) * (x_5(1)/x_1(1))) + y_5(1)) /           & 
+	                   & (y_1(1) - (y_4(1)*(x_4(1)/x_1(1))))
+	          d_q(1) = ( y_4(1) * (x_3(1)/x_1(1))  )   /                  &
+	                   & (y_1(1) - (y_4(1) * (x_4(1) / x_1(1))))
+	
+	          ! -------------------------------------------------------------------
+	
+	      END IF ! (jnlvls .eq. 1)... THEN ELSE...
+	
+	
+	      big_e_top(1) = (+(dtradia* a_q(1) * chalev0 * rau(ji)) /                             &
+	         & (rho_veg *leaf_tks * pad_deltah(1) * delta_h(1) * big_r_prime(1) * jtheta(1)))  &
+	         & +((dtradia* d_t(1) * cp_air * rau(ji)) /                                        &
+	         & (rho_veg*leaf_tks * pad_deltah(1) * delta_h(1) * big_r(1) * jtheta(1)) )   
+	
+	      big_f_top(1) = (+(dtradia* a_t(1) * cp_air * rau(ji)) /                              &
+	         & (rho_veg*leaf_tks * pad_deltah(1) * delta_h(1) * big_r(1) * jtheta(1)))         &
+	         & + ((dtradia* d_q(1) * chalev0 * rau(ji)) /                                      &
+	         & (rho_veg*leaf_tks * pad_deltah(1) * delta_h(1) * big_r_prime(1) * jtheta(1)))
+	
+	      big_g_top(1) = (t_l_pres(1) + dtradia* eta_3(1) /                                    &
+	         & (rho_veg*leaf_tks * pad_deltah(1) * delta_h(1) * jtheta(1))                     & 
+	         & + (eta_1(1) * lwdown(ji) * dtradia)/                                            &
+	         & (rho_veg *leaf_tks* pad_deltah(1) * delta_h(1) * jtheta(1))                     &
+	         &  + (eta_4(1) * swnet(ji) * dtradia)/                                            &
+	         & (rho_veg *leaf_tks* pad_deltah(1) * delta_h(1) * jtheta(1))                     &
+	         &  - (chalev0 * rau(ji) * dtradia* jbeta(1))/                                     & 
+	         & (rho_veg *leaf_tks* pad_deltah(1) *delta_h(1) * big_r_prime(1) * jtheta(1))     &
+	         &  + (dtradia* cp_air * rau(ji) * b_t(1)) /                                       &
+	         & (rho_veg *leaf_tks* pad_deltah(1) * delta_h(1) * big_r(1) * jtheta(1))          &
+	         &  + (dtradia* chalev0 * rau(ji) * b_q(1)) /                                      &
+	         & (rho_veg *leaf_tks * pad_deltah(1) * delta_h(1) * big_r_prime(1) * jtheta(1)))
+	
+	      big_efg_bottom(1) = ( 1.0d0 + (dtradia* jalpha(1) * chalev0 * rau(ji))/              &
+	         & (rho_veg *leaf_tks * pad_deltah(1) * delta_h(1) * big_r_prime(1) * jtheta(1))   &
+	         & + (dtradia* cp_air * rau(ji)) /                                                 &
+	         & (rho_veg *leaf_tks * pad_deltah(1) * delta_h(1) * jtheta(1) * big_r(1))         &
+	         & - (eta_2(1) * dtradia) /                                                        &
+	         & (rho_veg*leaf_tks * pad_deltah(1)  * delta_h(1) * jtheta(1))                    &
+	         & - (dtradia* chalev0 * rau(ji) * c_q(1)) /                                       &
+	         & (rho_veg *leaf_tks * pad_deltah(1) * delta_h(1) * jtheta(1) * big_r_prime(1))   &
+	         & - (dtradia* cp_air * rau(ji) * c_t(1))/                                         &
+	         & (rho_veg *leaf_tks * pad_deltah(1) * delta_h(1) * jtheta(1)*big_r(1)))
+	
+	
+	      big_e(1) = big_e_top(1) / big_efg_bottom(1)
+	 
+	      big_f(1) = big_f_top(1) / big_efg_bottom(1)
+	
+	      big_g(1) = big_g_top(1) / big_efg_bottom(1)    
+	
+	      ! --------------------------------------------------------------------------------------------------------------
+	    
+
+	      turb_factor = speed * q_cdrag(ji)            ! surface turbulence calculated as in existing ORCHIDEE
+
+	
+	      ! components for surface sensible heat flux    
+	
+	      big_omega_1 = 1.0d0 - (rau(ji) * 1.0d0) * turb_factor * &
+	                 & (a_t(1) + c_t(1) * big_f(1)) 
+	
+	      big_omega_2 = + (rau(ji) * cp_air) * turb_factor * &
+	                 & (b_t(1) + c_t(1) * big_g(1))
+	    
+	      big_omega_3 = - rau(ji) * cp_air * turb_factor 
+	    
+	      big_omega_4 = + rau(ji) * cp_air * turb_factor * &
+	                 & (c_t(1) * big_e(1) + d_t(1))
+	    
+		
+	
+	      ! components for surface latent heat flux (evaporation)
+	
+	      big_omega_5 = 1.0d0 - (rau(ji) * 1.0d0) * turb_factor * & 
+	                 & (a_q(1) + c_q(1) * big_e(1)) 
+	    
+	      big_omega_6 = + (rau(ji) * chalev0) * turb_factor * &
+	                 & (b_q(1) + c_q(1) * big_g(1) - jbeta_surf(ji) )
+	    
+	      big_omega_7 = - jalpha_surf(ji) * rau(ji) * chalev0 * turb_factor
+	    
+	      big_omega_8 = + rau(ji) * chalev0 * turb_factor * &
+	                 & (c_q(1) * big_f(1) + d_q(1))
+	
+	
+	
+	
+	      ! components for surface latent heat flux (sublimination)
+	
+	      big_omega_5_sub = 1.0d0 - (rau(ji) * 1.0d0) * turb_factor * & 
+	                 & (a_q(1) + c_q(1) * big_e(1)) 
+	    
+	      big_omega_6_sub = + (rau(ji) * chalsu0) * turb_factor * &
+	                 & (b_q(1) + c_q(1) * big_g(1) - jbeta_surf(ji) )
+	    
+	      big_omega_7_sub = - jalpha_surf(ji) * rau(ji) * chalsu0 * turb_factor
+	    
+	      big_omega_8_sub = + rau(ji) * chalsu0 * turb_factor * &
+	                 & (c_q(1) * big_f(1) + d_q(1))
+	
+	
+	      ! --------------------------------------------------------------------------------------------------------------
+	
+	      xi_1 = ( big_omega_2 + (big_omega_4/big_omega_5) * big_omega_6 )  / &
+	            &  ( big_omega_1 - (big_omega_4/big_omega_5) * big_omega_8 )
+	
+	      xi_2 = ( big_omega_3 + (big_omega_4/big_omega_5) * big_omega_7 )  / &
+	            &  ( big_omega_1 - (big_omega_4/big_omega_5) * big_omega_8 )
+	
+	      xi_3 = beta_diffuco_evap(ji) *                                              &
+	            & ( big_omega_6 + (big_omega_8/big_omega_1) * big_omega_2 ) /         &
+	            & ( big_omega_5 - (big_omega_8/big_omega_1) * big_omega_4 )  +        &
+	            & beta_diffuco_sub(ji) *                                              &
+	            & ( big_omega_6_sub + (big_omega_8_sub/big_omega_1) * big_omega_2 ) / &
+	            & ( big_omega_5_sub - (big_omega_8_sub/big_omega_1) * big_omega_4 ) 
+	
+	      xi_4 = beta_diffuco_evap(ji) *                                              &
+	            & ( big_omega_7 + (big_omega_8/big_omega_1) * big_omega_3 ) /         &
+	            &  ( big_omega_5 - (big_omega_8/big_omega_1) * big_omega_4 ) +        &
+	            & beta_diffuco_sub(ji) *                                              &
+	            & ( big_omega_7_sub + (big_omega_8_sub/big_omega_1) * big_omega_3 ) / &
+	            &  ( big_omega_5_sub - (big_omega_8_sub/big_omega_1) * big_omega_4 ) 
+	
+
+ !             WRITE(numout,*) "calcul temp surf next 1", psold(ji), soilcap(ji), soilflx(ji)
+ !             WRITE(numout,*) "calcul temp surf next 2", lwdown(ji), swnet(ji)
+ !             WRITE(numout,*) "calcul temp surf next 3", xi_1, xi_3, xi_4
+ !             WRITE(numout,*) "calcul temp surf next 4", eta_1_surf, eta_4_surf, eta_3_surf
+   
+	
+	      temp_surf_next = (psold(ji)/cp_air + (dtradia/soilcap(ji)) * ( xi_1 + xi_3   &
+	            & + eta_1_surf*lwdown(ji)                                              &
+	            & + eta_4_surf*swnet(ji)                                               &
+	            & - eta_3_surf + soilflx(ji)) ) /                                      &
+	            & ( 1.0d0 - (xi_2 + xi_4 + eta_2_surf) * (dtradia/soilcap(ji)))
+
+
+!              WRITE(numout,*) "temp_surf_next", temp_surf_next
+	      temp_sol_new(ji) = temp_surf_next
+	
+
+	      psnew(ji) = temp_surf_next * cp_air
+	
+	      qsol_sat_new(ji) = qsol_sat(ji) + &
+	                  &  (1.0d0/(cp_air)) * pdqsold(ji) * &
+	                  &  (psnew(ji) - psold(ji))
+
+	
+	      delta_temp = temp_surf_next - psold(ji)/cp_air
+	
+	      epot_air_new(ji) = (1.0d0/( rau(ji) * speed * q_cdrag(ji))) *                 &
+	                   & (cp_air * b_t(1) - psold(ji) - cp_air * delta_temp) /          &
+	                   & ((1.0d0/( rau(ji) * speed * q_cdrag(ji))) - a_t(1) ) +         &
+	                   & cp_air * temp_surf_next
+               	
+	
+	      ! %%%%% JR 060913 section modified from enerbil_flux %%%%%%%%%%%%%%%%%
+	
+	      !! \latexonly 
+	      !!     \input{enerbilsurftemp17.tex}
+	      !! \endlatexonly
+		
+	      fevap = (chalev0 * beta_diffuco_evap(ji) +                                         &
+	              & chalsu0 * beta_diffuco_sub(ji)) * ((b_q(1) - qsol_sat(ji)) /             &
+	              & ((1.0d0/(rau(ji)*speed*q_cdrag(ji))) - a_q(1) ) )                        &
+	              & - (chalev0 * beta_diffuco_evap(ji) + chalsu0 * beta_diffuco_sub(ji))     &
+	              & * ((pdqsold(ji)/cp_air) /                                                &
+	              & ((1.0d0/(rau(ji)*speed*q_cdrag(ji))) - a_q(1) )  )  *                    &
+	              & (cp_air*temp_surf_next - psold(ji))
+	
+	
+	      IF ( ABS(fevap) < EPSILON(un) ) THEN
+	        
+	          !! \latexonly 
+	          !!     \input{enerbilsurftemp18.tex}
+	          !! \endlatexonly
+	
+	          qair_new(ji) = qair(ji)
+	      ELSE
+	          !! \latexonly 
+	          !!     \input{enerbilsurftemp19.tex}
+	          !! \endlatexonly     
+	
+	          qair_new(ji) = (1.0d0/( rau(ji) * speed * q_cdrag(ji))) * un / ( chalsu0 *  vbeta1(ji) * (un - vbeta5(ji)) + &
+                 & chalev0 * ((un - vbeta1(ji))*(un - vbeta5(ji)) * vbeta(ji) * 1.0d0 + vbeta5(ji)) ) &
+                 & * fevap + qsol_sat_new(ji)  
+ 
+	      ENDIF
+              	
+	
+	      ! 201013 calculate new series of beta_v3
+	      
+	      IF (hydrol_flag) THEN  ! overall hydrol flag
+	      ! vbeta2sum(:) = zero
+	         IF (hydrol_flag2(ji)) THEN
+	            DO jv = 1, nvm
+	               IF (.NOT. hydrol_flag3(ji, jv)) THEN 
+                          ! WRITE(*,*) "041113 not hydrol_flag3"
+	                  ! this is for cases when the supply term is higher than the 
+	                  !     transpiration) - i.e. the normal state of affairs
+	                  ! WRITE(numout,*) '201013 vbeta3(ji,jv) is unchanged as: ', vbeta3(ji,jv)
+	               ELSE
+                          ! WRITE(*,*) "041113 hydrol_flag3"
+	                 ! WRITE(numout,*) '261113 vbeta3(ji,jv) is originally: ', vbeta3(ji,jv)
+  
+	                  vbeta3(ji,jv) = ( veget_max(ji,jv)* E_supply(ji,jv) ) / &
+	                      & ( dtradia * (1.0d0 - vbeta1(ji)) * (qsol_sat_new(ji) - qair_new(ji)) * ( rau(ji) * speed * q_cdrag(ji)) )
+                        ! write(*,*) 'vbeta3_ener', vbeta3(ji,jv)
+                        !write(*,*) 'veget_max',veget_max(ji,jv)
+                        !write(*,*) 'E_supplyYYT',E_supply(ji,jv)
+                        !write(*,*) 'qsol_sat_new',qsol_sat_new(ji)
+                        !write(*,*) 'qair_new',qair_new(ji)
+                           ! WRITE(numout,*) 'PFT no. : ', jv              
+	                 ! WRITE(numout,*) '261113 new vbeta3(ji,jv) is: ', vbeta3(ji,jv)    
+	               END IF ! (hydrol_flag3(ji, jv) .eq. .FALSE.)
+	           ENDDO ! jv = 1, nvm
+	        ELSE
+	           ! do nothing
+	        END IF ! (hydrol_flag2(ji) .eq. .TRUE.)        
+	     END IF ! IF (hydrol_flag .eq. .TRUE.)       
+	      
+	     ! end 281013 calculate new series of beta_v3 
+
+             IF (hydrol_flag) THEN
+                ! We aim to calculate a new delta_temp using the new vbeta3
+             ELSE
+                ! in non-hydrol interface case (the first call to the energy budget in the sechiba cycle,
+                !     we can exit this loop straightaway)
+                 EXIT convergence_loop 
+             END IF 
+
+
+             END DO convergence_loop
+             ! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$  end convergence loop here  $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+	
+	      flux_ground_h = - (xi_1 + (xi_2 * temp_surf_next))
+	
+	      flux_ground_le = - (xi_3 + (xi_4 * temp_surf_next))	
+	
+	      ! work up the column for atmospheric temperature and humidity, and 
+	      !    vegetation temperature 
+	
+	      t_l_next(1) = big_e(1) * (flux_ground_le) + big_f(1) * (flux_ground_h) + big_g(1)
+	
+	      t_a_next(1) = (a_t(1) * (flux_ground_h)) + b_t(1) + &
+	                   & (c_t(1) * t_l_next(1)) + (d_t(1) * (flux_ground_le)) 
+	
+	      q_a_next(1) = (a_q(1) * (flux_ground_le)) + b_q(1) + &
+	                   & (c_q(1) * t_l_next(1)) + (d_q(1) * (flux_ground_h)) 
+	
+	      DO i = 2, jnlvls
+	          t_l_next(i) = (big_e(i) * q_a_next(i-1)) + &
+	                       & (big_f(i) * t_a_next(i-1)) + big_g(i)
+	
+	          t_a_next(i) = (a_t(i) * t_a_next(i-1)) + b_t(i) + &
+	                       & (c_t(i) * t_l_next(i)) + (d_t(i) * q_a_next(i-1))
+	
+	          q_a_next(i) = (a_q(i) * q_a_next(i-1)) + b_q(i) + &
+	                       & (c_q(i) * t_l_next(i)) + (d_q(i) * t_a_next(i-1))
+	      END DO ! i = 1, jnlvls
+
+
+	      t_a_next_grid(ji, :) = t_a_next(:)
+
+	      q_a_next_grid(ji, :) = q_a_next(:)
+	
+	      temp_leaf_next_grid(ji, :) = t_l_next(:)
+	
+	      ! the lowest level flux is always the flux from the ground
+	      ! n.b. sign convention: positive flux is the flow of heat from high temperature to low
+	      !   temperature or from high humidity to low humidity respectably
+	
+	      flux_h(1) = flux_ground_h
+	      flux_le(1) = flux_ground_le
+	
+	      DO i = 2, jnlvls
+	          flux_h(i) = - cp_air * rau(ji) * &
+	                      & (t_a_next(i) - t_a_next(i-1)) * k_eddy(i-1)/delta_z(i-1)
+	          flux_le(i) = - chalev0 * rau(ji) * &
+	                      & (q_a_next(i) - q_a_next(i-1)) * k_eddy(i-1)/delta_z(i-1)
+	      END DO ! i = 2, jnlvls
+	
+	      flux_h_grid(ji, :) = flux_h(:)
+	      flux_le_grid(ji, :) = flux_le(:)
+	
+	      fluxsens(ji) = flux_h(jnlvls)
+	      fluxlat(ji) = flux_le(jnlvls)  
+              !+++++++++++++++++++++++++++++++++++++++++
+              !- Added by YC 03202014
+               netrad(ji) = eta_1_surf*lwdown(ji) + eta_4_surf*swnet(ji) + &
+  	                 & (eta_2_surf * temp_surf_next) - eta_3_surf + (temp_surf_next - (psold(ji)/cp_air)) / (dtradia/soilcap(ji))
+              !+++++++++++++++++++++++++++++++++++++++++
+	      IF (james_write) THEN
+	
+		
+	           WRITE(numout,*) '081013 balance test delta temp: ', temp_surf_next - (psold(ji)/cp_air)
+			  
+	           WRITE(numout,*) '081013 balance test fluxes sum: ', (-flux_h(1) - flux_le(1) + &
+	      		  & eta_1_surf*lwdown(ji) + eta_4_surf*swnet(ji) + eta_3_surf + soilflx(ji)   &
+	              & + eta_2_surf * temp_surf_next) &
+		          & * (dtradia/soilcap(ji))
+			  
+	           WRITE(numout,*) '081013 balance test delta temp / (dtradia/soilcap(ji): ', &
+			      & (temp_surf_next - (psold(ji)/cp_air)) / (dtradia/soilcap(ji))
+			  
+     		   WRITE(numout,*) '081013 balance test fluxes sum: ', -flux_h(1) - flux_le(1) + &
+			      & eta_1_surf*lwdown(ji) + eta_4_surf*swnet(ji) + soilflx(ji)   &
+			      & + (eta_2_surf * temp_surf_next) - eta_3_surf
+			
+	           WRITE(numout,*) '141013 total balance test: ', &
+			      & (temp_surf_next - (psold(ji)/cp_air)) / (dtradia/soilcap(ji)) - &
+	              & (-flux_h(1) - flux_le(1) + &
+			      & eta_1_surf*lwdown(ji) + eta_4_surf*swnet(ji) + soilflx(ji)   &
+	              & + (eta_2_surf * temp_surf_next) - eta_3_surf)
+			
+                   WRITE(numout,*) '081013 balance test flux_h(1): ', flux_h(1)
+	           WRITE(numout,*) '081013 balance test flux_le(1): ', flux_le(1)
+                   WRITE(numout,*) '081013 balance test eta_1_surf*lwdown(ji): ', eta_1_surf*lwdown(ji)
+                   WRITE(numout,*) '081013 balance test eta_2_surf * temp_surf_next: ', eta_2_surf * temp_surf_next
+                   WRITE(numout,*) '081013 balance test eta_3_surf: ', eta_3_surf
+                   WRITE(numout,*) '081013 balance test eta_4_surf*swnet(ji): ', eta_4_surf*swnet(ji)
+	           WRITE(numout,*) '081013 balance test soilflx(ji): ', soilflx(ji)
+		
+	       ! %%%% JR 260813 write out delta_temp_leaf and sum_flux_leaf series %%%%%%
+               ! %%%% this is to verify that energy is conserved %%%%%%
+		
+
+		
+		
+		   DO i = 1, jnlvls
+		       source_sink_t(i) = cp_air * rau(ji) * &
+		                        & ((t_a_next(i) - t_a_pres(i)) * delta_h(i)) / dtradia
+		       source_sink_q(i) = chalev0 * rau(ji) * &
+		                        & ((q_a_next(i) - q_a_pres(i)) * delta_h(i)) / dtradia
+		
+		       source_sink_t_l(i) = ((t_l_next(i) - t_l_pres(i)) * delta_h(i)) / dtradia
+		
+		       horiz_flux_t(i) = (t_l_next(i) - t_a_next(i))/big_r(i) * cp_air * rau(ji) 
+		       horiz_flux_q(i) = (((jalpha(i) * t_l_next(i) + jbeta(i)) - q_a_next(i))/ &
+		                        & big_r_prime(i)) * chalev0 * rau(ji) 
+		   END DO ! i = 1, jnlvls
+		
+		
+		   delta_t_a(1) = cp_air * rau(ji) * ((t_a_next(1) - t_a_pres(1)) &
+		                   & * delta_h(1)) / dtradia
+		   sum_flux_a(1) = - flux_h(1+1) + ( flux_h(1) + horiz_flux_t(1) )
+		
+		   delta_q_a(1) = chalev0 * rau(ji) * &
+		                   & ((q_a_next(1) - q_a_pres(1)) * delta_h(1)) / &
+		                   & dtradia
+		   sum_flux_q_a(1) = - flux_le(1+1) + ( flux_le(1) + horiz_flux_q(1) )
+		
+		    
+		   DO i = 2, jnlvls-1
+		        delta_t_a(i) = cp_air * rau(ji) * ((t_a_next(i) - t_a_pres(i)) &
+		                        & * delta_h(i)) / dtradia
+		        sum_flux_a(i) = - flux_h(i+1) + ( flux_h(i) + horiz_flux_t(i) )
+		   END DO ! i = 1, jnlvls-1
+		
+		   DO i = 2, jnlvls-1
+		        delta_q_a(i) = chalev0 * rau(ji) * &
+		                       & ((q_a_next(i) - q_a_pres(i)) * delta_h(i)) / &
+		                       & dtradia
+		        sum_flux_q_a(i) = - flux_le(i+1) + ( flux_le(i) + horiz_flux_q(i) )
+		   END DO ! i = 1, jnlvls-1
+		
+		
+		   DO i = 1, jnlvls-1
+		         delta_temp_leaf(i) = rho_veg*leaf_tks * pad_deltah(i) * jtheta(i) * &
+		                               & ((t_l_next(i) - t_l_pres(i)) * delta_h(i)) / &
+		                               & dtradia
+		         sum_flux_leaf(i) = (eta_1(i) * lwdown(ji)) + (eta_2(i)*t_l_next(i)) + &
+		                               & eta_3(i) + (eta_4(i) * swnet(ji)) - &
+		                               & ( horiz_flux_t(i) + horiz_flux_q(i))
+		   END DO ! i = 1, jnlvls-1
+		
+		   DO i = 1, jnlvls-1
+		          IF (ABS(source_sink_t(i) - sum_flux_a(i)) .gt. 1.0d-5) THEN
+		                  WRITE(numout,*) 'level: ', i, ' does not balance at atmos temperature'
+		          ELSE
+		                  ! do nothing
+		          END IF
+		
+		          IF (ABS(source_sink_q(i) - sum_flux_q_a(i)) .gt. 1.0d-5) THEN
+		                  WRITE(numout,*) 'level: ', i, ' does not balance at atmos specific humidity'
+		          ELSE
+		                  ! do nothing
+		          END IF
+		
+		          IF (ABS(delta_temp_leaf(i) - sum_flux_leaf(i)) .gt. 1.0d-5) THEN
+		                  WRITE(numout,*) 'level: ', i, ' does not balance at leaf temperature'
+		          ELSE
+		                  ! do nothing
+		          END IF
+		          
+		    END DO ! i = 1, jnlvls-1
+		
+		
+		    DO i = 1, jnlvls-1
+		          source_sink_sum_t = (source_sink_sum_t + source_sink_t(i) + horiz_flux_t(i))
+		          source_sink_sum_q = (source_sink_sum_q + source_sink_q(i) + horiz_flux_q(i))
+		    END DO ! i = 1, jnlvls-1
+
+          END IF !(james_write) 
+
+
+    END DO gridloop ! ji=1,kjpindex  ! ------------------------------------------------------------
+ 
+
+ END SUBROUTINE jcalc
+
+
+ ! -------------------------------------------------------------------------------------------------
+
+ !!  ===========================================================================================================================
+ !! SUBROUTINE		 		    : calc_jalpha_and_jbeta 
+ !!
+ !!
+ !>\BRIEF				    : calculates the rate of change of saturated surface humidity of the leaf surface 
+ !!
+ !! DESCRIPTION			   	    : 
+ !! 
+ !!
+ !! RECENT CHANGE(S): None
+ !!
+ !! MAIN OUTPUT VARIABLE(S)	: jalpha, jbeta, jalpha_surf, jbeta_surf, q_sat_surf, temp_surf_pres
+ !!
+ !! REFERENCE(S)		: Monteith & Unsworth (2008 edition)
+ !!
+ !! FLOWCHART			: 
+ !_ ==============================================================================================================================
+
+
+ SUBROUTINE calc_jalpha_and_jbeta (temp_atmos_pres_grid, temp_leaf_pres_grid, jalpha, jbeta, &
+               & jalpha_surf, jbeta_surf, temp_surf_pres, q_sat_surf, kjpindex, &
+               & pb, temp_sol, james_write, jpdqsold)
+
+    ! we use the approach outlined in Monteith & Unsworth (2008 edition)
+
+    IMPLICIT NONE
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                               :: kjpindex                       !! Domain size (-)
+    REAL(r_std), DIMENSION (kjpindex), INTENT (in)           :: pb                             !! Lowest level pressure (hPa)
+    REAL(r_std), DIMENSION (kjpindex, jnlvls), INTENT (in)   :: temp_atmos_pres_grid           ! atmospheric temperature down the column (K)
+    REAL(r_std), DIMENSION (kjpindex, jnlvls), INTENT (in)   :: temp_leaf_pres_grid            ! leaf temperature down the column (K)
+
+    LOGICAL, INTENT(in)                                      :: james_write                    !! Flag for turning all of the verbose write statements on and off
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: temp_sol                       !! Soil temperature (K)
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION (jnlvls), INTENT (out)            :: jalpha, jbeta
+    REAL(r_std), DIMENSION (kjpindex), INTENT (out)          :: jalpha_surf, jbeta_surf
+    REAL(r_std), DIMENSION (kjpindex), INTENT (out)          :: q_sat_surf
+
+
+    !! 0.3 Modified variables
+    REAL(r_std), INTENT (inout)                              :: temp_surf_pres                 ! surface temperature at PRESENT time step (Kelvins)
+
+    !! 0.4 Local variables
+
+    REAL(r_std), DIMENSION (jnlvls)                          :: temp_atmos                     ! atmospheric temperature down the column (K)
+    REAL(r_std), DIMENSION (jnlvls)                          :: temp_leaf                      ! leaf temperature down the column (K)
+
+    INTEGER(i_std)                                :: ji                           ! grid point loop
+    INTEGER(i_std)                                :: i                           ! levels loop
+
+    REAL(r_std)                                   :: lambda_const = 2480.0d0        ! (J g^-1) at 10degC n.b. this changes by 2.4 per degree
+    REAL(r_std)                                   :: bigm_w = 18.0d0                ! (g mol^-1) approximate molar mass of water
+    REAL(r_std)                                   :: bigr_const = 8.314d0           ! (J mol^-1 K^-1) the molar gas constant
+    REAL(r_std)                                   :: eta_const = 0.622d0            ! ratio of molecular mass of water to molecular mass of air
+    REAL(r_std)                                   :: biga_const = 17.27d0
+    REAL(r_std)                                   :: tstar_const = 273.0d0          ! (Kelvins)
+    REAL(r_std)                                   :: tprime_const = 36.0d0          ! (Kelvins)
+    REAL(r_std)                                   :: e_sat_tstar = 0.611d0          ! (kPa)
+    REAL(r_std)                                   :: zrapp,zcorr,ztemperature,zqsat !! Temporary vector variables      
+    REAL(r_std), DIMENSION (jnlvls)               :: q_sat                          ! (kg/kg)
+    REAL(r_std), DIMENSION (jnlvls)               :: big_delta                      ! delta q_sat / delta temp at leaf temperature
+    REAL(r_std), DIMENSION (jnlvls)               :: leaf_qsol_sat                    !! Soil temperature (K)
+    REAL(r_std), DIMENSION (jnlvls)               :: leaf_dev_qsol                    !! Soil temperature (K)
+    REAL(r_std), DIMENSION (jnlvls)               :: leaf_pdqsold                     !! Soil temperature (K)
+    REAL(r_std), DIMENSION (kjpindex)             :: big_delta_surf
+    REAL(r_std), DIMENSION (kjpindex)             :: j_qsol_sat, j_dev_qsol
+    REAL(r_std), DIMENSION (kjpindex)             :: jpdqsold
+    REAL(r_std), DIMENSION (kjpindex)             :: j_dev_q, j_q_sat
+
+
+!   =from qsat_moisture=================================================================================================
+
+    !! 1. Initialisation
+    zrapp = msmlr_h2o/msmlr_air
+    zcorr = 0.00320991_r_std
+
+    jalpha(:) = 0.0d0
+    jbeta(:) = 0.0d0
+    jalpha_surf(:) = 0.0d0 
+    jbeta_surf(:) = 0.0d0
+
+    q_sat(:) = 0.0d0
+    big_delta(:) = 0.0d0
+    leaf_qsol_sat(:) = 0.0d0
+    leaf_dev_qsol(:) = 0.0d0
+    leaf_pdqsold(:) = 0.0d0
+    big_delta_surf(:) = 0.0d0 
+    j_qsol_sat(:) = 0.0d0
+    j_dev_qsol(:) = 0.0d0
+    jpdqsold(:) = 0.0d0
+
+    DO ji = 1, kjpindex
+      
+       !! 2. Computes saturated humidity one time and store in qsfrict local array
+         
+       ztemperature = temp_sol(ji)
+ 
+       j_qsol_sat(:) = 0.0d0
+       j_dev_qsol(:) = 0.0d0
+
+
+       ! WRITE(*,*) '181113a test, pre call to qsatcalc enerbil line 4790; temp_sol is: ', temp_sol
+
+       ! CALL qsatcalc (kjpindex, temp_sol, pb, qsol_sat) jtest4
+       CALL qsatcalc (kjpindex, temp_sol, pb, j_qsol_sat)
+
+       !   CALL dev_qsatcalc (kjpindex, temp_sol, pb, dev_qsol) jtest3
+       CALL dev_qsatcalc (kjpindex, temp_sol, pb, j_dev_qsol)
+
+       temp_surf_pres = temp_sol(ji)
+
+       ! WRITE(numout,*) '100114 after qsatcalc and dev_qsatcalc, temp_surf_pres is: ', temp_surf_pres
+
+       !+++ According to r2093 in the trunk, the line below is modified to avoid possible instability in the coupling.
+
+       ! jpdqsold(ji) = j_dev_qsol(ji) * ( pb(ji)**kappa ) / cp_air
+
+       jpdqsold(ji) = j_dev_qsol(ji)
+
+       q_sat(:) = 0.0d0
+       big_delta(:) = 0.0d0
+
+       ! calculate jalpha_surf and jbeta_surf first of all:
+
+       ! Using Tetens' method for close approximation of saturated specific humidity 
+       !   (e.g. 2.27 of Monteith & Unsworth (2008)) and the specific humidity approximation 
+       !   in terms of vapour pressure (e.g. 2.32 of Monteith & Unsworth (2008))
+        
+      ! WRITE(numout,*) 'temp_surf_pres, pixel', temp_surf_pres, ji
+       q_sat_surf(ji) = (eta_const / 100000.0d0)  * (e_sat_tstar*1000.0d0) *  &
+          & EXP((biga_const*(temp_surf_pres - tstar_const)/(temp_surf_pres - tprime_const)))
+
+ 
+       big_delta_surf(ji) = ( lambda_const * bigm_w * q_sat_surf(ji) ) / &
+                      & ( bigr_const * (temp_surf_pres)**2 )
+
+       IF (james_write) THEN
+           !WRITE(numout,*) 'in calc_jalpha_jbeta, big_delta_surf is: ', big_delta_surf(ji)    
+       END IF !(james_write)
+
+       ! jalpha_surf(ji) = j_dev_qsol(ji)
+       jalpha_surf(ji) = jpdqsold(ji)
+       jbeta_surf(ji) = j_qsol_sat(ji) - temp_sol(ji) * jpdqsold(ji)
+       q_sat_surf(ji) = j_qsol_sat(ji)
+
+       IF (jnlvls .gt. 1) THEN
+
+           DO i=1, jnlvls
+
+               temp_atmos(i) = temp_atmos_pres_grid(ji,i)
+               temp_leaf(i) = temp_leaf_pres_grid(ji,i)
+
+               ! Using Tetens' method for close approximation of saturated specific humidity 
+               !   (see 2.27 of Monteith & Unsworth (2008)) and the specific humidity 
+               !   approximation in terms of vapour pressure (see 2.32 of Monteith & Unsworth (2008))
+        
+               q_sat(i) = (eta_const / 100000.0d0)  * (e_sat_tstar*1000.0d0) *  &
+                   & EXP((biga_const*(temp_leaf(i) - tstar_const)/(temp_leaf(i) - tprime_const)))
+
+               big_delta(i) = ( lambda_const * bigm_w * q_sat(i) ) / &
+                   & ( bigr_const * temp_leaf(i)**2 )
+
+               jalpha(i) = big_delta(i) 
+               jbeta(i) = q_sat(i) - (temp_leaf(i) * jalpha(i))
+
+
+               ! CALL qsatcalc (kjpindex, temp_sol, pb, qsol_sat) jtest4
+               CALL qsatcalc (kjpindex, temp_leaf_pres_grid(:,i), pb, j_q_sat)
+
+               !   CALL dev_qsatcalc (kjpindex, temp_sol, pb, dev_qsol) jtest3
+               CALL dev_qsatcalc (kjpindex, temp_leaf_pres_grid(:,i), pb, j_dev_q)
+
+               jalpha(i) = j_dev_q(ji) * ( pb(ji)**kappa ) / cp_air
+           
+               jbeta(i) = j_q_sat(ji) - temp_leaf(i) * j_dev_q(ji) * ( pb(ji)**kappa ) / cp_air
+
+           END DO !i = 1, jnlvls
+
+       END IF ! IF (jnlvls .gt. 1)
+
+
+
+    END DO ! ji = 1, kjpindex
+
+
+ END SUBROUTINE calc_jalpha_and_jbeta 
+
+
+ ! -------------------------------------------------------------------------------------------------
+
+ !!  ===========================================================================================================================
+ !! SUBROUTINE		 		    : jprofile
+ !!
+ !!
+ !>\BRIEF				    : calculates the rate of change of saturated surface humidity of the leaf surface 
+ !!
+ !! DESCRIPTION			   	    : This routine will allocate a LAD to each level of the canopy using the approach 
+ !!                                           of Yang et al. (1999) and the parameters they allocate to an aspen stand (if not 
+ !!                                           already known through read-in data). Based on this LAD profile, canopy turbulence 
+ !!                                           statistics will be allocated using the method of Massman & Weil (1999).
+ !! 
+ !!
+ !! RECENT CHANGE(S): None
+ !!
+ !! MAIN OUTPUT VARIABLE(S)	: jalpha, jbeta, jalpha_surf, jbeta_surf, q_sat_surf, temp_surf_pres
+ !!
+ !! REFERENCE(S)		: Massman, W.J. & Weil, J.C., 1999. An analytical one-dimensional second-order 
+ !!                               closure model of turbulence statistics and the lagrangian time scale within and 
+ !!                               above plant canopies of arbitrary structure. Boundary-Layer Meteorology, 91, 
+ !!                               pp.81â107.
+ !!
+ !!                               Raupach, M.R., Antonia R.A. and Rajagpalan, S., 1991. 'Rough-wall turbulent 
+ !!                               boundary layers', Applied Mechanics Review, 44, pp. 1-25
+ !!
+ !!                               Yang, X., Witcosky, J.J. & Miller, D.R., 1999. Vertical overstory canopy 
+ !!                               architecture of temperate deciduous in the Eastern United States. Forest Science, 
+ !!                               45(3), pp.349â358.
+ !!
+ !! FLOWCHART			: 
+ !_ ==============================================================================================================================
+
+
+ SUBROUTINE jprofile (pad_deltah, cum_pad_deltah, layer_height, ustar_ac, delta_z, &
+                      & delta_h, box_height, k_eddy, delta_h_surf, delta_z_surf, &
+                      & box_height_surf, u_star, speed, u_speed, big_pad, &
+                      & k_eddy_fac, k_eddy_surf, surf_lev, top_lev)
+
+    IMPLICIT NONE
+
+
+
+
+
+    !! 0 Variable and parameter description
+
+
+
+    !! 0.1 Input variables
+    REAL(r_std), DIMENSION (0:jnlvls), INTENT(in)    :: pad_deltah             ! Plant Area Density as a function of height above the ground (m^2/m^3)
+
+    REAL(r_std), DIMENSION(jnlvls+1), INTENT(in)     :: box_height             ! height of each box edge, starting at the surface layer (m)
+    REAL(r_std), INTENT(in)                          :: box_height_surf        ! height of bottom of surface layer box (m)
+    REAL(r_std), INTENT(in)                          :: surf_lev
+    REAL(r_std), DIMENSION(jnlvls+1), INTENT(in)     :: top_lev
+    REAL(r_std), INTENT(in)                          :: k_eddy_fac
+   
+
+    !! 0.2 Output variables
+    REAL(r_std), INTENT(out)                         :: u_star                 ! friction velocity (m/s)
+    REAL(r_std), INTENT(out)                         :: layer_height           ! the height of each layer in the canopy (assumed equal for now) (m)
+    REAL(r_std), DIMENSION (jnlvls), INTENT(out)     :: cum_pad_deltah         ! Cumulative Plant Area Density multiplied by layer height (m^2/m^3)
+    REAL(r_std), DIMENSION (jnlvls), INTENT(out)     :: delta_z                ! change in height (m)
+    REAL(r_std), DIMENSION (jnlvls), INTENT(out)     :: u_speed                ! vertical wind speed (m/s)
+    REAL(r_std), DIMENSION (jnlvls), INTENT(out)     :: big_pad 
+    REAL(r_std), DIMENSION (jnlvls), INTENT(out)     :: k_eddy                ! calculated eddy diffusivity coefficient (m^2/s)
+    REAL(r_std), DIMENSION(jnlvls), INTENT(out)      :: delta_h                ! height of each level (m)
+
+
+    !! 0.3 Modified variables
+
+
+
+    !! 0.4 Local variables
+    REAL(r_std)                                       :: speed
+    REAL(r_std)                                       :: param_b=0.426d0
+    REAL(r_std)                                       :: param_c=1.856d0
+    REAL(r_std)                                       :: c_d=0.2d0
+    REAL(r_std)                                       :: p_m=1.0d0
+    REAL(r_std)                                       :: jlambda
+    REAL(r_std)                                       :: jalpha=0.05d0
+    REAL(r_std)                                       :: small_n
+    INTEGER(i_std)                                    :: i
+    INTEGER(i_std)                                    :: j, k, m, n
+    REAL(r_std)                                       :: c_1, c_2, c_3          ! coefficients as defined in Massman & Weil (1999) p. 83
+    REAL(r_std), DIMENSION (jnlvls+1)                 :: jepsilon               ! epsilon coefficient as in Massman & Weil (1999), 
+                                                                                !   equation (6) and just after
+    REAL(r_std), DIMENSION (jnlvls)                  :: eta_z                  ! eta coefficient as in Massman & Weil (1999), equation (3)
+    REAL(r_std), DIMENSION (jnlvls)                  :: sigma_exp_1
+    REAL(r_std), DIMENSION (jnlvls)                  :: sigma_exp_2
+    REAL(r_std), DIMENSION (jnlvls)                  :: sigma_exp_3
+    REAL(r_std), DIMENSION (jnlvls)                  :: sigma_e_over_u_star    ! sigma_e normalised by u_star (-)
+    REAL(r_std), DIMENSION (jnlvls)                  :: sigma_u_over_u_star    ! sigma_u normalised by u_star (-)
+    REAL(r_std), DIMENSION (jnlvls)                  :: sigma_v_over_u_star    ! sigma_v normalised by u_star (-)
+    REAL(r_std), DIMENSION (jnlvls)                  :: sigma_w_over_u_star    ! sigma_w normalised by u_star (-)
+    REAL(r_std), DIMENSION (jnlvls)                  :: sigma_u                ! standard deviation in u-stream (horizontal) velocity (m/s); Massman & Weil eqn. (11)
+    REAL(r_std), DIMENSION (jnlvls)                  :: sigma_v                ! standard deviation in v-stream (horizontal) velocity (m/s); Massman & Weil eqn. (11)
+    REAL(r_std), DIMENSION (jnlvls)                  :: sigma_w                ! standard deviation in w-stream (vertical) velocity (m/s); Massman & Weil eqn. (11)
+
+    REAL(r_std), DIMENSION (timesteps)                :: ustar_ac               ! ?? not used ?? Friction velocity (m/s)
+    REAL(r_std)                                       :: delta_h_surf           ! ?? not used ?? height of surface level (m)
+    REAL(r_std)                                       :: delta_z_surf           ! ?? not used ?? vertical difference between the middle of the surface layer
+                                                                                             !     and the middle of the first layer (m)
+    REAL(r_std)                                       :: k_eddy_surf            ! ?? not used ?? 
+
+    REAL(r_std)                                       :: gamma_1=2.4d0
+    REAL(r_std)                                       :: gamma_2=1.9d0
+    REAL(r_std)                                       :: gamma_3=1.25d0
+    REAL(r_std)                                       :: nu_1, nu_2, nu_3
+    REAL(r_std)                                       :: bigb1
+    REAL(r_std)                                       :: rp_a_1 = 1.25d0        ! Raupach et al. (1991) co-efficients
+    REAL(r_std)                                       :: rp_a_0 = 0.25d0        ! Raupach et al. (1991) co-efficients
+    REAL(r_std)                                       :: rp_c_0 = 0.3d0         ! Raupach et al. (1991) co-efficients 
+    REAL(r_std), DIMENSION (0:jnlvls)                 :: gu_l
+    REAL(r_std)                                       :: gu_ext = 0.7d0
+    REAL(r_std), DIMENSION (jnlvls)                   :: middle_layer_height    ! the height in the middle of each layer in the canopy (m)
+    REAL(r_std), DIMENSION (jnlvls+1)                 :: z_h                    ! height above ground at the base of each layer (m)
+    REAL(r_std), DIMENSION (jnlvls+1)                 :: jeta
+    REAL(r_std), DIMENSION (jnlvls)                   :: t_lagrangian           ! Lagrangian timescale (s)
+
+
+
+
+    IF (james_write) THEN
+        !WRITE (*,*) '220513 k_eddy_fac is: ', k_eddy_fac
+    END IF ! (james_write)
+
+
+    layer_height = 0.0_r_std
+    middle_layer_height = 0.0_r_std
+    z_h = 0.0_r_std
+    jepsilon = 0.0_r_std
+    cum_pad_deltah = 0.0_r_std
+    small_n = 0.0_r_std
+    bigb1 = 0.0_r_std
+    sigma_exp_1 = 0.0_r_std
+    sigma_exp_2 = 0.0_r_std
+    sigma_exp_3 = 0.0_r_std
+
+    nu_1 = (gamma_1**2.0_r_std+gamma_2**2.0_r_std+gamma_3**2.0_r_std)**(-0.5_r_std)
+    nu_3 = (gamma_1**2.0_r_std+gamma_2**2.0_r_std+gamma_3**2.0_r_std)**(3.0_r_std/2.0_r_std)   
+    nu_2 = nu_3/6.0_r_std-(gamma_3**2.0_r_std/(2.0_r_std*nu_1))
+
+
+
+    DO i=1, jnlvls
+        delta_h(i) = box_height(i+1) - box_height(i)
+    END DO !i=1, jnlvls
+
+    DO i=1, jnlvls-1
+        delta_z(i) = (box_height(i+1) + (delta_h(i+1)/2.0_r_std)) - &
+                         &  (box_height(i) + (delta_h(i)/2.0_r_std))
+    END DO !i=1, jnlvls
+
+    DO i=1, jnlvls+1
+        z_h(i) = box_height(i)
+        jeta(i) = z_h(i) / canopy_height
+        ! this is from Yang et al. (1999), equation 1
+        !++++TEMP++++
+        ! for single layer case without STOMATE
+        !jepsilon(i) = 1.0_r_std - exp ((-1.0_r_std)*(( (1-jeta(i)) /param_b ) ** (param_c)))
+        jepsilon(i) = 1.0_r_std 
+        !+++++++++++++
+    END DO !i=1, jnlvls+1
+
+    DO i=1, jnlvls
+        middle_layer_height(i) = (z_h(i) + z_h(i+1)) / 2.0_r_std
+    END DO !i=1, jnlvls
+
+
+    delta_h(1) = top_lev(1) - surf_lev
+     
+    DO i = 2, jnlvls
+        delta_h(i) = top_lev(i) - top_lev(i-1)
+    END DO ! i = 2, jnlvls 
+
+    DO i = 1, jnlvls-1
+        delta_z(i) = (delta_h(i) + delta_h(i+1))/2.0_r_std
+    END DO ! i = 1, jnlvls-1
+
+
+    ! coefficients c_1, c_2 and c_3 as defined in Massman & Weil (1999) p. 83
+
+    c_1 = 0.320_r_std
+    c_2 = 0.264_r_std
+    c_3 = 15.1_r_std
+
+    cum_pad_deltah(jnlvls) = pad_deltah(jnlvls)
+
+    DO i=jnlvls-1, 1, -1
+        cum_pad_deltah(i) = cum_pad_deltah(i+1) + pad_deltah(i)
+    END DO !i=1, jnlvls
+
+
+    DO i=1, jnlvls
+        big_pad(i) = pad_deltah(i) / delta_h(i)
+    END DO ! i=1, jnlvls
+
+
+
+    eta_z(1) = (( c_d * pad_deltah(1) ) / p_m )
+    DO i=2, jnlvls
+        eta_z(i) = (( c_d * pad_deltah(i) ) / p_m ) + eta_z(i-1)
+    END DO !i=1, jnlvls
+
+    u_star = speed * (c_1 - c_2 * exp (- c_3 * eta_z(jnlvls) ) )
+
+
+    jlambda = SQRT( 7.0_r_std / (3.0_r_std * jalpha**2.0_r_std * nu_1 * nu_3 ) + & 
+                      & (1.0_r_std / 3.0_r_std - (gamma_3**2.0_r_std * nu_1**2.0_r_std ))/  &
+                      & (3.0_r_std * jalpha**2.0_r_std * nu_1 * nu_2))
+
+    small_n = eta_z(jnlvls)/((2.0_r_std*(u_star**2.0_r_std))/(speed**2.0_r_std))
+
+
+    bigb1 = -(9.0_r_std* u_star / speed)/(2.0_r_std* jalpha * nu_1 * & 
+               & (9.0_r_std/4.0_r_std - ((jlambda**2.0_r_std*u_star**4.0_r_std)/speed**4.0_r_std)))
+
+
+
+    DO i=1, jnlvls
+        sigma_exp_1(i) = -jlambda * eta_z(jnlvls) * ( 1.0_r_std - eta_z(i) / eta_z(jnlvls))
+        sigma_exp_2(i) = -3.0_r_std * small_n * ( 1.0_r_std - ( eta_z(i) / eta_z(jnlvls)))
+        sigma_exp_3(i) = -jlambda * eta_z(jnlvls) * (1.0_r_std - eta_z(i) / eta_z(jnlvls))
+        sigma_e_over_u_star(i) = ( nu_3 * &
+                             & EXP (sigma_exp_1(i)) + bigb1 *( EXP( sigma_exp_2(i)) - &
+                             & EXP( sigma_exp_3(i))))**(1.0_r_std/3.0_r_std)
+        sigma_u_over_u_star(i) = gamma_1 * nu_1 * sigma_e_over_u_star(i)
+        sigma_v_over_u_star(i) = gamma_2 * nu_1 * sigma_e_over_u_star(i)
+        sigma_w_over_u_star(i) = gamma_3 * nu_1 * sigma_e_over_u_star(i)
+        sigma_u(i) = sigma_u_over_u_star(i) * u_star
+        sigma_v(i) = sigma_v_over_u_star(i) * u_star
+        sigma_w(i) = sigma_w_over_u_star(i) * u_star
+        u_speed(i) = speed * exp (-small_n * (1-(eta_z(i)/eta_z(jnlvls))))
+    END DO !i=1, jnlvls
+
+
+
+    IF (jnlvls .eq. 1) THEN
+        u_speed(1) = speed
+    END IF
+
+    ! approximate the Lagrangian timescale using the parameterisation of Raupach (1989)
+    ! where 0.4_r_std is the von Karmen constant
+
+    DO i=1, jnlvls
+        t_lagrangian(i) = (canopy_height/u_star) *                                      &
+                       &    (max (rp_c_0, 0.4_r_std * ( z_h(i) - (0.63_r_std*canopy_height) )   &
+                       &     / (rp_a_1 * canopy_height)))
+    END DO !i=1, jnlvls
+
+    ! this is the eddy diffusivity approximation for the far-field (also Raupach, 1989)
+
+    DO i=1, jnlvls
+
+        k_eddy(i) = (sigma_w(i))**2 * t_lagrangian(i)
+
+    END DO !i=1, jnlvls
+
+
+ 
+    k_eddy = k_eddy * k_eddy_fac
+    
+
+ END SUBROUTINE jprofile
+
+    
+ !!  ===========================================================================================================================
+ !! SUBROUTINE		 		    : calc_stomatal_resistance
+ !!
+ !!
+ !>\BRIEF				    : 
+ !!
+ !! DESCRIPTION			   	    : 
+ !! 
+ !!
+ !! RECENT CHANGE(S): None
+ !!
+ !! MAIN OUTPUT VARIABLE(S)	:     down_sw_tab, down_lw_tab, big_r_prime
+ !!
+ !! REFERENCE(S)		:     Gao, W., Wesely, M.L. & Doskey, P.V., 1993. Numerical modeling of the turbulent 
+ !!                                   diffusion and chemistry of NOx, O3, Isoprene, and other reactive trace gases in 
+ !!                                   and above a forest canopy. Journal of Geophysical Research, 98(D10), pp.18339â18353
+ !!
+ !!                                   Guimberteau, M., 2010. ModÃ©lisation de lâhydrologie continentale et influences de 
+ !!                                   l'irrigation sur le cycle de l'eau.
+ !!
+ !!                                   Monteith J., Unsworth M., 2008. Principles of environmental physics. Published 
+ !!                                   Academic Press (Elsevier), ISBN: 978-0-12-505103-3
+ !!
+ !! FLOWCHART			: 
+ !_ ==============================================================================================================================
+
+
+ ! -------------------------------------------------------------------------------------------------
+
+ SUBROUTINE calc_stomatal_resistance (pad_deltah, swnet, lwdown, pb, &
+                      & down_sw_tab, down_lw_tab, big_r_prime, temp_atmos_pres_grid, &
+                      & q_atmos_pres_grid, big_r, u_speed, r_sto_v_fac, big_r_h2o_fac, &
+                      & rau, kjpindex, sr_fac, hd_big_r_prime)
+
+
+
+
+    IMPLICIT NONE
+    
+
+    !! 0.1 Input variables
+    INTEGER(i_std), INTENT(in)                                   :: kjpindex         !! Domain size (-)
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)                :: rau              !! Air density (kg m^{-3})
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)                 :: swnet            !! Net surface short-wave flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)                 :: lwdown           !! Down-welling long-wave flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)                 :: pb               !! Lowest level pressure (hPa)
+    REAL(r_std), DIMENSION (0:jnlvls), INTENT(in)                :: pad_deltah       !! Plant Area Density multiplied by layer height
+    REAL(r_std), DIMENSION (kjpindex, jnlvls), INTENT(in)        :: temp_atmos_pres_grid
+    REAL(r_std), DIMENSION (kjpindex, jnlvls), INTENT(in)        :: q_atmos_pres_grid
+    REAL(r_std), DIMENSION(jnlvls), INTENT(in)                   :: big_r    
+    REAL(r_std), DIMENSION(jnlvls), INTENT(in)                   :: u_speed
+    REAL(r_std), INTENT(in)                                      :: r_sto_v_fac, big_r_h2o_fac    
+    REAL(r_std), INTENT(in)                                      :: sr_fac                  ! parameterisation factor   
+    REAL(r_std), INTENT(in)                                      :: hd_big_r_prime          ! parameterisation factor
+
+
+    !! 0.2 Output variables
+    REAL(r_std), DIMENSION (jnlvls), INTENT (out)                :: down_sw_tab, down_lw_tab
+    REAL(r_std), DIMENSION (jnlvls), INTENT(out)                 :: big_r_prime
+
+
+
+    !! 0.3 Modified variables
+
+
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                     :: i, j, jk             !! loop counters
+    
+    REAL(r_std), DIMENSION (jnlvls)                    :: temp_atmos_pres    
+    REAL(r_std), DIMENSION (jnlvls)                    :: q_atmos_pres    
+    ! constants from Tetens' expression for saturated vapor pressure (see Monteith &
+    !   Unsworth 2.1)  bigA (-), tstar (K), tprime(K)
+    REAL(r_std)                                        :: biga_const = 17.27_r_std
+    REAL(r_std)                                        :: tstar_const = 273.0_r_std
+    REAL(r_std)                                        :: tprime_const = 36.0_r_std 
+    REAL(r_std)                                        :: e_sat_tstar = 0.611_r_std  !vapor pressure at T* (kPa)
+    !! laitab is the accumulated LAI from the top of the canopy (see Gao et al., 1993)
+    REAL(r_std), DIMENSION (jnlvls)                    :: laitab
+    !! extinction coefficient used is that from from src_parameters of 0.5_r_std for all PFTs               
+    REAL(r_std)                                        :: ext_coef_sw = 0.5_r_std
+    REAL(r_std)                                        :: ext_coef_lw = 0.8_r_std
+    ! this is the assumed minimum average stomatal resistance (s/m)
+    REAL(r_std)                                        :: k_0 = 25.0d-2
+    ! PFT dependent number that is characterised by vegetation (value for PFT8, 
+    !   from Guimberteau, Table 2.2) (-)
+    REAL(r_std)                                        :: bigr_0 = 125.0_r_std ! solar radiation constant (Wm^-2)
+    REAL(r_std)                                        :: lambda = 1.5d-3
+    ! coefficient for the increase of stomatal closure under hydrological deficit 
+    !   (m^2 s kg^(-1))
+    REAL(r_std), DIMENSION (jnlvls)                    :: delta_c
+    ! deficit of water in the atmosphere at the level in question (kg m^-3)
+    REAL(r_std), DIMENSION (jnlvls)                    :: q_sat_ta, r_sto_v
+    REAL(r_std)                                        :: big_l =2.46d6           !(J/kg)
+    REAL(r_std)                                        :: r_b = 30.0_r_std            ! leaf boundary layer resistance
+    ! (see Guimberteau section 4.2)
+    REAL(r_std)                                        :: r_sv = 25.0_r_std           ! structural resistance for PFT8 (s/m) 
+    REAL(r_std)                                        :: r_a = 0.0_r_std             ! aerodynamic resistance represented by the eddy
+    REAL(r_std)                                        :: bigu_sv = 0.8_r_std         ! water uptake function
+    REAL(r_std)                                        :: small_d                 ! characteristic leaf length (m)
+    REAL(r_std), DIMENSION(jnlvls)                     :: bigd_h2o                ! molecular diffusivity of water
+    REAL(r_std), DIMENSION(jnlvls)                     :: nu_air                  ! kinematic viscosity of air
+    REAL(r_std), DIMENSION(jnlvls)                     :: schmidt                 ! schmidt number
+    REAL(r_std), DIMENSION(jnlvls)                     :: sherwood                ! sherwood number
+    REAL(r_std), DIMENSION(jnlvls)                     :: reynolds                ! reynolds number
+    REAL(r_std), DIMENSION(jnlvls)                     :: big_r_h2o               ! h2o leaf boundary layer resistance
+    REAL(r_std)                                        :: smalla = 23.0_r_std        ! this is the assumed minimum average stomatal resistance (s/m)
+
+    r_sto_v=zero
+    big_r_h2o=zero
+
+
+
+    IF (james_write) THEN
+        !WRITE (*,*) '250613 hd_big_r_prime is: ', hd_big_r_prime
+    END IF !(james_write)
+ 
+    DO jk = 1, kjpindex
+
+        temp_atmos_pres(:) = temp_atmos_pres_grid(jk,:)
+        q_atmos_pres(:) = q_atmos_pres_grid(jk,:)
+
+
+	    small_d = 0.05_r_std                            ! set the leaf length to 5cm for now
+	    ! physical dimensions for aspen leaf length: www.ag.ndsu.edu/trees/handbook/th-3-103.pdf
+	
+	    ! n.b. for Eucalyptus delegatensis:
+	    ! http://davisla.wordpress.com/2012/04/07/plant-of-the-week-eucalyptus-delegatensis/
+	    ! 'juvenile leaf being up to 25cm long and 10cm broad the mature 18cm long and 3cm broad'
+	
+	
+	    ! calculate steps of LAI (using the same formulation as in diffuco.f90 for co2)
+	    laitab = 0.0_r_std
+	 
+	    ! calculate light fraction that comes through at a given LAI for each vegetation type
+	    ! laitab(jnlvls) = 0
+	 
+	    IF (jnlvls .eq. 1) THEN
+	        ! omit the layered calculation for single layer case
+	    ELSE
+	
+	        DO i=jnlvls-1, 1, -1
+	     
+	             laitab(i) = pad_deltah(i+1) + laitab(i+1)   
+	        
+	        END DO !i=jnlvls, 1, -1
+	
+	    
+	        DO i=1, jnlvls
+	             down_sw_tab(i) = swnet(1) * exp (-ext_coef_sw * laitab(i))
+	             down_lw_tab(i) = lwdown(1) * exp (-ext_coef_lw * laitab(i))
+	        END DO !i=1, jnlvls
+	
+                IF (james_write) THEN
+	            DO i=1, jnlvls	
+	               !WRITE(numout,*) 'down_sw_tab, level: ', i, ' is: ', down_sw_tab(i)
+	               !WRITE(numout,*) 'down_lw_tab, level: ', i, ' is: ', down_lw_tab(i)
+	            END DO !i=1, jnlvls
+                END IF ! (james_write)	    
+
+	        DO i=1, jnlvls
+	             q_sat_ta(i) = (0.622_r_std/ pb(1))  *e_sat_tstar* 1000.0_r_std * &
+	               & EXP((biga_const*(temp_atmos_pres(i) - tstar_const) / &
+	               & (temp_atmos_pres(i) - tprime_const)))
+	        
+	             delta_c(i) = rau(1) * MAX (q_sat_ta(i) - q_atmos_pres(i), zero) /100.0_r_std
+	        END DO !i=1, jnlvls
+	
+
+	        DO i=1, jnlvls
+                  IF (down_sw_tab(i) .ne. 0.0d0) THEN
+	                  r_sto_v(i) = (smalla/k_0) * (1/pad_deltah(i)) * &
+	                        & ((down_sw_tab(i)+bigr_0)/down_sw_tab(i))  &
+	                        & * (un + lambda * (delta_c(i)/smalla) )
+	              ELSE
+	                  r_sto_v(i) = 1.0d20
+	              END IF
+	        END DO !i=1,jnlvls
+	     
+	        DO i = 1, jnlvls
+	        !     WRITE(numout,*) 'r_sto_v(i) is: ', r_sto_v(i)
+	        END DO
+	         
+	    ! We're using the expression from ORCHIDEE as in Guimberteau (2010)
+	
+	        DO i = 1, jnlvls
+	 
+	           ! n.b. the transition point from laminar to turbulent flow occurs when the 
+	           !   Reynolds number passes 8,000 to 25,000 (Baldochhi, 1988)
+	
+	           bigd_h2o(i) = 2.26d-5 + (1.51d-7 * (temp_atmos_pres(i) - 273.15_r_std))
+	           nu_air(i) = 1.35d-5 + (1.0d-7 * (temp_atmos_pres(i) - 273.15_r_std))
+	           schmidt(i) = nu_air(i) / bigd_h2o(i)
+	
+	           reynolds(i) = (small_d * u_speed(i))/nu_air(i)
+
+	           ! WRITE(numout,*) 'temp_atmos_pres(i) is: ', temp_atmos_pres(i)	
+
+	           ! WRITE(numout,*) 'small_d is: ', small_d	
+	           ! WRITE(numout,*) 'u_speed(i) is: ', u_speed(i)
+	           ! WRITE(numout,*) 'nu_air(i) is: ', nu_air(i)
+	
+	           ! WRITE(numout,*) 'sherwood(i) is: ', sherwood(i)	
+	           ! WRITE(numout,*) 'reynolds(i) is: ', reynolds(i)
+	           ! WRITE(numout,*) 'schmidt(i) is: ', schmidt(i)
+	
+	           ! is the flow laminar or turbulent?
+	           IF (reynolds(i) .le. 8000.0_r_std) THEN
+	               sherwood(i) = 0.66_r_std * (reynolds(i))**(0.5_r_std) + (schmidt(i))**(0.33_r_std)
+	           ELSE IF (reynolds(i) .gt. 8000.0_r_std) THEN
+	               sherwood(i) = 0.03_r_std * (reynolds(i))**(0.8_r_std) + (schmidt(i))**(0.33_r_std)
+	           END IF
+	
+	           big_r_h2o(i) = small_d / (bigd_h2o(i) * sherwood(i))
+	
+	    END DO ! i=1, jnlvls
+	
+	    END IF ! (jnlvls .eq. 1)
+	
+	     big_r_prime = ((r_sto_v * r_sto_v_fac) + (big_r_h2o * big_r_h2o_fac))
+	
+	     big_r_prime = big_r_prime * sr_fac
+	
+	     ! 230613
+	     big_r_prime(:) = hd_big_r_prime
+	
+	     ! big_r_prime(:) = 1.0d20
+	     
+	     big_r_prime(jnlvls) = 1.0d20   ! the top level resistance should be approaching 
+	                                     !   infinity (see diagram) need to implement this 
+	                                     !   more elegantly
+
+     END DO ! jk = 1, kjpindex
+
+    
+ END SUBROUTINE calc_stomatal_resistance
+
+    
+ ! -------------------------------------------------------------------------------------------------
+
+ !!  ===========================================================================================================================
+ !! SUBROUTINE		 		    : calc_boundarylayer_resistance
+ !!
+ !!
+ !>\BRIEF				    : 
+ !!
+ !! DESCRIPTION			   	    : 
+ !! 
+ !!
+ !! RECENT CHANGE(S): None
+ !!
+ !! MAIN OUTPUT VARIABLE(S)	:     down_sw_tab, down_lw_tab, big_r_prime
+ !!
+ !! REFERENCE(S)		:     Baldocchi, D.D., 1988. A multi-layer model for estimating sulfur dioxide deposition 
+ !!                                   to a deciduous oak forest canopy. Atmospheric Environment (1967), 22(5), 
+ !!                                   pp.869â884
+ !!
+ !! FLOWCHART			: 
+ !_ ==============================================================================================================================
+
+
+
+ SUBROUTINE calc_boundarylayer_resistance (big_r, u_speed, temp_atmos_pres_grid, &
+                                            & big_r_heat_fac, kjpindex, &
+                                            & br_fac, hd_big_r)
+  
+
+
+
+    IMPLICIT NONE
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                               :: kjpindex         !! Domain size (-)
+    REAL(r_std), DIMENSION (kjpindex, jnlvls), INTENT(in)    :: temp_atmos_pres_grid ! atmospheric temperature down the column (K) PRESENT STEP
+    REAL(r_std), DIMENSION (jnlvls), INTENT(in)              :: u_speed
+    REAL(r_std), INTENT(in)                                  :: big_r_heat_fac
+    REAL(r_std), INTENT(in)                                  :: br_fac
+    REAL(r_std), INTENT(in)                                  :: hd_big_r
+
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(jnlvls), INTENT(out)              :: big_r
+
+    !! 0.3 Modified variables
+
+
+    !! 0.4 Local variables
+
+    REAL(r_std), DIMENSION (jnlvls)                                :: temp_atmos_pres ! atmospheric temperature down the column (K) PRESENT STEP
+    REAL(r_std)                                                    :: r_a = 0.0_r_std     ! aerodynamic resistance is represented by the eddy
+    ! diffusivity coefficients so I have set this to zero 
+    REAL(r_std)                                                    :: r_b = 30.0_r_std    ! leaf boundary layer resistance
+    INTEGER(i_std)                                                 :: i, jk
+    REAL(r_std)                                                    :: small_d         ! characteristic leaf length (m)
+    REAL(r_std)                                                    :: big_l           ! characteristic leaf dimension (m)
+    REAL(r_std)                                                    :: big_d           ! molecular diffusivity of air
+    REAL(r_std)                                                    :: sherwood        ! Sherwood number
+    REAL(r_std)                                                    :: prandtl         ! Prandtl number 
+    REAL(r_std), DIMENSION (jnlvls)                                :: nusselt         ! Nusselt number
+    REAL(r_std), DIMENSION (jnlvls)                                :: bigd_h          ! heat diffusivity of air (m^2 s^-1)
+    REAL(r_std), DIMENSION (jnlvls)                                :: nu_air          ! the kinematic viscosity of air
+    REAL(r_std), DIMENSION (jnlvls)                                :: reynolds        ! reynolds number
+    REAL(r_std), DIMENSION(jnlvls)                                 :: big_r_heat
+
+
+    DO jk = 1, kjpindex
+
+        temp_atmos_pres(:) = temp_atmos_pres_grid(jk,:)
+ 
+	    IF (jnlvls .eq. 1) THEN
+
+                big_r(:)=un
+
+	        ! omit the layered calculation for single layer case
+	    ELSE
+	
+	        small_d = 0.01_r_std                                ! set the leaf length to 1cm for now
+	        big_l = 0.01_r_std                                  ! set the leaf length to 1cm for now
+	        prandtl = 1.0_r_std                                 ! set the Prandtl number to 1 for now
+	
+	        DO i = 1, jnlvls
+	            big_r(i) = 200.0_r_std * (0.05_r_std / u_speed (i))
+	        END DO ! i = 1, jnlvls
+	
+	        DO i = 1, jnlvls
+	
+	            bigd_h(i) = 1.9d-5 + (1.26d-5 * (temp_atmos_pres(i) - 273.15_r_std))
+	            nu_air(i) = 1.35d-5 + (1.0d-7 * (temp_atmos_pres(i) - 273.15_r_std))
+	            reynolds(i) = (big_l * u_speed(i)) / nu_air(i)
+	
+	            ! is the flow laminar or turbulent?
+	            IF (prandtl .lt. 0.6_r_std) THEN
+	                nusselt(i) = 0.332_r_std * (reynolds(i))**(1.0_r_std/2.0_r_std) + (prandtl)**(1.0_r_std/3.0_r_std)
+	            ELSE IF (prandtl .ge. 0.6_r_std) THEN
+	                nusselt(i) = 0.0296_r_std * (reynolds(i))**(4.0_r_std/5.0_r_std) + (prandtl)**(1.0_r_std/3.0_r_std)
+	            END IF
+	
+	            big_r_heat(i) = small_d / (bigd_h(i) * nusselt(i))
+	
+	    END DO ! i=1, jnlvls
+	
+	    END IF ! (jnlvls .eq. 1)
+	
+	    big_r = big_r * br_fac
+	
+	    ! 230613
+	    big_r(:) = hd_big_r
+	
+	    ! big_r(:) = 1.0d20
+	
+	    big_r(jnlvls) = 1.0d20        ! n.b. the top level resistance should be approaching 
+	                                   !   infinity (see diagram) need to implement this more 
+	                                   !   elegantly 
+    END DO ! jk = 1, kjpindex
+
+ END SUBROUTINE calc_boundarylayer_resistance
+
+    
+ ! -------------------------------------------------------------------------------------------------
+
+
+ SUBROUTINE jcalc_fluxes(temp_atmos_next, q_atmos_next, k_eddy, delta_z,  &
+                          & h_flux, le_flux)
+
+    ! calculate flux profiles
+
+    IMPLICIT NONE
+
+    !! 0.1 Input variables
+    !! 0.2 Output variables
+    !! 0.3 Modified variables
+    !! 0.4 Local variables
+
+
+    REAL(r_std), DIMENSION (jnlvls)               :: temp_atmos_next    ! atmospheric temperature down the column (K) NEXT STEP
+    REAL(r_std), DIMENSION (jnlvls)               :: q_atmos_next       
+    REAL(r_std), DIMENSION (jnlvls)               :: k_eddy             ! eddy transport coefficient (m^2 s-1)
+    REAL(r_std), DIMENSION (jnlvls)               :: delta_z            ! vertical difference between the middle of each box (m)
+    REAL(r_std), DIMENSION (jnlvls)               :: h_flux, le_flux
+    INTEGER(i_std)                                :: i
+    REAL(r_std)                                   :: rho_air            ! temporary for number checking   
+
+    DO i = 1, jnlvls-1
+        h_flux(i) = -1.0_r_std * cp_air * rho_air * &
+          & ((temp_atmos_next(i+1) - temp_atmos_next(i)) * k_eddy(i))/delta_z(i)
+    END DO ! i = 1, jnlvls-1
+
+    IF (james_write) THEN
+       !WRITE(numout,*) '280913 cp_air * rho_air is: ', cp_air * rho_air
+       !WRITE(numout,*) '280913 h_flux_top is: ', h_flux(jnlvls-1)
+    END IF !(james_write)
+
+    DO i = 1, jnlvls-1
+        le_flux(i) = -1.0_r_std * chalev0 * rho_air * &
+          & ((q_atmos_next(i+1) - q_atmos_next(i)) * k_eddy(i))/delta_z(i)
+    END DO ! i = 1, jnlvls-1
+
+    IF (james_write) THEN
+       !WRITE(numout,*) '280913 chalev0 * rho_air is: ', chalev0 * rho_air
+       !WRITE(numout,*) '280913 le_flux_top is: ', le_flux(jnlvls-1)
+    END IF !(james_write)
+
+ END SUBROUTINE jcalc_fluxes
+
+
+ ! ---------------------------------------------------------------------------------------
+
+  !!  ====================================================================================
+  !! SUBROUTINE		 			: jenerbil_begin
+  !!
+  !>\BRIEF					Preliminary variables required for the 
+  !! calculation of the energy budget are derived.
+  !!
+  !! DESCRIPTION				: This routines computes preliminary 
+  !! variables required for the calculation of the energy budget: the old surface static 
+  !! energy (psold), the surface saturation humidity (qsol_sat), the derivative of satured 
+  !! specific humidity at the old temperature (pdqsold) and the net radiation (netrad).
+  !!
+  !! MAIN OUTPUT VARIABLE(S)	                : psold, qsol_sat, pdqsold, netrad
+  !!
+  !! REFERENCE(S)				:
+  !! - Best, MJ, Beljaars, A, Polcher, J & Viterbo, P, 2004. A proposed structure for 
+  !! coupling tiled surfaces with the planetary boundary layer. Journal of 
+  !! Hydrometeorology, 5, pp.1271-1278
+  !! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of 
+  !! parameterisations of the hydrologic exchanges at the land-atmosphere interface within
+  !! the LMD Atmospheric General Circulation Model. Journal of Climate, 6, pp.248-273
+  !! - Dufresne, J-L & Ghattas, J, 2009. Description du schÃ©ma de la couche limite 
+  !! turbulente et la interface avec la surface planetaire dans LMDZ, Technical note, 
+  !! available (22/12/11):
+  !! http://lmdz.lmd.jussieu.fr/developpeurs/notes-techniques/ressources/pbl_surface.pdf
+  !! - Polcher, J. McAvaney, B, Viterbo, P, Gaertner, MA, Hahmann, A, Mahfouf, J-F, 
+  !! Noilhan, J Phillips, TJ, Pitman, AJ, Schlosser, CA, Schulz, J-P, Timbal, B, Verseghy,
+  !! D Xue, Y, 1998. A proposal for a general interface between land surface schemes and
+  !! general circulation models. Global and Planetary Change, 19, pp.261-276
+  !! - Richtmeyer, RD, Morton, KW, 1967. Difference Methods for Initial-Value Problems.
+  !! Interscience Publishers\n
+  !! - Schulz, Jan-Peter, Lydia DÃŒmenil, Jan Polcher, 2001: On the Land SurfaceâAtmosphere 
+  !! Coupling and Its Impact in a Single-Column Atmospheric Model. J. Appl. Meteor., 
+  !! 40, 642â663.
+  !!
+  !! FLOWCHART  : None                     
+  !! \n
+  !_ =====================================================================================
+  
+  SUBROUTINE jenerbil_begin (kjpindex, temp_sol, lwdown, swnet, pb, psold, qsol_sat, &
+                               & pdqsold, netrad, emis, jr_enerbil, dev_qsol)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                         :: kjpindex         !! Domain size (-)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_sol         !! Soil temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: lwdown           !! Down-welling long-wave flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: swnet            !! Net surface short-wave flux (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: pb               !! Lowest level pressure (hPa)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: emis             !! Emissivity (-)
+    LOGICAL, INTENT(in)                                :: jr_enerbil    !! Flag that controls the activation of alternate enerbil scheme (true/false)
+    
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: psold            !! Old surface dry static energy (J kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: qsol_sat	   !! Saturated specific humudity for old temperature 
+                                                                           !! (kg kg^{-1})    
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: pdqsold	   !! Derivative of satured specific humidity at the old 
+                                                                           !! temperature (kg (kg s)^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: netrad           !! Net radiation (W m^{-2})
+    REAL(r_std), DIMENSION(kjpindex)                   :: dev_qsol
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                     :: ji
+
+    REAL(r_std), PARAMETER                             :: missing = 999998.
+!_ ================================================================================================================================
+  
+  !! 1. Computes psold (the surface static energy for the old timestep)
+   
+    !! We here define the surface static energy for the 'old' timestep, in terms of the surface
+    !! temperature and heat capacity.
+    !! \latexonly 
+    !!     \input{enerbilbegin1.tex}
+    !! \endlatexonly
+    psold(:) = temp_sol(:)*cp_air
+    
+  !! 2. Computes qsol_sat (the surface saturated humidity).
+ 
+    ! WRITE(*,*) '181113a test, pre call to qsatcalc enerbil line 5602; temp_sol is: ', temp_sol
+
+    !! We call the routine 'qsatcalc' from within the module 'src_parameters/constantes_veg'.
+    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 
+    
+    !! Computes pdqsold (the derivative of the saturated humidity with respect to temperature
+    !! analysed at the surface temperature at the 'old' timestep.
+    !! We call the routine 'dev_qsatcalc' from within the module 'src_parameters/constantes_veg'.
+    CALL dev_qsatcalc (kjpindex, temp_sol, pb, dev_qsol)
+    
+     IF (james_write) THEN
+!!$       WRITE(numout,*) '***** 010213 *****'
+!!$       WRITE(numout,*) ' '
+!!$       WRITE(numout,*) 'after CALL dev_qsatcalc'
+!!$       WRITE(numout,*) 'temp_sol(1) is: ', temp_sol(1)
+!!$       WRITE(numout,*) 'pb(1) is: ', pb(1)
+!!$       WRITE(numout,*) 'dev_qsol(1) is: ', dev_qsol(1)        
+!!$       WRITE(numout,*) 'EFFECTIVE jalpha is: ', dev_qsol(1)
+!!$       WRITE(numout,*) 'EFFECTIVE jbeta is: ', qsol_sat(1) - temp_sol(1) * dev_qsol(1)
+     ENDIF
+
+
+!+++ According to r2093 in the trunk, this causes and instabilty in the coupling
+!    DO ji = 1, kjpindex
+!!$    
+!!$    !! \latexonly 
+!!$    !!     \input{enerbilbegin2.tex}
+!!$    !! \endlatexonly
+!      pdqsold(ji) = dev_qsol(ji) * ( pb(ji)**kappa ) / cp_air
+!    ENDDO
+
+    pdqsold(:) = dev_qsol(:)
+!+++++++++
+
+    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 the net radiation and the absorbed LW radiation absorbed at the surface. 
+
+    !! Long wave radiation absorbed by the surface is the product of emissivity and downwelling LW radiation    
+    !! \latexonly 
+    !!     \input{enerbilbegin3.tex}
+    !! \endlatexonly
+    lwabs(:) = emis(:) * lwdown(:)
+
+    !! Net radiation is calculated as:
+    !! \latexonly 
+    !!     \input{enerbilbegin4.tex}
+    !! \endlatexonly
+    netrad(:) = lwdown(:) + swnet (:) - (emis(:) * c_stefan * temp_sol(:)**4 + &
+                 & (un - emis(:)) * lwdown(:)) 
+    !
+    IF (long_print) WRITE (numout,*) ' jenerbil_begin done '
+
+    ! WRITE(numout,*) 'components BB emission (inside jenerbil_begin): ', (emis(1) * c_stefan * temp_sol(1)**4)
+
+
+
+  END SUBROUTINE jenerbil_begin
+
+ ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+
+
+
+ !! =============================================================================================================================
+ !! SUBROUTINE		 			: jenerbil_pottemp
+ !!
+ !>\BRIEF		This subroutine computes the surface temperature and humidity should the surface been unstressed	
+ !!
+ !! DESCRIPTION				: 
+ !!
+ !! MAIN OUTPUT VARIABLE(S)	: q_sol_pot, temp_sol_pot
+ !!
+ !! REFERENCE(S)		:
+ !!
+ !! FLOWCHART    : None
+ !!
+ !_ ==============================================================================================================================  
+
+  SUBROUTINE jenerbil_pottemp (kjpindex, dtradia, zlev, emis, epot_air, &
+     & petAcoef, petBcoef, qair, peqAcoef, peqBcoef, soilflx, rau, u, v, q_cdrag, vbeta,&
+     & valpha, vbeta1, vbeta5, soilcap, lwdown, swnet, q_sol_pot, temp_sol_pot) 
+
+    !! 0.1 Input variables
+    !! 0.2 Output variables
+    !! 0.3 Modified variables
+    !! 0.4 Local variables
+
+    ! 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)            :: vbeta5        !! Floodplains 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)           :: q_sol_pot     !! Potential surface air moisture
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: temp_sol_pot  !! Potential soil 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
+
+    ! initialisation of variables
+    temp_sol_pot(:)=zero
+    q_sol_pot(:)=zero
+
+    !
+    DO ji=1,kjpindex
+
+       dtheta = zero
+       fevap = zero
+
+       temp_sol_pot(ji) = temp_sol_pot(ji) + dtheta
+
+       q_sol_pot(ji) = q_sol_pot(ji) + fevap
+
+    ENDDO
+
+  END SUBROUTINE jenerbil_pottemp
+
+
+
+  ! ------------------------------------------------------------------------------------------------------------------------------
+
+
+
+
+  SUBROUTINE jenerbil_evapveg (kjpindex, dtradia, vbeta1, vbeta2, vbeta3, vbeta3pot, &
+     & vbeta4, vbeta5, rau, u, v, q_cdrag, qair, humrel, &
+!!$     & vbeta4, vbeta5, cimean, ccanopy, rau, u, v, q_cdrag, qair, humrel, &
+     & vevapsno, vevapnu , vevapflo, vevapwet, transpir, transpot, evapot)
+
+    !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                          :: kjpindex          !! Domain size (-)
+    REAL(r_std), INTENT(in)                             :: dtradia           !! Time step (s)
+    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)       :: vbeta5            !! Floodplains resistance
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: rau               !! Density (kg m^{-3})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: u, v              !! Wind velocity in directions u and v (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: q_cdrag           !! Surface drag (m s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: qair              !! Lowest level specific humidity (kg kg^{-1})
+!!$    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: ccanopy           !! CO2 concentration in the canopy (ppm)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: evapot            !! Soil Potential Evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex, nvm), INTENT (in)  :: humrel            !! Soil moisture stress (within range 0 to 1)
+    !!$ DS 15022011 humrel was used in a previous version of Orchidee, developped by Nathalie. Need to be discussed if it should be introduce again             
+    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)   :: vbeta3pot         !! Vegetation resistance for potential transpiration
+!!$    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)   :: cimean            !! STOMATE: mean intercellular ci \mu mole m^{-2} s^{-1}
+    
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: vevapsno          !! Snow evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: vevapnu           !! Bare soil evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: vevapflo         !! Floodplains evaporation
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)  :: transpir          !! Transpiration (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)  :: transpot          !! Potential Transpiration
+    ! JR GPP calculation is now carried out in diffuco 
+!   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 (mm day^{-1})
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                      :: ji, jv
+    REAL(r_std), DIMENSION(kjpindex)                    :: xx
+    REAL(r_std), DIMENSION(kjpindex)                    :: vbeta2sum, vbeta3sum
+    REAL(r_std)                                    	:: speed	     !! Speed (m s^{-1})
+!_ ==============================================================================================================================
+    ! initialisation: utile pour calculer l'evaporation des floodplains dans lesquelles il y a de la vegetation
+    vbeta2sum(:) = 0.
+    vbeta3sum(:) = 0.
+    DO jv = 1, nvm
+      vbeta2sum(:) = vbeta2sum(:) + vbeta2(:,jv)
+      vbeta3sum(:) = vbeta3sum(:) + vbeta3(:,jv)
+    ENDDO 
+    
+    IF (james_write) THEN
+       !WRITE (*,*) '041113 vbeta3sum is: ', vbeta3sum
+    END IF ! (james_write)    
+
+    !! 1. Compute vevapsno (evaporation from snow) and vevapnu (bare soil evaporation)
+
+    DO ji=1,kjpindex 
+
+        !! \latexonly 
+        !q_cdrag(ji) = q_cdrag(ji) * 10        
+!!     \input{enerbilevapveg1.tex}
+        !! \endlatexonly
+        speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+
+      
+        !! 1.1 Snow sublimation
+        !! \latexonly 
+        !!     \input{enerbilevapveg2.tex}
+        !! \endlatexonly
+        vevapsno(ji) = (un - vbeta5(ji)) * vbeta1(ji) * dtradia * rau(ji) * speed * &
+                      & q_cdrag(ji) *  (qsol_sat_new(ji) - qair(ji))
+
+        !! 1.2 Bare soil evaporation
+        !! \latexonly 
+        !!     \input{enerbilevapveg3.tex}
+        !! \endlatexonly
+        vevapnu(ji) = (un - vbeta1(ji)) * (un-vbeta5(ji)) * vbeta4(ji) * dtradia * &
+                     & rau(ji) * speed * q_cdrag(ji) * (qsol_sat_new(ji) - qair(ji))
+
+        !
+        ! 1.3 floodplains evaporation - transpiration et interception prioritaires dans les floodplains
+        !
+        vevapflo(ji) = vbeta5(ji) * (1 - vbeta2sum(ji) - vbeta3sum(ji)) &
+             & * dtradia * rau(ji) * speed * q_cdrag(ji) * (qsol_sat_new(ji) - qair(ji))
+
+    END DO
+
+    !! 2. Compute transpir (transpiration) and vevapwet (interception)
+  
+    !! Preliminaries
+    DO ji = 1, kjpindex
+       
+        !! \latexonly 
+        !!     \input{enerbilevapveg4.tex}
+        !! \endlatexonly
+        speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+       
+        !! \latexonly 
+        !!     \input{enerbilevapveg5.tex}
+        !! \endlatexonly
+        !+++TEMP+++
+!!$        IF (james_write) THEN
+!!$           WRITE(numout,*) 'Checking transpir'
+!!$           WRITE(numout,*) 'vbeta1(ji), ',vbeta1(ji)
+!!$           WRITE(numout,*) 'qsol_sat_new(ji)', qsol_sat_new(ji)
+!!$           WRITE(numout,*) 'qair(ji), ', qair(ji)
+!!$           WRITE(numout,*) 'rau(ji), ', rau(ji)
+!!$           WRITE(numout,*) 'speed, ', speed
+!!$           WRITE(numout,*) 'q_cdrag(ji)', q_cdrag(ji)
+!!$           WRITE(numout,*) 'vbeta3(ji,jv)', vbeta3(ji,:)
+!!$        ENDIF
+        xx(ji) = dtradia * (un-vbeta1(ji)) * (qsol_sat_new(ji)-qair(ji)) &
+                 & * rau(ji) * speed * q_cdrag(ji) 
+        !++++++++++
+       ! write(*,*) 'xx_CAN',xx(ji)
+       !write(*,*) 'vbeta1_jCAN',vbeta1(ji)
+       !write(*,*) 'qsol_sat_new_jCAN',qsol_sat_new(ji)
+       !write(*,*) 'qair_jCAN',qair(ji)
+       !write(*,*) 'rau_jCAN',rau(ji)
+       !write(*,*) 'speed_jCAN',speed
+       !write(*,*) 'q_cdrag_jCAN',q_cdrag(ji)
+
+       !write(*,*) 'xx_jCAN',xx(ji)
+    ENDDO
+    
+    DO jv=1,nvm 
+      DO ji=1,kjpindex 
+        
+        !! 2.1 Calculate interception loss
+        !! \latexonly 
+        !!     \input{enerbilevapveg6.tex}
+        !! \endlatexonly
+        vevapwet(ji,jv) = xx(ji) * vbeta2(ji,jv)
+        !vevapwet(ji,jv)=MAX(0.0,vevapwet(ji,jv))
+        !write(*,*) 'vevapwet_j',vevapwet(ji,jv) 
+        !! 2.2 Calculate transpiration
+        !! \latexonly 
+        !!     \input{enerbilevapveg7.tex}
+        !! \endlatexonly
+        transpir (ji,jv) = xx(ji) * vbeta3(ji,jv)
+        !transpir(ji,jv)=MAX(0.0,transpir(ji,jv))
+
+           ! IF (jv .eq. 4) THEN
+           !      WRITE(numout,*) '261113b in first calc PFT4, vbeta3(ji,jv) is: ', vbeta3(ji,jv)
+           !      WRITE(numout,*) '261113b in first calc PFT4, transpir (ji,jv) is: ', transpir (ji,jv)
+           !      WRITE(numout,*) '261113b in first calc PFT4, (1.0_r_std - vbeta1(ji)) is: ', (1.0_r_std - vbeta1(ji))
+           !      WRITE(numout,*) '261113b in first calc PFT4, qsol_sat_new(ji) is: ', qsol_sat_new(ji)
+           !      WRITE(numout,*) '261113b in first calc PFT4, qair(ji) is: ', qair(ji)
+           !      WRITE(numout,*) '261113b in first calc PFT4, ( rau(ji) * speed * q_cdrag(ji)) is: ', ( rau(ji) * speed * q_cdrag(ji))
+           ! END IF
+
+        transpot(ji,jv) = xx(ji) * vbeta3pot(ji,jv)
+
+      END DO
+    END DO
+    DO ji=1,kjpindex
+        !write(*,*) 'vevapwet_jCAN',vevapwet(ji,2)
+        !write(*,*) 'vbeta3_jCAN',vbeta3(ji,2)
+        !write(*,*) 'transpir_jCAN',transpir(ji,2)
+    ENDDO
+
+    IF (long_print) WRITE (numout,*) ' enerbil_evapveg done '
+
+    ! WRITE (*,*) '041013 transpir(:,:) is: ', transpir
+
+  END SUBROUTINE jenerbil_evapveg
+
+
+  !!  =============================================================================================================================
+  !! SUBROUTINE		 			: enerbil_flux
+  !!
+  !>\BRIEF					Computes the new soil temperature, net radiation and
+  !! latent and sensible heat flux for the new time step.
+  !!
+  !! DESCRIPTION				: This routine diagnoses, based on the new soil temperature, 
+  !! the net radiation, the total evaporation, the latent heat flux, the sensible heat flux and the 
+  !! sublimination flux. It also diagnoses the potential evaporation used for the fluxes (evapot) and the potential
+  !! as defined by Penman & Monteith (Monteith, 1965) based on the correction term developed by Chris 
+  !! Milly (1992). This Penman-Monteith formulation is required for the estimation of bare soil evaporation 
+  !! when the 11 layer CWRR moisture scheme is used for the soil hydrology.
+  !!
+  !! MAIN OUTPUT VARIABLE(S)	: qsurf, fluxsens, fluxlat, fluxsubli, vevapp, lwup, lwnet,
+  !! tsol_rad, netrad, evapot, evapot_corr
+  !!
+  !! REFERENCE(S)					:
+  !! - Best, MJ, Beljaars, A, Polcher, J & Viterbo, P, 2004. A proposed structure for coupling tiled
+  !! surfaces with the planetary boundary layer. Journal of Hydrometeorology, 5, pp.1271-1278
+  !! - de Noblet-DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+  !! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+  !! Circulation Model. Journal of Climate, 6, pp.248-273
+  !! - Dufresne, J-L & Ghattas, J, 2009. Description du schÃ©ma de la couche limite turbulente et la
+  !! interface avec la surface planetaire dans LMDZ, Technical note, available (22/12/11):
+  !! http://lmdz.lmd.jussieu.fr/developpeurs/notes-techniques/ressources/pbl_surface.pdf
+  !! - Guimberteau, M, 2010. ModÃ©lisation de l'hydrologie continentale et influences de l'irrigation
+  !! sur le cycle de l'eau, PhD Thesis, available (22/12/11):
+  !! http://www.sisyphe.upmc.fr/~guimberteau/docs/manuscrit_these.pdf
+  !! - Monteith, JL, 1965. Evaporation and Environment, paper presented at Symposium of the Society
+  !! for Experimental Biology
+  !! - Monteith & Unsworth, 2008. Principles of Environmental Physics (third edition), published Elsevier
+  !! ISBN 978-0-12-505103-3
+  !! - Milly, P. C. D., 1992: Potential Evaporation and Soil Moisture in General Circulation Models. 
+  !! Journal of Climate, 5, pp. 209â226.
+  !! - Polcher, J. McAvaney, B, Viterbo, P, Gaertner, MA, Hahmann, A, Mahfouf, J-F, Noilhan, J
+  !! Phillips, TJ, Pitman, AJ, Schlosser, CA, Schulz, J-P, Timbal, B, Verseghy, D &
+  !! Xue, Y, 1998. A proposal for a general interface between land surface schemes and
+  !! general circulation models. Global and Planetary Change, 19, pp.261-276
+  !! - Richtmeyer, RD, Morton, KW, 1967. Difference Methods for Initial-Value Problems.
+  !! Interscience Publishers
+  !! - Schulz, Jan-Peter, Lydia DÃŒmenil, Jan Polcher, 2001: On the Land SurfaceâAtmosphere 
+  !! Coupling and Its Impact in a Single-Column Atmospheric Model. J. Appl. Meteor., 40, 642â663.
+  !!
+  !! FLOWCHART					: None
+  !! \n
+  !_ ==============================================================================================================================
+
+  SUBROUTINE jenerbil_flux (kjpindex, dtradia, emis, temp_sol, rau, u, v, q_cdrag, vbeta, valpha, vbeta1, vbeta5, &
+       & qair, epot_air, psnew, qsurf, fluxsens, fluxlat, fluxsubli, vevapp, temp_sol_new, &
+       & lwdown, swnet, lwup, lwnet, pb, tsol_rad, netrad, evapot, evapot_corr, jr_enerbil)
+
+    !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                               :: kjpindex      !! Domain size (-)
+    REAL(r_std), INTENT(in)                                  :: dtradia       !! Time step (s)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: emis          !! Emissivity (-)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_sol      !! Surface temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: rau           !! Density (kg m^{-3})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u,v           !! Wind velocity in components u and v (m s^{-1}) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q_cdrag       !! Surface drag (m s^{-1})
+    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)            :: vbeta5        !! Flood resistance 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qair          !! Lowest level specific humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: epot_air      !! Air potential energy (J)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: psnew         !! New surface static energy (J kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_sol_new  !! New soil temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: pb            !! Lowest level pressure (hPa)
+    LOGICAL, INTENT(in)                                      :: jr_enerbil    !! Flag that controls the activation of alternate enerbil scheme (true/false)
+    
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: qsurf         !! Surface specific humidity (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex)                         :: fluxsens      !! Sensible heat flux (W m^{-2})   ! JR 060913 not output here, calculated in jcalc instead
+    REAL(r_std),DIMENSION (kjpindex)                         :: fluxlat       !! Latent heat flux (W m^{-2})     ! JR 060913 not output here, calculated in jcalc instead
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fluxsubli     !! Energy of sublimation (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: vevapp        !! Total of evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: lwdown        !! Downward long wave radiation (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: swnet         !! Net short wave radiation (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: lwup          !! Long-wave up radiation (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: lwnet         !! Long-wave net radiation (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: tsol_rad      !! Radiative surface temperature (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: netrad        !! Net radiation (W m^{-2})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: evapot        !! Soil Potential Evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: evapot_corr   !! Soil Potential Evaporation Correction 
+                                                                              !! (?? mm day^{-1})
+
+
+    
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                               :: ji
+    REAL(r_std),DIMENSION (kjpindex)        		         :: grad_qsat
+    REAL(r_std)                               		         :: correction
+    REAL(r_std)                                			 :: speed              !! Speed (m s^{-1}), 
+    REAL(r_std)                                			 :: qc          !! Surface drag coefficient (??)
+    LOGICAL,DIMENSION (kjpindex)            		         :: warning_correction
+!_ ================================================================================================================================
+!   tzjE 
+    DO ji=1,kjpindex
+      
+        !! 1. Determination of 'housekeeping' variables
+      
+        !! The horizontal wind speed is calculated from the velocities along each axis using Pythagorus' theorem. 
+        !! \latexonly 
+        !!     \input{enerbilflux1.tex}
+        !! \endlatexonly
+        speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+        !! From definition, the surface drag coefficient is defined:
+        !! \latexonly 
+        !!     \input{enerbilflux2.tex}
+        !! \endlatexonly
+! WRITE(numout,*) 'q_drag', q_cdrag(ji) 
+        qc = speed * q_cdrag(ji)
+! WRITE(numout,*) 'qc', qc     
+ 
+
+        !! 2. Calculation of the net upward flux of longwave radiation
+      
+        !! We first of all calculate the radiation as a result of the Stefan-Boltzmann equation,
+        !! which is the sum of the calculated values at the surface temperature  at the 'old' 
+        !! temperature and the value that corresponds to the difference between the old temperature
+        !! and the temperature at the 'new' timestep.
+        !! \latexonly 
+        !!     \input{enerbilflux3.tex}
+        !! \endlatexonly
+
+! tzjE issu with temp_sol (too high 368 et le new tombe Ã  120 K)
+! WRITE(numout,*) 'temp_sol enerbil', temp_sol(ji)
+! WRITE(numout,*) 'temp_sol_new enerbil', temp_sol_new(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))      
+ 
+! WRITE(numout,*) 'lwup', lwup(ji)
+      
+        !! We then add to this value that from the reflected longwave radiation:
+        !! \latexonly 
+        !!     \input{enerbilflux4.tex}
+        !! \endlatexonly
+! WRITE(numout,*) 'lwdow', lwdown(ji)
+        lwup(ji) = lwup(ji)  +  (un - emis(ji)) * lwdown(ji)
+! WRITE(numout,*) 'lwup2', lwup(ji)
+      
+
+      !! The radiative surface temperature is calculated according to the Stefan-Boltzmann relation:
+      !! \latexonly 
+      !!     \input{enerbilflux5.tex}
+      !! \endlatexonly      
+      ! tsol_rad(ji) = emis(ji) * c_stefan * temp_sol(ji)**4 + lwup(ji)
+
+
+      !! The implicit solution computes an emitted long-wave flux which is a limited Taylor expansion 
+      !! of the future surface temperature around the current values. Thus the long-wave flux does not  
+      !! correspond to the new surface temperature but some intermediate value. So we need to deduce the 
+      !! radiative surface temperature to which this flux corresponds. 
+      !! 
+
+!WRITE(numout,*) 'enrb',emis(ji)
+!WRITE(numout,*) 'enrb emis',c_stefan
+       tsol_rad(ji) = (lwup(ji)/ (emis(ji) * c_stefan)) **(1./quatre) 
+
+!WRITE(numout,*) 'tsol_rad',tsol_rad(ji)
+
+     
+        !! qsurf (the surface specific humidity) is a simple diagnostic which will be used by the 
+        !! GCM to compute the dependence of of the surface layer stability on moisture.
+        !! \latexonly 
+        !!     \input{enerbilflux6.tex}
+        !! \endlatexonly
+
+        qsurf(ji) = (vbeta1(ji) * (un - vbeta5(ji)) + vbeta5(ji)) * qsol_sat_new(ji) + &
+             & (un - vbeta1(ji))*(un - vbeta5(ji)) * vbeta(ji) * valpha(ji) * qsol_sat_new(ji)
+
+!WRITE(numout,*) 'qsol_sat_new',qsol_sat_new(ji)
+!WRITE(numout,*) 'param', vbeta1(ji), vbeta5(ji), vbeta(ji), valpha(ji)
+!WRITE(numout,*) 'qsurf',qsurf(ji)
+      
+        IF (ji .eq. 1 .AND. ld_enerbil) THEN
+            WRITE(numout,*) "qsurf(1) is: ", qsurf(1) 
+            WRITE(numout,*) "qair(1) is: ", qair(1) 
+        END IF 
+
+        !! \latexonly 
+        !!     \input{enerbilflux7.tex}
+        !! \endlatexonly
+        qsurf(ji) = MAX(qsurf(ji), qair(ji))
+!WRITE(numout,*) 'qsurf',qsurf(ji)
+
+        !! Net downward radiation is the sum of the down-welling less the up-welling long wave flux, plus
+        !! the short wave radiation.
+        !! \latexonly 
+        !!     \emissivity absorbed lw radiationinput{enerbilflux8.tex}
+        !! \endlatexonly
+! WRITE(numout,*) 'swnet', swnet(ji)
+        netrad(ji) = lwdown(ji) + swnet(ji) - lwup(ji) 
+! WRITE(numout,*) 'netrad', netrad(ji)
+      
+        !! 'vevapp' is the sum of the total evaporative processes (snow plus non-snow processes).
+        !! \latexonly 
+        !!     \input{enerbilflux9.tex}
+        !! \endlatexonly
+! WRITE(numout,*) 'vevapp calcul', rau(ji)
+        vevapp(ji) = dtradia * rau(ji) * qc * (vbeta1(ji) * (un - vbeta5(ji)) + vbeta5(ji)) * &
+             & (qsol_sat_new(ji) - qair(ji)) + &
+             &  dtradia * rau(ji) * qc * (un - vbeta1(ji))*(un-vbeta5(ji)) * vbeta(ji) * &
+             & (valpha(ji) * qsol_sat_new(ji) - qair(ji))
+      
+        !! The total latent heat flux is the sum of the snow plus non-snow processes.
+        !! \latexonly 
+        !!     \input{enerbilflux10.tex}
+        !! \endlatexonly
+        ! ( JR 050913 commented out here, as calculated in jcalc for now)
+        ! fluxlat(ji) = chalsu0 * rau(ji) * qc * vbeta1(ji) * (un - vbeta5(ji)) * &
+        !      & (qsol_sat_new(ji) - qair(ji)) + &
+        !      &  chalev0 * rau(ji) * qc * vbeta5(ji) *&
+        !      & (qsol_sat_new(ji) - qair(ji)) + &
+        !      &  chalev0 * rau(ji) * qc * (un - vbeta1(ji)) * (un - vbeta5(ji)) * vbeta(ji) * &
+        !     & (valpha(ji) * qsol_sat_new(ji) - qair(ji))
+
+
+
+        !! The sublimination flux concerns is calculated using vbeta1, the snow resistance.
+        !! \latexonly 
+        !!     \input{enerbilflux11.tex}
+        !! \endlatexonly
+        fluxsubli(ji) = chalsu0 * rau(ji) * qc * vbeta1(ji) * (un - vbeta5(ji)) * &
+             & (qsol_sat_new(ji) - qair(ji)) 
+      
+        !! The sensible heat flux is a factor of the difference between the new surface static energy
+        !! and the potential energy of air.
+        !! \latexonly 
+        !!     \input{enerbilflux12.tex}
+        !! \endlatexonly
+        !fluxsens(ji) =  rau(ji) * qc * (psnew(ji) - epot_air(ji))
+      
+        !! This is the net longwave downwards radiation.
+        !! \latexonly 
+        !!     \input{enerbilflux13.tex}
+        !! \endlatexonly
+        lwnet(ji) = lwdown(ji) - lwup(ji)
+      
+        !! Diagnoses the potential evaporation used for the fluxes (evapot)
+        !! \latexonly 
+        !!     \input{enerbilflux14.tex}
+        !! \endlatexonly  
+        evapot(ji) =  MAX(zero, dtradia * rau(ji) * qc * (qsol_sat_new(ji) - qair(ji)))
+     
+        !! From definition we can say:
+        !! \latexonly 
+        !!     \input{enerbilflux15.tex}
+        !! \endlatexonly 
+
+! WRITE(numout,*) 'epot_ait', epot_air(ji)
+        tair(ji)  =  epot_air(ji) / cp_air
+
+     ENDDO 
+
+
+    !! 3. Define qsat_air with the subroutine src_parameter:
+
+    ! WRITE(*,*) '181113a test, pre call to qsatcalc enerbil line 6210; tair is: ', tair
+
+    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
+      
+      !! \latexonly 
+      !!     \input{enerbilflux16.tex}
+      !! \endlatexonly 
+      speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+      
+      !! \latexonly 
+      !!     \input{enerbilflux17.tex}
+      !! \endlatexonly 
+      qc = speed * q_cdrag(ji)
+       
+      !! Derive the potential as defined by Penman & Monteith (Monteith, 1965) based on the correction 
+      !! term developed by Chris Milly (1992).
+       IF ((evapot(ji) .GT. zero) .AND. ((psnew(ji) - epot_air(ji)) .NE. zero )) THEN
+          !
+          !! \latexonly 
+          !!     \input{enerbilflux18.tex}
+          !! \endlatexonly 
+          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) )
+          
+          !! \latexonly 
+          !!     \input{enerbilflux19.tex}
+          !! \endlatexonly 
+          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)
+      
+      !! \latexonly 
+      !!     \input{enerbilflux20.tex}
+      !! \endlatexonly 
+       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,"Denumerator of the Milly Correction is zero, so no correction has been applied"
+          ENDIF
+       ENDDO
+    ENDIF
+!    IF (long_print) WRITE (numout,*) ' enerbil_flux done '
+!    WRITE (numout,*) ' enerbil_flux done '
+
+  END SUBROUTINE jenerbil_flux
+
+  ! --------------------------------------------------------------------------------------------------------
+
+
+ !!  ===========================================================================================================================
+  !! SUBROUTINE		 		    : enerbil_write
+  !!
+  !!
+  !>\BRIEF				    Write a bunch of variables to the history file
+  !!
+  !! DESCRIPTION			    : 
+  !! Originally the routine enerbil_main was used for this, but that seemed to create
+  !! problems with uninitialized variables when it was called after jdriver.
+  !! \n
+  !!
+  !! RECENT CHANGE(S): None
+  !!
+  !! MAIN OUTPUT VARIABLE(S)	: None
+  !!
+  !! REFERENCE(S)		:
+  !!
+  !! FLOWCHART			:
+  !! \n
+  !_ ==============================================================================================================================
+   
+  SUBROUTINE enerbil_write (kjit, kjpindex, &
+       & index, lwdown, temp_sol, &
+!!$       & index, lwdown, ccanopy, temp_sol, &
+       & temp_sol_new, evapot, evapot_corr, hist_id, hist2_id) 
+
+    !! 0 Variable and parameter description
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                           :: kjit          !! Time step number (-)
+    INTEGER(i_std), INTENT(in)                           :: kjpindex      !! Domain size (-)
+    INTEGER(i_std),INTENT (in)                           :: hist_id       !! _Restart_ file and _history_ file identifier (-)
+    INTEGER(i_std),INTENT (in)                           :: hist2_id      !! _history_ file 2 identifier (-)
+    
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)     :: index         !! Indeces of the points on the map (-)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: lwdown        !! Down-welling long-wave flux (W m^{-2})
+!!$    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: ccanopy       !! CO_2 concentration in the canopy (ppm)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: evapot        !! Soil Potential Evaporation (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: evapot_corr   !! Soil Potential Evaporation Correction (mm day^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: temp_sol      !! Soil temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: temp_sol_new  !! New soil temperature (K)
+
+    !! 0.2 Output variables
+    
+    !! 0.3 Modified variables
+    
+    
+    !! 0.4 Local variables
+
+
+!_ ================================================================================================================================
+    
+    
+    
+     !CALL xios_orchidee_send_field("netrad",netrad)
+     CALL xios_orchidee_send_field("evapot",evapot*one_day/dt_sechiba)
+     CALL xios_orchidee_send_field("evapot_alma",evapot/dt_sechiba)
+     CALL xios_orchidee_send_field("evapot_corr",evapot_corr*one_day/dt_sechiba)
+     CALL xios_orchidee_send_field("evapot_corr_alma",evapot_corr/dt_sechiba)
+     CALL xios_orchidee_send_field("lwdown",lwabs)
+     CALL xios_orchidee_send_field("lwnet",lwnet)
+     CALL xios_orchidee_send_field("Qv",fluxsubli)
+     CALL xios_orchidee_send_field("PotSurfT",temp_sol_pot)
+     
+     IF ( .NOT. almaoutput ) THEN
+        !CALL histwrite_p(hist_id, 'netrad', kjit, netrad, kjpindex, index)
+        CALL histwrite_p(hist_id, 'evapot', kjit, evapot, kjpindex, index)
+        CALL histwrite_p(hist_id, 'evapot_corr', kjit, evapot_corr, kjpindex, index)
+        CALL histwrite_p(hist_id, 'lwdown', kjit, lwabs,  kjpindex, index)
+        CALL histwrite_p(hist_id, 'lwnet',  kjit, lwnet,  kjpindex, index)
+        IF ( hist2_id > 0 ) THEN
+           !CALL histwrite_p(hist2_id, 'netrad', kjit, netrad, kjpindex, index)
+           CALL histwrite_p(hist2_id, 'evapot', kjit, evapot, kjpindex, index)
+           CALL histwrite_p(hist2_id, 'evapot_corr', kjit, evapot_corr, kjpindex, index)
+           CALL histwrite_p(hist2_id, 'lwdown', kjit, lwabs,  kjpindex, index)
+           CALL histwrite_p(hist2_id, 'lwnet',  kjit, lwnet,  kjpindex, index)
+        ENDIF
+     ELSE
+        CALL histwrite_p(hist_id, 'LWnet', kjit, lwnet, kjpindex, index)
+        CALL histwrite_p(hist_id, 'Qv', kjit, fluxsubli, kjpindex, index)
+        CALL histwrite_p(hist_id, 'PotEvap', kjit, evapot_corr, kjpindex, index)
+        CALL histwrite_p(hist_id, 'PotEvapOld', kjit, evapot, kjpindex, index)
+        CALL histwrite_p(hist_id, 'PotSurfT', kjit, temp_sol_pot, kjpindex, index)
+        IF ( hist2_id > 0 ) THEN
+           CALL histwrite_p(hist2_id, 'LWnet', kjit, lwnet, kjpindex, index)
+           CALL histwrite_p(hist2_id, 'Qv', kjit, fluxsubli, kjpindex, index)
+           CALL histwrite_p(hist2_id, 'PotEvap', kjit, evapot_corr, kjpindex, index)
+        ENDIF
+     ENDIF
+     
+    IF (long_print) WRITE (numout,*) ' enerbil_main Done '
+
+  END SUBROUTINE enerbil_write
+
+
+END MODULE enerbil
Index: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/hydrol.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/hydrol.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/hydrol.f90	(revision 7236)
@@ -0,0 +1,7836 @@
+! ===================================================================================================\n
+! MODULE        : hydrol
+!
+! CONTACT       : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE       : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        This module computes the soil moisture processes on continental points. 
+!!
+!!\n DESCRIPTION : contains hydrol_main, hydrol_initialize, hydrol_finalise, hydrol_init, 
+!!                 hydrol_var_init, hydrol_waterbal, hydrol_alma,
+!!                 hydrol_snow, hydrol_vegupd, hydrol_canop, hydrol_flood, hydrol_soil.
+!!                 The assumption in this module is that very high vertical resolution is
+!!                 needed in order to properly resolve the vertical diffusion of water in
+!!                 the soils. Furthermore we have taken into account the sub-grid variability
+!!                 of soil properties and vegetation cover by allowing the co-existence of
+!!                 different soil moisture columns in the same grid box.
+!!                 This routine was originaly developed by Patricia deRosnay.
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! REFERENCE(S) :
+!! - de Rosnay, P., J. Polcher, M. Bruen, and K. Laval, Impact of a physically based soil
+!! water flow and soil-plant interaction representation for modeling large-scale land surface
+!! processes, J. Geophys. Res, 107 (10.1029), 2002. \n
+!! - de Rosnay, P. and Polcher J. (1998) Modeling root water uptake in a complex land surface scheme coupled 
+!! to a GCM. Hydrology and Earth System Sciences, 2(2-3):239-256. \n
+!! - de Rosnay, P., M. Bruen, and J. Polcher, Sensitivity of surface fluxes to the number of layers in the soil 
+!! model used in GCMs, Geophysical research letters, 27 (20), 3329 - 3332, 2000. \n
+!! - dâOrgeval, T., J. Polcher, and P. De Rosnay, Sensitivity of the West African hydrological
+!! cycle in ORCHIDEE to infiltration processes, Hydrol. Earth Syst. Sci. Discuss, 5, 2251 - 2292, 2008. \n
+!! - Carsel, R., and R. Parrish, Developing joint probability distributions of soil water retention
+!! characteristics, Water Resources Research, 24 (5), 755 - 769, 1988. \n
+!! - Mualem, Y., A new model for predicting the hydraulic conductivity of unsaturated porous
+!! media, Water Resources Research, 12 (3), 513 - 522, 1976. \n
+!! - Van Genuchten, M., A closed-form equation for predicting the hydraulic conductivity of
+!! unsaturated soils, Soil Science Society of America Journal, 44 (5), 892 - 898, 1980. \n
+!! - Campoy, A., Ducharne, A., Cheruy, F., Hourdin, F., Polcher, J., and Dupont, J.-C., Response 
+!! of land surface fluxes and precipitation to different soil bottom hydrological conditions in a
+!! general circulation model,  J. Geophys. Res, in press, 2013. \n
+!! - Gouttevin, I., Krinner, G., Ciais, P., Polcher, J., and Legout, C. , 2012. Multi-scale validation
+!! of a new soil freezing scheme for a land-surface model with physically-based hydrology.
+!! The Cryosphere, 6, 407-430, doi: 10.5194/tc-6-407-2012. \n
+!!
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/trunk/ORCHIDEE/src_sechiba/hydrol.f90 $
+!! $Date: 2016-12-01 08:43:56 +0100 (jeu. 01 dÃ©c. 2016) $
+!! $Revision: 3941 $
+!! \n
+!_ ===============================================================================================\n
+MODULE hydrol
+
+  USE ioipsl
+  USE xios_orchidee
+  USE constantes
+  USE constantes_soil
+  USE pft_parameters
+  USE sechiba_io
+  USE grid
+  USE sechiba_hydrol_arch
+!@FM  USE explicitsnow
+
+  IMPLICIT NONE
+
+  PRIVATE
+  PUBLIC :: hydrol_main, hydrol_initialize, hydrol_finalize, hydrol_clear
+
+  !
+  ! variables used inside hydrol module : declaration and initialisation
+  !
+  LOGICAL, SAVE                                   :: first_hydrol_main=.TRUE.  !! Initialisation has to be done one time (true/false)
+!$OMP THREADPRIVATE(first_hydrol_main)
+  LOGICAL, SAVE                                   :: doponds=.FALSE.         !! Reinfiltration flag (true/false)
+!$OMP THREADPRIVATE(doponds)
+  !
+  CHARACTER(LEN=80) , SAVE                        :: var_name                !! To store variables names for I/O
+!$OMP THREADPRIVATE(var_name)
+  !
+  REAL(r_std), PARAMETER                          :: allowed_err =  2.0E-8_r_std
+  REAL(r_std), PARAMETER                          :: EPS1 = EPSILON(un)      !! A small number
+  ! one dimension array allocated, computed, saved and got in hydrol module
+  ! Values per soil type
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: nvan                !! Van Genuchten coeficients n (unitless)
+                                                                          ! RK: 1/n=1-m
+!$OMP THREADPRIVATE(nvan)                                                 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: avan                !! Van Genuchten coeficients a
+                                                                         !!  @tex $(mm^{-1})$ @endtex
+!$OMP THREADPRIVATE(avan)                                                
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: mcr                 !! Residual volumetric water content
+                                                                         !!  @tex $(m^{3} m^{-3})$ @endtex
+!$OMP THREADPRIVATE(mcr)                                                 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: mcs                 !! Saturated volumetric water content
+                                                                         !!  @tex $(m^{3} m^{-3})$ @endtex
+!$OMP THREADPRIVATE(mcs)                                                  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: ks                  !! Hydraulic conductivity at saturation
+                                                                         !!  @tex $(mm d^{-1})$ @endtex
+!$OMP THREADPRIVATE(ks)                                                  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: pcent               !! Fraction of saturated volumetric soil moisture above 
+                                                                         !! which transpir is max (0-1, unitless)
+!$OMP THREADPRIVATE(pcent)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: mcf                 !! Volumetric water content at field capacity
+                                                                         !!  @tex $(m^{3} m^{-3})$ @endtex 
+!$OMP THREADPRIVATE(mcf)                                                 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: mcw                 !! Volumetric water content at wilting point
+                                                                         !!  @tex $(m^{3} m^{-3})$ @endtex 
+!$OMP THREADPRIVATE(mcw)                                                 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: mc_awet             !! Vol. wat. cont. above which albedo is cst
+                                                                         !!  @tex $(m^{3} m^{-3})$ @endtex 
+!$OMP THREADPRIVATE(mc_awet)                                             
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: mc_adry             !! Vol. wat. cont. below which albedo is cst
+                                                                         !!  @tex $(m^{3} m^{-3})$ @endtex 
+!$OMP THREADPRIVATE(mc_adry)                                             
+
+  ! Values per grid point
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_water_beg    !! Total amount of water at start of time step
+                                                                         !!  @tex $(kg m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(tot_water_beg)                                       
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_water_end    !! Total amount of water at end of time step
+                                                                         !!  @tex $(kg m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(tot_water_end)                                       
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_flux         !! Total water flux  
+                                                                         !!  @tex $(kg m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(tot_flux)                                            
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_watveg_beg   !! Total amount of water on vegetation at start of time 
+                                                                         !! step @tex $(kg m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(tot_watveg_beg)                                      
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_watveg_end   !! Total amount of water on vegetation at end of time step
+                                                                         !!  @tex $(kg m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(tot_watveg_end)                                      
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_watsoil_beg  !! Total amount of water in the soil at start of time step
+                                                                         !!  @tex $(kg m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(tot_watsoil_beg)                                     
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_watsoil_end  !! Total amount of water in the soil at end of time step
+                                                                         !!  @tex $(kg m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(tot_watsoil_end)                                     
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: snow_beg         !! Total amount of snow at start of time step
+                                                                         !!  @tex $(kg m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(snow_beg)                                            
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: snow_end         !! Total amount of snow at end of time step
+                                                                         !!  @tex $(kg m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(snow_end)                                           
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: delsoilmoist     !! Change in soil moisture @tex $(kg m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(delsoilmoist)                                         
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: delintercept     !! Change in interception storage
+                                                                         !!  @tex $(kg m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(delintercept)                                        
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: delswe           !! Change in SWE @tex $(kg m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(delswe)
+  REAL(r_std),ALLOCATABLE, SAVE, DIMENSION (:)       :: undermcr         !! Nb of tiles under mcr for a given time step
+!$OMP THREADPRIVATE(undermcr) 
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: mask_veget       !! zero/one when veget fraction is zero/higher (1)
+!$OMP THREADPRIVATE(mask_veget)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: mask_soiltile    !! zero/one where soil tile is zero/higher (1)
+!$OMP THREADPRIVATE(mask_soiltile)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: humrelv          !! Water stress index for transpiration
+                                                                         !! for each soiltile x PFT couple (0-1, unitless)
+!$OMP THREADPRIVATE(humrelv)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: vegstressv       !! Water stress index for vegetation growth
+                                                                         !! for each soiltile x PFT couple (0-1, unitless)
+!$OMP THREADPRIVATE(vegstressv)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:,:):: us               !! Water stress index for transpiration 
+                                                                         !! (by soil layer and PFT) (0-1, unitless)
+!$OMP THREADPRIVATE(us)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: precisol         !! Throughfall per PFT 
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(precisol)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: precisol_ns      !! Throughfall per soiltile 
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(precisol_ns)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: ae_ns            !! Bare soil evaporation per soiltile
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(ae_ns)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: evap_bare_lim_ns !! Limitation factor (beta) for bare soil evaporation 
+                                                                         !! per soiltile (used to deconvoluate vevapnu)  
+                                                                         !!  (0-1, unitless) 
+!$OMP THREADPRIVATE(evap_bare_lim_ns)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: free_drain_coef  !! Coefficient for free drainage at bottom
+                                                                         !!  (0-1, unitless) 
+!$OMP THREADPRIVATE(free_drain_coef) 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: zwt_force        !! Prescribed water table depth (m)
+!$OMP THREADPRIVATE(zwt_force) 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: frac_bare_ns     !! Evaporating bare soil fraction per soiltile
+                                                                         !!  (0-1, unitless)
+!$OMP THREADPRIVATE(frac_bare_ns)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: rootsink         !! Transpiration sink by soil layer and soiltile
+                                                                         !! @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(rootsink)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: subsnowveg       !! Sublimation of snow on vegetation 
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(subsnowveg)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: subsnownobio     !! Sublimation of snow on other surface types  
+                                                                         !! (ice, lakes,...) @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(subsnownobio)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: icemelt          !! Ice melt @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(icemelt)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: subsinksoil      !! Excess of sublimation as a sink for the soil
+                                                                         !! @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(subsinksoil)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: vegtot           !! Total Total fraction of grid-cell covered by PFTs
+                                                                         !! (bare soil + vegetation) (1; 1)
+!$OMP THREADPRIVATE(vegtot)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: resdist          !! Soiltile values from previous time-step (1; 1)
+  
+!$OMP THREADPRIVATE(resdist)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: mx_eau_var       !! Maximum water content of the soil @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(mx_eau_var)
+
+  ! arrays used by cwrr scheme
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: nroot            !! Normalized root length fraction in each soil layer 
+                                                                         !! (0-1, unitless)
+                                                                         !! DIM = nvm * nstm * nslm
+!$OMP THREADPRIVATE(nroot)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: kfact_root       !! Factor to increase Ks towards the surface
+                                                                         !! (unitless)
+                                                                         !! DIM = kjpindex * nslm * nstm
+!$OMP THREADPRIVATE(kfact_root)
+! add three variables by yitong yao 4 Jan 2021 
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: soil_waterinf_ns
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: soil_dtinf_ns
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: soil_infilttmp_ns
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: soil_km_ns
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: soil_smcinfilt_ns
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: soil_resinfilt_ns
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: soil_totalinfilt_ns
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: begin_infilt_ns
+! above added 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: kfact            !! Factor to reduce Ks with depth (unitless)
+                                                                         !! DIM = nslm * nscm
+!$OMP THREADPRIVATE(kfact)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: zz               !! Depth of the calculation nodes (mm) 
+!$OMP THREADPRIVATE(zz)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: dz               !! Internode thickness (mm)
+!$OMP THREADPRIVATE(dz)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: dh               !! Layer thickness (mm)
+!$OMP THREADPRIVATE(dh)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: mc_lin   !! 50 Vol. Wat. Contents to linearize K and D, for each texture 
+                                                                 !!  @tex $(m^{3} m^{-3})$ @endtex
+                                                                 !! DIM = imin:imax * nscm
+!$OMP THREADPRIVATE(mc_lin)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: k_lin    !! 50 values of unsaturated K, for each soil layer and texture
+                                                                 !!  @tex $(mm d^{-1})$ @endtex
+                                                                 !! DIM = imin:imax * nslm * nscm
+!$OMP THREADPRIVATE(k_lin)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: d_lin    !! 50 values of diffusivity D, for each soil layer and texture
+                                                                 !!  @tex $(mm^2 d^{-1})$ @endtex
+                                                                 !! DIM = imin:imax * nslm * nscm
+!$OMP THREADPRIVATE(d_lin)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: a_lin    !! 50 values of the slope in K=a*mc+b, for each soil layer and texture
+                                                                 !!  @tex $(mm d^{-1})$ @endtex
+                                                                 !! DIM = imin:imax * nslm * nscm
+!$OMP THREADPRIVATE(a_lin)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: b_lin    !! 50 values of y-intercept in K=a*mc+b, for each soil layer and texture
+                                                                 !!  @tex $(m^{3} m^{-3})$ @endtex
+                                                                 !! DIM = imin:imax * nslm * nscm
+!$OMP THREADPRIVATE(b_lin)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: humtot   !! Total Soil Moisture @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(humtot)
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION (:)          :: resolv   !! Mask of land points where to solve the diffusion equation
+                                                                 !! (true/false)
+!$OMP THREADPRIVATE(resolv)
+
+!! linarization coefficients of hydraulic conductivity K (hydrol_soil_coef)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: k        !! Hydraulic conductivity K for each soil layer
+                                                                 !!  @tex $(mm d^{-1})$ @endtex
+                                                                 !! DIM = (:,nslm)
+!$OMP THREADPRIVATE(k)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: kk_moy   !! Mean hydraulic conductivity over soiltiles (mm/d)
+!$OMP THREADPRIVATE(kk_moy)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: kk       !! Hydraulic conductivity for each soiltiles (mm/d)
+!$OMP THREADPRIVATE(kk)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: a        !! Slope in K=a*mc+b(:,nslm)
+                                                                 !!  @tex $(mm d^{-1})$ @endtex
+                                                                 !! DIM = (:,nslm)
+!$OMP THREADPRIVATE(a)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: b        !! y-intercept in K=a*mc+b
+                                                                 !!  @tex $(m^{3} m^{-3})$ @endtex
+                                                                 !! DIM = (:,nslm)
+!$OMP THREADPRIVATE(b)
+!! linarization coefficients of hydraulic diffusivity D (hydrol_soil_coef)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: d        !! Diffusivity D for each soil layer
+                                                                 !!  @tex $(mm^2 d^{-1})$ @endtex
+                                                                 !! DIM = (:,nslm)
+!$OMP THREADPRIVATE(d)
+!! matrix coefficients (hydrol_soil_tridiag and hydrol_soil_setup), see De Rosnay (1999), p155-157
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: e        !! Left-hand tridiagonal matrix coefficients
+!$OMP THREADPRIVATE(e)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: f        !! Left-hand tridiagonal matrix coefficients
+!$OMP THREADPRIVATE(f)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: g1       !! Left-hand tridiagonal matrix coefficients
+!$OMP THREADPRIVATE(g1)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: ep       !! Right-hand matrix coefficients
+!$OMP THREADPRIVATE(ep)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: fp       !! Right-hand atrix coefficients
+!$OMP THREADPRIVATE(fp)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: gp       !! Right-hand atrix coefficients
+!$OMP THREADPRIVATE(gp)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: rhs      !! Right-hand system
+!$OMP THREADPRIVATE(rhs)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: srhs     !! Temporarily stored rhs
+!$OMP THREADPRIVATE(srhs)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: tmat             !! Left-hand tridiagonal matrix
+!$OMP THREADPRIVATE(tmat)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: stmat            !! Temporarily stored tmat
+  !$OMP THREADPRIVATE(stmat)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: water2infilt     !! Water to be infiltrated
+                                                                         !! @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(water2infilt)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc              !! Total moisture content per soiltile 
+                                                                         !!  @tex $(kg m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(tmc)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmcr             !! Total moisture constent at residual per soiltile 
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(tmcr)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmcs             !! Total moisture constent at saturation per soiltile 
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(tmcs)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc_litter       !! Total moisture in the litter per soiltile
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(tmc_litter)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tmc_litt_mea     !! Total moisture in the litter over the grid
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(tmc_litt_mea)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc_litter_wilt  !! Total moisture of litter at wilt point per soiltile 
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(tmc_litter_wilt)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc_litter_field !! Total moisture of litter at field cap. per soiltile 
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(tmc_litter_field)
+!!! A CHANGER DANS TOUT HYDROL: tmc_litter_res et sat ne devraient pas dependre de ji - tdo
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc_litter_res   !! Total moisture of litter at residual moisture per soiltile 
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(tmc_litter_res)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc_litter_sat   !! Total moisture of litter at saturation per soiltile 
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(tmc_litter_sat)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc_litter_awet  !! Total moisture of litter at mc_awet per soiltile 
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(tmc_litter_awet)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc_litter_adry  !! Total moisture of litter at mc_adry per soiltile 
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(tmc_litter_adry)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tmc_litt_wet_mea !! Total moisture in the litter over the grid below which 
+                                                                         !! albedo is fixed constant
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(tmc_litt_wet_mea)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tmc_litt_dry_mea !! Total moisture in the litter over the grid above which 
+                                                                         !! albedo is constant
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(tmc_litt_dry_mea)
+  LOGICAL, SAVE                                      :: tmc_init_updated = .FALSE. !! Flag allowing to determine if tmc is initialized.
+!$OMP THREADPRIVATE(tmc_init_updated)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: v1               !! Temporary variable (:)
+!$OMP THREADPRIVATE(v1)
+
+  !! par type de sol :
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: ru_ns            !! Surface runoff per soiltile
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(ru_ns)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: dr_ns            !! Drainage per soiltile
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(dr_ns)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tr_ns            !! Transpiration per soiltile
+!$OMP THREADPRIVATE(tr_ns)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: cvs_over_veg     !! (:,nvm,nstm) old value of vegetmax_soil/veget_max kept 
+                                                                         !! from diag to next split 
+!$OMP THREADPRIVATE(cvs_over_veg)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: vegetmax_soil    !! (:,nvm,nstm) percentage of each veg. type on each soil 
+                                                                         !! of each grid point 
+!$OMP THREADPRIVATE(vegetmax_soil)
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: mc                 !! Total volumetric water content at the calculation nodes
+                                                                         !! (eg : liquid + frozen)
+                                                                         !!  @tex $(m^{3} m^{-3})$ @endtex
+!$OMP THREADPRIVATE(mc)
+   REAL(r_std),ALLOCATABLE, SAVE, DIMENSION(:,:,:)   :: mcl              !! Liquid water content
+                                                                         !!  @tex $(m^{3} m^{-3})$ @endtex
+!$OMP THREADPRIVATE(mcl)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: soilmoist        !! (:,nslm) Mean of each soil layer's moisture
+                                                                         !! across soiltiles
+                                                                         !!  @tex $(kg m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(soilmoist)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: soil_wet         !! Soil wetness above mcw (0-1, unitless)
+!$OMP THREADPRIVATE(soil_wet)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: soil_wet_litter  !! Soil wetness aove mvw in the litter (0-1, unitless)
+!$OMP THREADPRIVATE(soil_wet_litter)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: qflux            !! Diffusive water fluxes between soil layers
+!$OMP THREADPRIVATE(qflux)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: frac_hydro_diag       !! 
+!$OMP THREADPRIVATE(frac_hydro_diag)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: profil_froz_hydro     !! Frozen fraction for each hydrological soil layer
+!$OMP THREADPRIVATE(profil_froz_hydro)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: profil_froz_hydro_ns  !! As  profil_froz_hydro per soiltile
+!$OMP THREADPRIVATE(profil_froz_hydro_ns)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: temp_hydro            !! Temp profile on hydrological levels
+!$OMP THREADPRIVATE(temp_hydro)
+
+!tzjswi
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: swi              !! Soil Wetness Index
+ !$OMP THREADPRIVATE(swi)
+
+!tzjdz (BUT APPLIED FOR PFT2 (&) all trees) 
+!LOGICAL, SAVE                                  :: dyn_nroot_larix = .TRUE. !! dynamic root profile for BoNS to optimize soil moisture usage,similar to Beer et al.2007
+LOGICAL, SAVE                                  :: dyn_nroot_tree = .FALSE. !! dynamic root profile for BoNS to optimize soil moisture usage,similar to Beer et al.2007
+
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: hydrol_initialize
+!!
+!>\BRIEF         Allocate module variables, read from restart file or initialize with default values
+!!
+!! DESCRIPTION :
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+!  SUBROUTINE hydrol_initialize ( kjit,           kjpindex,  index,         rest_id,          &
+!                                 njsc,           soiltile,  veget,         veget_max,        &
+!                                 humrel,         vegstress, drysoil_frac,                    &
+!                                 shumdiag_perma, k_litt,    qsintveg,                        &
+!                                 evap_bare_lim,  snow,      snow_age,      snow_nobio,       &
+!                                 snow_nobio_age, snowrho,   snowtemp,      snowgrain,        &
+!                                 snowdz,         snowheat,  &
+!                                 mc_layh,       mcl_layh,  tmc_layh)
+
+  SUBROUTINE hydrol_initialize ( kjit,           kjpindex,  index, rest_id,          &
+                                 njsc,           soiltile,  veget, veget_max,        &
+                                 humrel,         vegstress, drysoil_frac,            &
+                                 shumdiag_perma, k_litt,    qsintveg,                &
+                                 evap_bare_lim,  snow,      snow_age,  snow_nobio,       &
+                                 snow_nobio_age,  &
+                                 mc_layh,       mcl_layh,  tmc_layh)
+
+
+
+
+
+    !! 0. Variable and parameter declaration
+    !! 0.1 Input variables
+    INTEGER(i_std), INTENT(in)                         :: kjit             !! Time step number 
+    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
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)   :: njsc             !! Index of the dominant soil textural class in the grid cell (1-nscm, unitless)
+    REAL(r_std),DIMENSION (kjpindex,nstm), INTENT (in) :: soiltile         !! Fraction of each soil tile (0-1, unitless)
+    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)
+
+    !! 0.2 Output variables
+    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 (out)  :: shumdiag_perma !! Percent of porosity filled with water (mc/mcs) used for the thermal computations
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)       :: k_litt         !! litter approximate conductivity
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)   :: qsintveg       !! Water on vegetation due to interception
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)        :: evap_bare_lim  !! Limitation factor for bare soil evaporation
+    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     !! Water balance on ice, lakes, .. [Kg/m^2]
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (out):: snow_nobio_age !! Snow age on ice, lakes, ...
+
+! tzjwb
+!    REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(out) :: snowrho        !! Snow density
+!    REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(out) :: snowtemp       !! Snow temperature
+!    REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(out) :: snowgrain      !! Snow grainsize
+!    REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(out) :: snowdz         !! Snow layer thickness
+!    REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(out) :: snowheat       !! Snow heat content
+    REAL(r_std),DIMENSION (kjpindex,nslm), INTENT (out)  :: mc_layh        !! Volumetric moisture content for each layer in hydrol (liquid+ice) m3/m3
+    REAL(r_std),DIMENSION (kjpindex,nslm), INTENT (out)  :: mcl_layh       !! Volumetric moisture content for each layer in hydrol (liquid) m3/m3
+    REAL(r_std),DIMENSION (kjpindex,nslm), INTENT (out)  :: tmc_layh       !! Total soil moisture content for each layer in hydrol (liquid+ice), mm
+    REAL(r_std),DIMENSION (kjpindex)                     :: soilwetdummy   !! Temporary variable never used
+
+
+    !! 0.4 Local variables
+!_ ================================================================================================================================
+
+!    CALL hydrol_init (kjit, kjpindex, index, rest_id, veget_max, soiltile, &
+!         humrel, vegstress, snow,       snow_age,   snow_nobio, snow_nobio_age, qsintveg, &
+!         snowdz, snowgrain, snowrho,    snowtemp,   snowheat, &
+!         drysoil_frac, evap_bare_lim)
+
+! tzjdz
+!CALL getin_p('dyn_nroot_larix',dyn_nroot_larix)
+CALL getin_p('dyn_nroot_tree',dyn_nroot_tree)
+
+! tzjwb
+    CALL hydrol_init (kjit, kjpindex, index, rest_id, veget_max, soiltile, &
+         humrel, vegstress, snow,       snow_age,   snow_nobio, snow_nobio_age, qsintveg,  &
+         drysoil_frac, evap_bare_lim)
+
+   
+    CALL hydrol_var_init (kjpindex, veget, veget_max, &
+         soiltile, njsc, mx_eau_var, shumdiag_perma, k_litt, &
+         drysoil_frac, qsintveg, mc_layh, mcl_layh, tmc_layh) 
+
+    !! Initialize hydrol_alma routine if the variables were not found in the restart file. This is done in the end of 
+    !! hydrol_initialize so that all variables(humtot,..) that will be used are initialized.
+    IF (ALL(tot_watveg_beg(:)==val_exp) .OR.  ALL(tot_watsoil_beg(:)==val_exp) .OR. ALL(snow_beg(:)==val_exp)) THEN
+       ! The output variable soilwetdummy is not calculated at first call to hydrol_alma.
+       CALL hydrol_alma(kjpindex, index, .TRUE., qsintveg, snow, snow_nobio, soilwetdummy)
+    END IF
+    
+    !! If we check the water balance we first save the total amount of water
+    !! X if check_waterbal ==> hydrol_waterbal
+    IF (check_waterbal) CALL hydrol_waterbal_init (kjpindex, qsintveg, snow, snow_nobio)
+    
+  END SUBROUTINE hydrol_initialize
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: hydrol_main
+!!
+!>\BRIEF         
+!!
+!! DESCRIPTION :
+!! - called every time step
+!! - initialization and finalization part are not done in here
+!!
+!! - 1 computes snow  ==> hydrol_snow
+!! - 2 computes vegetations reservoirs  ==> hydrol_vegupd
+!! - 3 computes canopy  ==> hydrol_canop
+!! - 4 computes surface reservoir  ==> hydrol_flood
+!! - 5 computes soil hydrology ==> hydrol_soil
+!! - X if check_waterbal ==> hydrol_waterbal
+!!
+!! IMPORTANT NOTICE : The water fluxes are used in their integrated form, over the time step 
+!! dt_sechiba, with a unit of kg m^{-2}.
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+!  SUBROUTINE hydrol_main (kjit, kjpindex, &
+!       & index, indexveg, indexsoil, indexlayer, indexnbdl, &
+!       & temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max, njsc, &
+!       & qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,  &
+!       & tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, &
+!       & humrel, vegstress, drysoil_frac, evapot, evapot_penm, evap_bare_lim, flood_frac, flood_res, &
+!       & shumdiag,shumdiag_perma, k_litt, litterhumdiag, soilcap, soiltile, reinf_slope, rest_id, hist_id, hist2_id,&
+!       & stempdiag, &
+!       & temp_air, pb, u, v, swnet, pgflux, &
+!       & snowrho,snowtemp,snowgrain,snowdz,snowheat,snowliq, &
+!       & grndflux,gtemp,tot_bare_soil, &
+!       & lambda_snow,cgrnd_snow,dgrnd_snow,temp_sol_add, &
+!       & mc_layh, mcl_layh, tmc_layh )
+
+!tzjwb
+  SUBROUTINE hydrol_main (kjit, kjpindex, &
+       & index, indexveg, indexsoil, indexlayer, indexnbdl, &
+       & temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio,vevapwet, veget, veget_max, njsc, &
+       & qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age,snow_nobio, snow_nobio_age,  &
+       & tot_melt, transpir, precip_rain, precip_snow, returnflow,reinfiltration, irrigation, &
+       & humrel, vegstress, drysoil_frac, evapot, evapot_penm, evap_bare_lim,flood_frac, flood_res, &
+       & shumdiag,shumdiag_perma, k_litt, litterhumdiag, soilcap, soiltile, reinf_slope, rest_id, hist_id, hist2_id,&
+       & stempdiag, &
+       & temp_air, pb, u, v, swnet, pgflux, &
+       & gtemp,tot_bare_soil, temp_sol_add, &
+       & mc_layh, mcl_layh, tmc_layh,control_in, swc,ksave )
+! tzjswc add swc
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+  
+    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
+    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
+    INTEGER(i_std),DIMENSION (kjpindex*nslm), INTENT (in):: indexnbdl      !! Indeces of the points on the 3D map for of diagnostic 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 (from the 
+                                                                           !! bottom) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: reinfiltration   !! Routed water which comes back into the soil (at the 
+                                                                           !! top) 
+    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
+
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)   :: njsc             !! Index of the dominant soil textural class in the grid cell (1-nscm, unitless)
+    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) :: soiltile         !! Fraction of each soil tile (0-1, unitless)
+    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)      :: reinf_slope      !! Slope coef
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: evapot           !! Soil Potential Evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: evapot_penm      !! Soil Potential Evaporation Correction
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: flood_frac       !! flood fraction
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in) :: stempdiag        !! Diagnostic temp profile from thermosoil
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)       :: temp_air         !! Air temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)       :: u,v              !! Horizontal wind speed
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)       :: pb               !! Surface pressure
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)       :: swnet            !! Net shortwave radiation
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)       :: pgflux           !! Net energy into snowpack
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)       :: gtemp            !! First soil layer temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)       :: tot_bare_soil    !! Total evaporating bare soil fraction 
+!tzjwb
+!    REAL(r_std),DIMENSION (kjpindex), INTENT(in)       :: lambda_snow      !! Coefficient of the linear extrapolation of surface temperature 
+
+!    REAL(r_std),DIMENSION (kjpindex,nsnow), INTENT (in):: cgrnd_snow       !! Integration coefficient for snow numerical scheme
+!    REAL(r_std),DIMENSION (kjpindex,nsnow), INTENT (in):: dgrnd_snow       !! Integration coefficient for snow numerical scheme
+   TYPE(control_type), INTENT (in)                    :: control_in       !! Flags that (de)activate parts of the model
+    !! 0.2 Output variables
+
+    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 (out):: shumdiag         !! Relative soil moisture in each soil layer 
+                                                                           !! with respect to (mcf-mcw)
+                                                                           !! (unitless; can be out of 0-1)
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out):: shumdiag_perma   !! Percent of porosity filled with water (mc/mcs) used for the thermal computations 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: k_litt           !! litter approximate conductivity
+    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), INTENT (out)     :: floodout         !! Flux out of floodplains
+! tzjswc    
+   REAL(r_std),DIMENSION (kjpindex,nslm,nstm), INTENT(inout) ::swc          !! Soil water content (copy of mc)
+   REAL(r_std),DIMENSION (kjpindex,nslm,nstm), INTENT(inout) ::ksave          !! Soil conductivity (mm/d) copy of k
+
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(inout):: qsintveg         !! Water on vegetation due to interception
+    REAL(r_std),DIMENSION (kjpindex), INTENT(inout)    :: evap_bare_lim    !! Limitation factor (beta) for bare soil evaporation    
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(inout):: humrel           !! Relative humidity
+    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)   :: vevapflo         !! Floodplain evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: flood_res        !! flood reservoir estimate
+    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 (out)         :: runoff       !! Complete surface runoff
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)         :: drainage     !! Drainage
+! tzjwb
+!    REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(inout) :: snowrho      !! Snow density
+!    REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(inout) :: snowtemp     !! Snow temperature
+!    REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(inout) :: snowgrain    !! Snow grainsize
+!    REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(inout) :: snowdz       !! Snow layer thickness
+!    REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(inout) :: snowheat     !! Snow heat content
+!    REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(out)   :: snowliq      !! Snow liquid content (m)
+!    REAL(r_std), DIMENSION (kjpindex), INTENT(out)         :: grndflux     !! Net flux into soil W/m2
+    REAL(r_std),DIMENSION (kjpindex,nslm), INTENT(out)     :: mc_layh      !! Volumetric moisture content for each layer in hydrol(liquid + ice) [m3/m3)]
+    REAL(r_std),DIMENSION (kjpindex,nslm), INTENT(out)     :: mcl_layh     !! Volumetric moisture content for each layer in hydrol(liquid) [m3/m3]
+    REAL(r_std),DIMENSION (kjpindex,nslm), INTENT(out)     :: tmc_layh     !! Total soil moisture content for each layer in hydrol(liquid + ice) [mm]
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)       :: temp_sol_add !! additional surface temperature due to the melt of first layer
+                                                                           !! at the present time-step @tex ($K$) @endtex
+
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                     :: jst              !! Index of soil tiles (unitless, 1-3)
+    INTEGER(i_std)                                     :: jsl              !! Index of soil layers (unitless)
+    INTEGER(i_std)                                     :: ji, jv
+    INTEGER(i_std)                                     :: itopmax          !! Indicating the layer corresponding to 0.1m depth
+    REAL(r_std),DIMENSION (kjpindex)                   :: soilwet          !! A temporary diagnostic of soil wetness
+    REAL(r_std),DIMENSION (kjpindex)                   :: snowdepth        !! Depth of snow layer, only for diagnostics with ok_explicitsnow=n
+    REAL(r_std),DIMENSION (kjpindex)                   :: njsc_tmp         !! Temporary REAL value for njsc to write it
+    REAL(r_std), DIMENSION (kjpindex)                  :: snowmelt         !! Snow melt [mm/dt_sechiba]
+    REAL(r_std), DIMENSION (kjpindex,nstm)             :: tmc_top          !! Moisture content in the itopmax upper layers, per tile
+    REAL(r_std), DIMENSION (kjpindex)                  :: humtot_top       !! Moisture content in the itopmax upper layers, for diagnistics
+    REAL(r_std), DIMENSION(kjpindex)                   :: histvar          !! Temporary variable when computations are needed
+    REAL(r_std), DIMENSION (kjpindex,nvm)              :: frac_bare        !! Fraction(of veget_max) of bare soil in each vegetation type
+    INTEGER(i_std), DIMENSION(kjpindex*imax)           :: mc_lin_axis_index
+    REAL(r_std), DIMENSION(kjpindex)                   :: twbr             !! Grid-cell mean of TWBR Total Water Budget Residu[kg/m2/dt]
+    REAL(r_std),DIMENSION (kjpindex,nslm)              :: land_nroot       !! To ouput the grid-cell mean of nroot
+    REAL(r_std),DIMENSION (kjpindex,nslm)              :: land_dh          !! To ouput the soil layer thicknes on all grid points [m]
+    REAL(r_std),DIMENSION (kjpindex,nslm)              :: land_mcs         !! To ouput the grid-cell mean of mcs
+   
+
+!_ ================================================================================================================================
+
+    !! 3. Shared time step
+! tzjwb
+!    IF (printlev>=3) WRITE (numout,*) 'hydrol pas de temps = ',dt_sechiba
+
+    !! Calculate kfact_root
+    !! An exponential factor is used to increase ks near the surface depending on the amount of roots in the soil 
+    !! through a geometric average over the vegets
+    !! This comes from the PhD thesis of d'Orgeval, 2006, p82; d'Orgeval et al. 2008, Eqs. 3-4
+    !! (Calibrated against Hapex-Sahel measurements)
+    !! Since rev 2916: veget_max/2 is used instead of veget
+    kfact_root(:,:,:) = un
+    
+    soil_waterinf_ns(:,:,:)=zero
+    soil_dtinf_ns(:,:,:)=zero
+    soil_infilttmp_ns(:,:,:)=zero
+    soil_km_ns(:,:,:)=zero
+    soil_smcinfilt_ns(:,:,:)=zero
+    soil_resinfilt_ns(:,:,:)=zero
+    soil_totalinfilt_ns(:,:)=zero
+    begin_infilt_ns(:,:)=zero
+!    DO jsl = 1, nslm
+!       DO jv = 2, nvm
+!          jst = pref_soil_veg(jv)
+!          DO ji = 1, kjpindex
+!             IF(soiltile(ji,jst) .GT. min_sechiba) THEN
+!                kfact_root(ji,jsl,jst) = kfact_root(ji,jsl,jst) * &
+!                     & MAX((MAXVAL(ks_usda)/ks(njsc(ji)))**(- veget_max(ji,jv)/2 * (humcste(jv)*zz(jsl)/mille - un)/deux), &
+!                     un) 
+!             ENDIF
+!          ENDDO
+!       ENDDO
+!    ENDDO
+
+    DO jsl = 1, nslm
+       DO jv = 2, nvm
+          jst = pref_soil_veg(jv)
+          DO ji = 1, kjpindex
+             IF(soiltile(ji,jst) .GT. min_sechiba) THEN
+                kfact_root(ji,jsl,jst) = kfact_root(ji,jsl,jst) * &
+                     & MAX((MAXVAL(ks_usda)/ks(njsc(ji)))**(- veget_max(ji,jv)/2* (humcste(jv)*zz(jsl)/mille - un)/deux), &
+                     un)
+             ! increase the minimum kfact_root by yitong yao in 3 Jan 2021
+                IF (pres_kfact .EQ. 1) THEN 
+                        IF (kfact_root(ji,jsl,jst) .LT. 1.3) THEN 
+                        kfact_root(ji,jsl,jst)=min_kfactroot
+                        ENDIF
+                ENDIF
+             ! above modified
+!            WRITE(*,*) "vegetmaxsoilcalc",vegetmax_soil(ji,jv,jst)
+!            WRITE(*,*) "vegetmax",veget_max(ji,jv)
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDDO
+    !write(*,*) 'njsc-ks',njsc(1)
+    !write(*,*) 'ks_usda',ks_usda,' ks',ks(njsc(1))
+!WRITE(*,*) 'kfact_root soil',kfact_root(:,:,2)
+    ! 
+    !! 3.1 Calculate snow processes with explicit method or bucket snow model
+    !@FM IF (ok_explicitsnow) THEN
+    !@FM   ! Explicit snow model
+    !@FM   IF (printlev>=3) WRITE (numout,*) ' ok_explicitsnow : use multi-snow layer '
+    !@FM   CALL explicitsnow_main(kjpindex,    precip_rain,  precip_snow,   temp_air,    pb,       &
+    !@FM                          u,           v,            temp_sol_new,  soilcap,     pgflux,   &
+    !@FM                          frac_nobio,  totfrac_nobio,gtemp,          &
+    !@FM                          lambda_snow, cgrnd_snow,   dgrnd_snow,                           & 
+    !@FM                          vevapsno,    snow_age,     snow_nobio_age,snow_nobio,  snowrho,  &
+    !@FM                          snowgrain,   snowdz,       snowtemp,      snowheat,    snow,     &
+    !@FM                          temp_sol_add,          					       &
+    !@FM                          snowliq,     subsnownobio, grndflux,      snowmelt,    tot_melt, &
+    !@FM                          subsinksoil)            
+    !@FMELSE
+       ! Bucket snow model
+       CALL hydrol_snow(kjpindex, precip_rain, precip_snow, temp_sol_new, soilcap, &
+            frac_nobio, totfrac_nobio, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age, &
+            tot_melt, snowdepth,snowmelt)
+    !@FMEND IF
+        
+    !
+    !! 3.2 computes vegetations reservoirs  ==>hydrol_vegupd
+    CALL hydrol_vegupd(kjpindex, veget, veget_max, soiltile, qsintveg, resdist, frac_bare)
+
+    !
+    !! 3.3 computes canopy  ==>hydrol_canop
+    CALL hydrol_canop(kjpindex, precip_rain, vevapwet, veget_max, veget, qsintmax, qsintveg,precisol,tot_melt)
+
+    !
+    !! 3.4 computes surface reservoir  ==>hydrol_flood
+    CALL hydrol_flood(kjpindex,  vevapflo, flood_frac, flood_res, floodout)
+
+    !
+    !! 3.5 computes soil hydrology ==>hydrol_soil
+
+    CALL hydrol_soil(kjpindex, veget_max, soiltile, njsc, reinf_slope,  &
+         transpir, vevapnu, evapot, evapot_penm, runoff, drainage, & 
+         returnflow, reinfiltration, irrigation, &
+         tot_melt,evap_bare_lim, shumdiag, shumdiag_perma, &
+         k_litt, litterhumdiag, humrel, vegstress, drysoil_frac,&
+!         stempdiag,snow,snowdz, tot_bare_soil, mc_layh, mcl_layh, tmc_layh)
+         stempdiag,snow,tot_bare_soil, mc_layh, mcl_layh, tmc_layh, swc, ksave,soil_waterinf_ns, soil_dtinf_ns, soil_infilttmp_ns, soil_km_ns, soil_smcinfilt_ns, soil_totalinfilt_ns, begin_infilt_ns, soil_resinfilt_ns)
+
+    ! 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, veget_max, totfrac_nobio, &
+            & qsintveg, snow,snow_nobio, precip_rain, precip_snow, returnflow, reinfiltration, &
+            & irrigation, tot_melt, vevapwet, transpir, vevapnu, vevapsno, vevapflo, floodout, runoff, drainage)
+    ENDIF
+
+    !! 4 write out file  ==> hydrol_alma/histwrite(*)
+    !
+    ! If we use the ALMA standards
+    CALL hydrol_alma(kjpindex, index, .FALSE., qsintveg, snow, snow_nobio, soilwet)
+    
+
+    ! Calcuate the moisture in the upper itopmax layers (humtot_top): 
+    ! For ORCHIDEE with nslm=11 and zmaxh=2 this means the upper 10 cm. 
+    ! We compute tmc_top as tmc but only for the first itopmax layers. Then we compute a humtot with this variable.
+    ! Note: itopmax should depend on the vertical discretization, to be done. 
+    itopmax=6
+    DO jst=1,nstm
+       DO ji=1,kjpindex
+          tmc_top(ji,jst) = dz(2) * ( trois*mc(ji,1,jst) + mc(ji,2,jst) )/huit
+          DO jsl = 2, itopmax
+             tmc_top(ji,jst) = tmc_top(ji,jst) + dz(jsl) * (trois*mc(ji,jsl,jst)+mc(ji,jsl-1,jst))/huit &
+                  + dz(jsl+1) * (trois*mc(ji,jsl,jst)+mc(ji,jsl+1,jst))/huit
+          ENDDO
+       ENDDO
+    ENDDO
+    humtot_top(:) = zero
+    DO jst=1,nstm
+       DO ji=1,kjpindex
+          humtot_top(ji) = humtot_top(ji) + soiltile(ji,jst) * tmc_top(ji,jst)
+       ENDDO
+    ENDDO
+
+    ! Calculate the Total Water Budget Residu (in kg/m2 over dt_sechibo)
+
+    ! Consistent with hydrol_waterbal for the use of vegtot
+    ! snow_nobio included in delswe
+    ! Does not include the routing reservoirs, although the flux to/from routing are integrated
+    ! AD16*** Normally, equation is correct if vegtot=1, else...?
+    DO ji=1,kjpindex
+       twbr(ji) = (vegtot(ji)*delsoilmoist(ji) + delintercept(ji) + delswe(ji)) &
+            - ( precip_rain(ji) + precip_snow(ji) + irrigation(ji) + floodout(ji) &
+            + returnflow(ji) + reinfiltration(ji) ) &
+            + ( runoff(ji) + drainage(ji) + SUM(vevapwet(ji,:)) &
+            + SUM(transpir(ji,:)) + vevapnu(ji) + vevapsno(ji) + vevapflo(ji) ) 
+    ENDDO
+    ! Transform unit from kg/m2/dt to kg/m2/s (or mm/s)
+    CALL xios_orchidee_send_field("twbr",twbr/dt_sechiba)
+    CALL xios_orchidee_send_field("undermcr",undermcr) ! nb of tiles undermcr at end of timestep
+
+    ! Calculate land_nroot : grid-cell mean of nroot 
+    ! Here use only nroot(jv,1,jsl) with jst=1 as nroot is the same for all soiltile
+    ! Do not treat PFT1 because it has no roots
+    land_nroot(:,:) = zero
+    DO jsl=1,nslm
+       DO jv=2,nvm
+          DO ji=1,kjpindex
+               IF ( vegtot(ji) > min_sechiba ) THEN 
+               land_nroot(ji,jsl) = land_nroot(ji,jsl) + veget_max(ji,jv) * nroot(jv,1,jsl) / vegtot(ji) 
+            END IF
+          END DO
+       ENDDO
+    ENDDO
+    CALL xios_orchidee_send_field("nroot",land_nroot)   
+
+!WRITE(*,*) "nroot land tzjh", land_nroot
+!WRITE(*,*) "nroot tzjh", nroot
+
+    DO jsl=1,nslm
+       land_dh(:,jsl)=dh(jsl)/mille
+    ENDDO
+    CALL xios_orchidee_send_field("dh",land_dh)
+
+    land_mcs(:,:) = zero
+    DO jsl=1,nslm
+       DO jst=1,nstm
+          DO ji=1,kjpindex
+             land_mcs(ji,jsl) = land_mcs(ji,jsl) + soiltile(ji,jst) * tmcs(ji,jst)
+          ENDDO
+       ENDDO
+    ENDDO
+    CALL xios_orchidee_send_field("mcs",land_mcs/(zmaxh* mille)) ! in m3/m3
+    CALL xios_orchidee_send_field("water2infilt",water2infilt)   
+    CALL xios_orchidee_send_field("mc",mc)
+    CALL xios_orchidee_send_field("kfact_root",kfact_root)
+    CALL xios_orchidee_send_field("vegetmax_soil",vegetmax_soil)
+    CALL xios_orchidee_send_field("evapnu_soil",ae_ns/dt_sechiba)
+    CALL xios_orchidee_send_field("drainage_soil",dr_ns/dt_sechiba)
+    CALL xios_orchidee_send_field("transpir_soil",tr_ns/dt_sechiba)
+    CALL xios_orchidee_send_field("runoff_soil",ru_ns/dt_sechiba)
+    CALL xios_orchidee_send_field("humrel",humrel)     
+    CALL xios_orchidee_send_field("drainage",drainage/dt_sechiba) ! [kg m-2 s-1]
+    CALL xios_orchidee_send_field("runoff",runoff/dt_sechiba) ! [kg m-2 s-1]
+    CALL xios_orchidee_send_field("precisol",precisol/dt_sechiba)
+    CALL xios_orchidee_send_field("precip_rain",precip_rain/dt_sechiba)
+    CALL xios_orchidee_send_field("precip_snow",precip_snow/dt_sechiba)
+    CALL xios_orchidee_send_field("qsintmax",qsintmax)
+    CALL xios_orchidee_send_field("qsintveg",qsintveg)
+    CALL xios_orchidee_send_field("qsintveg_tot",SUM(qsintveg(:,:),dim=2))
+    histvar(:)=(precip_rain(:)-SUM(precisol(:,:),dim=2))
+    CALL xios_orchidee_send_field("prveg",histvar/dt_sechiba)
+
+! tzjwb check code avant CALL
+! xios_orchidee_send_field("floodout",floodout*one_day/dt_sechiba)
+    IF ( control_in%do_floodplains ) THEN
+       CALL xios_orchidee_send_field("floodout",floodout/dt_sechiba)
+    END IF
+
+    IF (check_waterbal) THEN
+       CALL xios_orchidee_send_field("tot_flux",tot_flux/dt_sechiba)
+    END IF
+
+    CALL xios_orchidee_send_field("snowmelt",snowmelt/dt_sechiba)
+    CALL xios_orchidee_send_field("tot_melt",tot_melt/dt_sechiba)
+
+    CALL xios_orchidee_send_field("soilmoist",soilmoist)
+    CALL xios_orchidee_send_field("tmc",tmc)
+    CALL xios_orchidee_send_field("humtot",humtot)
+    CALL xios_orchidee_send_field("humtot_top",humtot_top)
+
+! tzjwb
+!    IF (ok_explicitsnow) THEN
+!       CALL xios_orchidee_send_field("snowdz",snowdz)
+!    ELSE
+        CALL xios_orchidee_send_field("snowdz",snowdepth)
+!    END IF
+
+    CALL xios_orchidee_send_field("frac_bare",frac_bare)
+
+    CALL xios_orchidee_send_field("soilwet",soilwet)
+    CALL xios_orchidee_send_field("delsoilmoist",delsoilmoist)
+    CALL xios_orchidee_send_field("delswe",delswe)
+    CALL xios_orchidee_send_field("delintercept",delintercept)  
+
+    IF (ok_freeze_cwrr) THEN
+       CALL xios_orchidee_send_field("profil_froz_hydro",profil_froz_hydro)
+       CALL xios_orchidee_send_field("temp_hydro",temp_hydro)
+       CALL xios_orchidee_send_field("kk_moy",kk_moy)
+    END IF
+    CALL xios_orchidee_send_field("profil_froz_hydro_ns", profil_froz_hydro_ns)
+
+    IF ( .NOT. almaoutput ) THEN
+!       CALL histwrite_p(hist_id, 'frac_bare', kjit, frac_bare, kjpindex*nvm, indexveg)
+
+       DO jst=1,nstm
+          ! var_name= "mc_1" ... "mc_3"
+          WRITE (var_name,"('moistc_',i1)") jst
+          CALL histwrite_p(hist_id, TRIM(var_name), kjit,mc(:,:,jst), kjpindex*nslm, indexlayer)
+
+          ! var_name= "kfactroot_1" ... "kfactroot_3"
+          WRITE (var_name,"('kfactroot_',i1)") jst
+          CALL histwrite_p(hist_id, TRIM(var_name), kjit, kfact_root(:,:,jst), kjpindex*nslm, indexlayer)
+          ! three outputs added by yitong yao 4 Jan 2021
+          WRITE (var_name,"('soilwaterinf_',i1)") jst
+          CALL histwrite_p(hist_id, TRIM(var_name), kjit, soil_waterinf_ns(:,:,jst), kjpindex*nslm, indexlayer)
+          
+          WRITE (var_name,"('soildtinf_',i1)") jst
+          CALL histwrite_p(hist_id, TRIM(var_name), kjit, soil_dtinf_ns(:,:,jst), kjpindex*nslm, indexlayer)
+
+          WRITE (var_name,"('soilinfilttmp_',i1)") jst
+          CALL histwrite_p(hist_id, TRIM(var_name), kjit, soil_infilttmp_ns(:,:,jst), kjpindex*nslm, indexlayer)
+
+          WRITE (var_name,"('soilkm_',i1)") jst
+          CALL histwrite_p(hist_id, TRIM(var_name), kjit, soil_km_ns(:,:,jst), kjpindex*nslm, indexlayer)
+
+          WRITE (var_name,"('soilsmcinfilt_',i1)") jst
+          CALL histwrite_p(hist_id, TRIM(var_name), kjit, soil_smcinfilt_ns(:,:,jst), kjpindex*nslm, indexlayer)
+
+          WRITE (var_name,"('soilresinfilt_',i1)") jst
+          CALL histwrite_p(hist_id, TRIM(var_name), kjit, soil_resinfilt_ns(:,:,jst), kjpindex*nslm, indexlayer)
+
+          ! above added by yitong yao 
+          ! var_name= "vegetsoil_1" ... "vegetsoil_3"
+          WRITE (var_name,"('vegetsoil_',i1)") jst
+          CALL histwrite_p(hist_id, TRIM(var_name), kjit,vegetmax_soil(:,:,jst), kjpindex*nvm, indexveg)
+       ENDDO
+       CALL histwrite_p(hist_id, 'evapnu_soil', kjit, ae_ns, kjpindex*nstm, indexsoil)
+       ! added by yitong in Nov 26 2020 
+       !CALL histwrite_p(hist_id, 'free_drain_coef_o', kjit, free_drain_coef, kjpindex*nstm, indexsoil)
+       ! added above 
+       CALL histwrite_p(hist_id, 'drainage_soil', kjit, dr_ns, kjpindex*nstm, indexsoil)
+       CALL histwrite_p(hist_id, 'transpir_soil', kjit, tr_ns, kjpindex*nstm, indexsoil)
+       CALL histwrite_p(hist_id, 'runoff_soil', kjit, ru_ns, kjpindex*nstm, indexsoil)
+       CALL histwrite_p(hist_id, 'humtot_soil', kjit, tmc, kjpindex*nstm, indexsoil)
+       ! 
+       CALL histwrite_p(hist_id, 'soiltotalinfilt', kjit, soil_totalinfilt_ns, kjpindex*nstm,indexsoil)
+       CALL histwrite_p(hist_id, 'begininfilt', kjit, begin_infilt_ns,kjpindex*nstm,indexsoil)
+       !
+ !tzjswi     
+    CALL histwrite_p(hist_id,"twbr",kjit,twbr/dt_sechiba,kjpindex, index)
+ 
+      ! mrso is a perfect duplicate of humtot
+       CALL histwrite_p(hist_id, 'humtot', kjit, humtot, kjpindex, index)
+       CALL histwrite_p(hist_id, 'mrso', kjit, humtot, kjpindex, index)
+       CALL histwrite_p(hist_id, 'mrsos', kjit, humtot_top, kjpindex, index)
+       njsc_tmp(:)=njsc(:)
+       CALL histwrite_p(hist_id, 'soilindex', kjit, njsc_tmp, kjpindex, index)
+       CALL histwrite_p(hist_id, 'humrel',   kjit, humrel,   kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'drainage', kjit, drainage, kjpindex, index)
+       ! NB! According to histdef in intersurf, the variables 'runoff' and 'mrros' have different units
+       CALL histwrite_p(hist_id, 'runoff', kjit, runoff, kjpindex, index)
+       CALL histwrite_p(hist_id, 'mrros', kjit, runoff, kjpindex, index)
+       histvar(:)=(runoff(:)+drainage(:))
+       CALL histwrite_p(hist_id, 'mrro', kjit, histvar, kjpindex, index)
+       CALL histwrite_p(hist_id, 'precisol', kjit, precisol, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'rain', kjit, precip_rain, kjpindex, index)
+! tzjswi
+       CALL histwrite_p(hist_id, 'swi', kjit, swi, kjpindex, index)
+
+       histvar(:)=(precip_rain(:)-SUM(precisol(:,:),dim=2))
+       CALL histwrite_p(hist_id, 'prveg', kjit, histvar, kjpindex, index)
+
+       CALL histwrite_p(hist_id, 'snowf', kjit, precip_snow, kjpindex, index)
+       CALL histwrite_p(hist_id, 'qsintmax', kjit, qsintmax, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'qsintveg', kjit, qsintveg, kjpindex*nvm, indexveg)
+ !      CALL histwrite_p(hist_id, 'snowmelt',kjit,snowmelt,kjpindex,index)
+ !      CALL histwrite_p(hist_id, 'shumdiag_perma',kjit,shumdiag_perma,kjpindex*nbdl,indexnbdl)
+
+       IF (control_in%do_floodplains ) THEN
+          CALL histwrite_p(hist_id, 'floodout', kjit, floodout, kjpindex, index)
+       ENDIF
+       !
+
+
+       IF ( hist2_id > 0 ) THEN
+          DO jst=1,nstm
+             ! var_name= "mc_1" ... "mc_3"
+             WRITE (var_name,"('moistc_',i1)") jst
+             CALL histwrite_p(hist2_id, TRIM(var_name), kjit,mc(:,:,jst), kjpindex*nslm, indexlayer)
+
+             ! var_name= "kfactroot_1" ... "kfactroot_3"
+             WRITE (var_name,"('kfactroot_',i1)") jst
+             CALL histwrite_p(hist2_id, TRIM(var_name), kjit, kfact_root(:,:,jst), kjpindex*nslm, indexlayer)
+
+           ! three outputs added by yitong yao 4 Jan 2021
+          WRITE (var_name,"('soilwaterinf_',i1)") jst
+          CALL histwrite_p(hist2_id, TRIM(var_name), kjit, soil_waterinf_ns(:,:,jst), kjpindex*nslm, indexlayer)
+
+          WRITE (var_name,"('soildtinf_',i1)") jst
+          CALL histwrite_p(hist2_id, TRIM(var_name), kjit, soil_dtinf_ns(:,:,jst), kjpindex*nslm, indexlayer)
+
+          WRITE (var_name,"('soilinfilttmp_',i1)") jst
+          CALL histwrite_p(hist2_id, TRIM(var_name), kjit, soil_infilttmp_ns(:,:,jst), kjpindex*nslm, indexlayer)
+
+          WRITE (var_name,"('soilkm_',i1)") jst
+          CALL histwrite_p(hist2_id, TRIM(var_name), kjit,soil_km_ns(:,:,jst), kjpindex*nslm, indexlayer)
+
+        WRITE (var_name,"('soilsmcinfilt_',i1)") jst
+          CALL histwrite_p(hist2_id, TRIM(var_name), kjit, soil_smcinfilt_ns(:,:,jst), kjpindex*nslm, indexlayer)
+          WRITE (var_name,"('soilresinfilt_',i1)") jst
+          CALL histwrite_p(hist2_id, TRIM(var_name), kjit, soil_resinfilt_ns(:,:,jst), kjpindex*nslm, indexlayer)
+
+
+
+          ! above added by yitong yao
+
+
+             ! var_name= "vegetsoil_1" ... "vegetsoil_3"
+             WRITE (var_name,"('vegetsoil_',i1)") jst
+             CALL histwrite_p(hist2_id, TRIM(var_name), kjit,vegetmax_soil(:,:,jst), kjpindex*nvm, indexveg)
+          ENDDO
+          CALL histwrite_p(hist2_id, 'evapnu_soil', kjit, ae_ns, kjpindex*nstm, indexsoil)
+          CALL histwrite_p(hist2_id, 'drainage_soil', kjit, dr_ns, kjpindex*nstm, indexsoil)
+          CALL histwrite_p(hist2_id, 'transpir_soil', kjit, tr_ns, kjpindex*nstm, indexsoil)
+          CALL histwrite_p(hist2_id, 'runoff_soil', kjit, ru_ns, kjpindex*nstm, indexsoil)
+          CALL histwrite_p(hist2_id, 'humtot_soil', kjit, tmc, kjpindex*nstm, indexsoil)
+        
+         CALL histwrite_p(hist2_id, 'soiltotalinfilt', kjit, soil_totalinfilt_ns,kjpindex*nstm,indexsoil)
+         CALL histwrite_p(hist2_id, 'begininfilt', kjit,begin_infilt_ns,kjpindex*nstm,indexsoil)
+
+ !         ! mrso is a perfect duplicate of humtot
+          CALL histwrite_p(hist2_id, 'humtot', kjit, humtot, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'mrso', kjit, humtot, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'mrsos', kjit, humtot_top, kjpindex, index)
+          njsc_tmp(:)=njsc(:)
+          CALL histwrite_p(hist2_id, 'soilindex', kjit, njsc_tmp, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'humrel',   kjit, humrel,   kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'drainage', kjit, drainage, kjpindex, index)
+          ! NB! According to histdef in intersurf, the variables 'runoff' and 'mrros' have different units
+          CALL histwrite_p(hist2_id, 'runoff', kjit, runoff, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'mrros', kjit, runoff, kjpindex, index)
+          histvar(:)=(runoff(:)+drainage(:))
+          CALL histwrite_p(hist2_id, 'mrro', kjit, histvar, kjpindex, index)
+
+          IF ( control_in%do_floodplains ) THEN
+             CALL histwrite_p(hist2_id, 'floodout', kjit, floodout, kjpindex, index)
+          ENDIF
+          CALL histwrite_p(hist2_id, 'precisol', kjit, precisol, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'rain', kjit, precip_rain, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'snowf', kjit, precip_snow, kjpindex, index)
+    !      CALL histwrite_p(hist2_id, 'snowmelt',kjit,snowmelt,kjpindex,index)
+          CALL histwrite_p(hist2_id, 'qsintmax', kjit, qsintmax, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'qsintveg', kjit, qsintveg, kjpindex*nvm, indexveg)
+       !tzjswi  
+         CALL histwrite_p(hist2_id, 'swi', kjit, swi, kjpindex, index)
+          IF (check_waterbal) THEN
+             CALL histwrite_p(hist2_id, 'TotWater', kjit, tot_water_end, kjpindex, index)
+             CALL histwrite_p(hist2_id, 'TotWaterFlux', kjit, tot_flux, kjpindex, index)
+          ENDIF
+       ENDIF
+    ELSE
+       CALL histwrite_p(hist_id, 'Snowf', kjit, precip_snow, kjpindex, index)
+       CALL histwrite_p(hist_id, 'Rainf', kjit, precip_rain, kjpindex, index)
+       CALL histwrite_p(hist_id, 'Qs', kjit, runoff, kjpindex, index)
+       CALL histwrite_p(hist_id, 'Qsb', kjit, drainage, kjpindex, index)
+       CALL histwrite_p(hist_id, 'Qsm', kjit, snowmelt, kjpindex, index)
+       CALL histwrite_p(hist_id, 'DelSoilMoist', kjit, delsoilmoist, kjpindex, index)
+       CALL histwrite_p(hist_id, 'DelSWE', kjit, delswe, kjpindex, index)
+       CALL histwrite_p(hist_id, 'DelIntercept', kjit, delintercept, kjpindex, index)
+       !
+       CALL histwrite_p(hist_id, 'SoilMoist', kjit, soilmoist, kjpindex*nslm, indexlayer)
+       CALL histwrite_p(hist_id, 'SoilWet', kjit, soilwet, kjpindex, index)
+       !
+       CALL histwrite_p(hist_id, 'RootMoist', kjit, tot_watsoil_end, kjpindex, index)
+       CALL histwrite_p(hist_id, 'SubSnow', kjit, vevapsno, kjpindex, index)
+! tzjwb
+!       IF (.NOT. ok_explicitsnow) CALL histwrite_p(hist_id, 'SnowDepth', kjit, snowdepth, kjpindex, index)
+!         CALL histwrite_p(hist_id, 'SnowDepth', kjit, snowdepth, kjpindex, index)
+       !
+       IF ( hist2_id > 0 ) THEN
+          CALL histwrite_p(hist2_id, 'Snowf', kjit, precip_snow, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'Rainf', kjit, precip_rain, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'Qs', kjit, runoff, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'Qsb', kjit, drainage, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'Qsm', kjit, snowmelt, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'DelSoilMoist', kjit, delsoilmoist, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'DelSWE', kjit, delswe, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'DelIntercept', kjit, delintercept, kjpindex, index)
+          !
+          CALL histwrite_p(hist2_id, 'SoilMoist', kjit, soilmoist, kjpindex*nslm, indexlayer)
+          CALL histwrite_p(hist2_id, 'SoilWet', kjit, soilwet, kjpindex, index)
+          !
+          CALL histwrite_p(hist2_id, 'RootMoist', kjit, tot_watsoil_end, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'SubSnow', kjit, vevapsno, kjpindex, index)
+          !
+! tzjwb 
+!          IF (.NOT. ok_explicitsnow) CALL histwrite_p(hist2_id, 'SnowDepth', kjit, snowdepth, kjpindex, index)
+!          CALL histwrite_p(hist2_id, 'SnowDepth', kjit, snowdepth, kjpindex, index)
+          ENDIF
+    ENDIF
+
+    IF (ok_freeze_cwrr) THEN
+       CALL histwrite_p(hist_id, 'profil_froz_hydro', kjit,profil_froz_hydro , kjpindex*nslm, indexlayer)
+       DO jst=1,nstm
+          WRITE (var_name,"('profil_froz_hydro_',i1)") jst
+          CALL histwrite_p(hist_id, TRIM(var_name), kjit, profil_froz_hydro_ns(:,:,jst), kjpindex*nslm, indexlayer)
+       ENDDO
+       CALL histwrite_p(hist_id, 'temp_hydro', kjit,temp_hydro , kjpindex*nslm, indexlayer)
+       CALL histwrite_p(hist_id, 'kk_moy', kjit, kk_moy,kjpindex*nslm, indexlayer) ! averaged over soiltiles
+    ENDIF
+
+    IF (first_hydrol_main) THEN 
+       first_hydrol_main=.FALSE.
+    ENDIF
+!tzjwb
+!    IF (printlev>=3) WRITE (numout,*) ' hydrol_main Done '
+
+  END SUBROUTINE hydrol_main
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: hydrol_finalize
+!!
+!>\BRIEF         
+!!
+!! DESCRIPTION : This subroutine writes the module variables and variables calculated in hydrol to restart file
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+!  SUBROUTINE hydrol_finalize( kjit,           kjpindex,   rest_id,  vegstress,  &
+!                              qsintveg,       humrel,     snow,     snow_age, snow_nobio, &
+!                              snow_nobio_age, snowrho,    snowtemp, snowdz,     &
+!                              snowheat,       snowgrain,  &
+!                              drysoil_frac, evap_bare_lim)
+
+! tzjwb
+  SUBROUTINE hydrol_finalize( kjit,           kjpindex,   rest_id,  vegstress,&
+                              qsintveg,       humrel,     snow,     snow_age, snow_nobio, &
+                              snow_nobio_age,  &
+                              drysoil_frac, evap_bare_lim)
+
+
+
+
+    !! 0. Variable and parameter declaration
+    !! 0.1 Input variables
+    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
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: vegstress      !! Veg. moisture stress (only for vegetation growth)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: qsintveg       !! Water on vegetation due to interception
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: humrel
+    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     !! Water balance on ice, lakes, .. [Kg/m^2]
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: snow_nobio_age !! Snow age on ice, lakes, ...
+ ! tzjwb
+ !   REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(in)  :: snowrho        !! Snow density
+ !   REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(in)  :: snowtemp       !! Snow temperature
+ !   REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(in)  :: snowdz         !! Snow layer thickness
+ !   REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(in)  :: snowheat       !! Snow heat content
+ !   REAL(r_std), DIMENSION (kjpindex,nsnow), INTENT(in)  :: snowgrain      !! Snow grainsize
+    REAL(r_std),DIMENSION (kjpindex),INTENT(in)          :: drysoil_frac   !! function of litter wetness
+    REAL(r_std),DIMENSION (kjpindex),INTENT(in)          :: evap_bare_lim
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                       :: jst, jsl
+   
+!_ ================================================================================================================================
+
+
+! tzjwb
+!    IF (printlev>=3) WRITE (numout,*) 'Write 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
+       ! var_name= "mcl_1" ... "mcl_3"
+       WRITE (var_name,"('moistcl_',i1)") jst
+       CALL restput_p(rest_id, var_name, nbp_glo,  nslm, 1, kjit, mcl(:,:,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
+    
+    CALL restput_p(rest_id, 'free_drain_coef', nbp_glo,   nstm, 1, kjit,  free_drain_coef, 'scatter',  nbp_glo, index_g)
+    CALL restput_p(rest_id, 'zwt_force', nbp_glo,   nstm, 1, kjit,  zwt_force, 'scatter',  nbp_glo, index_g)
+    CALL restput_p(rest_id, 'water2infilt', nbp_glo,   nstm, 1, kjit,  water2infilt, 'scatter',  nbp_glo, index_g)
+    CALL restput_p(rest_id, 'ae_ns', nbp_glo,   nstm, 1, kjit,  ae_ns, 'scatter',  nbp_glo, index_g)
+    CALL restput_p(rest_id, 'vegstress', nbp_glo,   nvm, 1, kjit,  vegstress, 'scatter',  nbp_glo, index_g)
+    CALL restput_p(rest_id, 'snow', nbp_glo,   1, 1, kjit,  snow, 'scatter',  nbp_glo, index_g)
+    CALL restput_p(rest_id, 'snow_age', nbp_glo,   1, 1, kjit,  snow_age, 'scatter',  nbp_glo, index_g)
+    CALL restput_p(rest_id, 'snow_nobio', nbp_glo,   nnobio, 1, kjit,  snow_nobio, 'scatter', nbp_glo, index_g)
+    CALL restput_p(rest_id, 'snow_nobio_age', nbp_glo,   nnobio, 1, kjit,  snow_nobio_age, 'scatter', nbp_glo, index_g)
+    CALL restput_p(rest_id, 'qsintveg', nbp_glo, nvm, 1, kjit,  qsintveg, 'scatter',  nbp_glo, index_g)
+    CALL restput_p(rest_id, 'evap_bare_lim_ns', nbp_glo, nstm, 1, kjit,  evap_bare_lim_ns, 'scatter',  nbp_glo, index_g)
+    CALL restput_p(rest_id, 'evap_bare_lim', nbp_glo, 1, 1, kjit,  evap_bare_lim, 'scatter',  nbp_glo, index_g)
+    CALL restput_p(rest_id, 'resdist', nbp_glo, nstm, 1, kjit,  resdist, 'scatter',  nbp_glo, index_g)       
+    CALL restput_p(rest_id, 'drysoil_frac', nbp_glo,   1, 1, kjit, drysoil_frac, 'scatter', nbp_glo, index_g)
+    CALL restput_p(rest_id, 'humrel', nbp_glo,   nvm, 1, kjit,  humrel, 'scatter',  nbp_glo, index_g)
+
+    DO jst=1,nstm
+       ! var_name= "cvs_over_veg_1" ... "cvs_over_veg_3"
+       WRITE (var_name,"('cvs_over_veg_',i1)") jst
+       CALL restput_p(rest_id, var_name, nbp_glo,  nvm, 1, kjit, cvs_over_veg(:,:,jst), 'scatter',  nbp_glo, index_g)
+    END DO
+
+    CALL restput_p(rest_id, 'tot_watveg_beg', nbp_glo,  1, 1, kjit,  tot_watveg_beg, 'scatter',  nbp_glo, index_g)
+    CALL restput_p(rest_id, 'tot_watsoil_beg', nbp_glo, 1, 1, kjit,  tot_watsoil_beg, 'scatter',  nbp_glo, index_g)
+    CALL restput_p(rest_id, 'snow_beg', nbp_glo,        1, 1, kjit,  snow_beg, 'scatter',  nbp_glo, index_g)
+   
+    IF ( check_waterbal ) &
+         CALL restput_p(rest_id, 'tot_water_beg', nbp_glo,   1, 1, kjit,  tot_water_end, 'scatter', nbp_glo, index_g)
+    
+    ! Write variables for explictsnow module to restart file
+! tzjwb
+!    IF (ok_explicitsnow) THEN
+!       CALL explicitsnow_finalize ( kjit,     kjpindex, rest_id,    snowrho,   &
+!                                    snowtemp, snowdz,   snowheat,   snowgrain)
+!    END IF
+
+  END SUBROUTINE hydrol_finalize
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_init
+!!
+!>\BRIEF        Initializations and memory allocation   
+!!
+!! DESCRIPTION  :
+!! - 1 Some initializations
+!! - 2 make dynamic allocation with good dimension
+!! - 2.1 array allocation for soil textur
+!! - 2.2 Soil texture choice
+!! - 3 Other array allocation
+!! - 4 Open restart input file and read data for HYDROLOGIC process
+!! - 5 get restart values if none were found in the restart file
+!! - 6 Vegetation array      
+!! - 7 set humrelv from us
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!!_ hydrol_init
+
+!  SUBROUTINE hydrol_init(kjit, kjpindex, index, rest_id, veget_max, soiltile, &
+!       humrel,  vegstress, snow,       snow_age,   snow_nobio, snow_nobio_age, qsintveg, &
+!       snowdz,  snowgrain, snowrho,    snowtemp,   snowheat, &
+!       drysoil_frac, evap_bare_lim)
+ 
+! tzjwb   
+  SUBROUTINE hydrol_init(kjit, kjpindex, index, rest_id, veget_max, soiltile, &
+       humrel,  vegstress, snow,       snow_age,   snow_nobio, snow_nobio_age, qsintveg, &
+       drysoil_frac, evap_bare_lim)
+    
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT (in)                         :: kjit               !! Time step number 
+    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,nvm), INTENT (in)   :: veget_max          !! Carte de vegetation max
+    REAL(r_std),DIMENSION (kjpindex,nstm), INTENT (in)  :: soiltile           !! Fraction of each soil tile (0-1, unitless)
+
+    !! 0.2 Output variables
+
+    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
+
+! tzjwb
+!    REAL(r_std),DIMENSION (kjpindex,nsnow),INTENT(out)    :: snowdz           !! Snow depth
+!    REAL(r_std),DIMENSION (kjpindex,nsnow),INTENT(out)    :: snowgrain        !! Snow grain size
+!    REAL(r_std),DIMENSION (kjpindex,nsnow),INTENT(out)    :: snowheat         !! Snow heat content
+!    REAL(r_std),DIMENSION (kjpindex,nsnow),INTENT(out)    :: snowtemp         !! Snow temperature
+!    REAL(r_std),DIMENSION (kjpindex,nsnow),INTENT(out)    :: snowrho          !! Snow density
+    REAL(r_std),DIMENSION (kjpindex),INTENT(out)          :: drysoil_frac     !! function of litter wetness
+    REAL(r_std),DIMENSION (kjpindex),INTENT(out)          :: evap_bare_lim
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                     :: ier                   !! Error code
+    INTEGER(i_std)                                     :: ji                    !! Index of land grid cells (1)
+    INTEGER(i_std)                                     :: jv                    !! Index of PFTs (1)
+    INTEGER(i_std)                                     :: jst                   !! Index of soil tiles (1)
+    INTEGER(i_std)                                     :: jsl                   !! Index of soil layers (1)
+    INTEGER(i_std)                                     :: jsc                   !! Index of soil texture (1)
+    INTEGER(i_std), PARAMETER                          :: error_level = 3       !! Error level for consistency check
+
+                                                                                !! Switch to 2 tu turn fatal errors into warnings  
+    REAL(r_std), ALLOCATABLE, DIMENSION (:)            :: free_drain_max        !! Temporary var for initialization of free_drain_coef 
+    REAL(r_std), ALLOCATABLE, DIMENSION (:)            :: zwt_default           !! Temporary variable for initialization of zwt_force
+    LOGICAL                                            :: zforce                !! To test if we force the WT in any of the soiltiles
+
+!_ ================================================================================================================================
+
+    !! 1 Some initializations
+    !
+    !Config Key   = DO_PONDS
+    !Config Desc  = Should we include ponds 
+    !Config Def   = n
+    !Config If    = HYDROL_CWRR
+    !Config Help  = This parameters allows the user to ask the model
+    !Config         to take into account the ponds and return 
+    !Config         the water into the soil moisture. If this is 
+    !Config         activated, then there is no reinfiltration 
+    !Config         computed inside the hydrol module.
+    !Config Units = [FLAG]
+    !
+    doponds = .FALSE.
+    CALL getin_p('DO_PONDS', doponds)
+
+
+    !! 2 make dynamic allocation with good dimension
+
+    !! 2.1 array allocation for soil texture
+
+    ALLOCATE (nvan(nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable nvan','','')
+
+    ALLOCATE (avan(nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable avan','','')
+
+    ALLOCATE (mcr(nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable mcr','','')
+
+    ALLOCATE (mcs(nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable mcs','','')
+
+    ALLOCATE (ks(nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable ks','','')
+
+    ALLOCATE (pcent(nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable pcent','','')
+
+    ALLOCATE (mcf(nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable mcf','','')
+
+    ALLOCATE (mcw(nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable mcw','','')
+    
+    ALLOCATE (mc_awet(nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable mc_awet','','')
+
+    ALLOCATE (mc_adry(nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable mc_adry','','')
+       
+    !!__2.2 Soil texture choose
+
+! tzj texture
+!WRITE(*,*) "nscm",nscm
+    SELECTCASE (nscm)
+    CASE (3)
+              
+       nvan(:) = nvan_fao(:)       
+       avan(:) = avan_fao(:)
+       mcr(:) = mcr_fao(:)
+       mcs(:) = mcs_fao(:)
+       ks(:) = ks_fao(:)
+       pcent(:) = pcent_fao(:)
+       mcf(:) = mcf_fao(:)
+       mcw(:) = mcw_fao(:)
+       mc_awet(:) = mc_awet_fao(:)
+       mc_adry(:) = mc_adry_fao(:)
+    CASE (12)
+       
+       nvan(:) = nvan_usda(:)
+       avan(:) = avan_usda(:)
+       mcr(:) = mcr_usda(:)
+       mcs(:) = mcs_usda(:)
+       ks(:) = ks_usda(:)
+       pcent(:) = pcent_usda(:)
+       mcf(:) = mcf_usda(:)
+       mcw(:) = mcw_usda(:)
+       mc_awet(:) = mc_awet_usda(:)
+       mc_adry(:) = mc_adry_usda(:)
+       
+    CASE DEFAULT
+       WRITE (numout,*) 'Unsupported soil type classification. Choose between zobler and usda according to the map'
+       CALL ipslerr_p(3,'hydrol_init','Unsupported soil type classification. ',&
+            'Choose between zobler and usda according to the map','')
+    ENDSELECT
+
+
+    !! 2.3 Read in the run.def the parameters values defined by the user
+
+    !Config Key   = CWRR_N_VANGENUCHTEN
+    !Config Desc  = Van genuchten coefficient n
+    !Config If    = HYDROL_CWRR
+    !Config Def   = 1.89, 1.56, 1.31
+    !Config Help  = This parameter will be constant over the entire 
+    !Config         simulated domain, thus independent from soil
+    !Config         texture.   
+    !Config Units = [-]
+    CALL getin_p("CWRR_N_VANGENUCHTEN",nvan)
+
+    !! Check parameter value (correct range)
+    IF ( ANY(nvan(:) <= zero) ) THEN
+       CALL ipslerr_p(error_level, "hydrol_init.", &
+            &     "Wrong parameter value for CWRR_N_VANGENUCHTEN.", &
+            &     "This parameter should be positive. ", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+
+    !Config Key   = CWRR_A_VANGENUCHTEN
+    !Config Desc  = Van genuchten coefficient a
+    !Config If    = HYDROL_CWRR
+    !Config Def   = 0.0075, 0.0036, 0.0019
+    !Config Help  = This parameter will be constant over the entire 
+    !Config         simulated domain, thus independent from soil
+    !Config         texture.   
+    !Config Units = [1/mm]  
+    CALL getin_p("CWRR_A_VANGENUCHTEN",avan)
+
+    !! Check parameter value (correct range)
+    IF ( ANY(avan(:) <= zero) ) THEN
+       CALL ipslerr_p(error_level, "hydrol_init.", &
+            &     "Wrong parameter value for CWRR_A_VANGENUCHTEN.", &
+            &     "This parameter should be positive. ", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+
+    !Config Key   = VWC_RESIDUAL
+    !Config Desc  = Residual soil water content
+    !Config If    = HYDROL_CWRR
+    !Config Def   = 0.065, 0.078, 0.095
+    !Config Help  = This parameter will be constant over the entire 
+    !Config         simulated domain, thus independent from soil
+    !Config         texture.   
+    !Config Units = [m3/m3]  
+    CALL getin_p("VWC_RESIDUAL",mcr)
+
+    !! Check parameter value (correct range)
+    IF ( ANY(mcr(:) < zero) .OR. ANY(mcr(:) > 1.)  ) THEN
+       CALL ipslerr_p(error_level, "hydrol_init.", &
+            &     "Wrong parameter value for VWC_RESIDUAL.", &
+            &     "This parameter is ranged between 0 and 1. ", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+    
+    !Config Key   = VWC_SAT
+    !Config Desc  = Saturated soil water content
+    !Config If    = HYDROL_CWRR
+    !Config Def   = 0.41, 0.43, 0.41
+    !Config Help  = This parameter will be constant over the entire 
+    !Config         simulated domain, thus independent from soil
+    !Config         texture.   
+    !Config Units = [m3/m3]  
+    CALL getin_p("VWC_SAT",mcs)
+
+    !! Check parameter value (correct range)
+    IF ( ANY(mcs(:) < zero) .OR. ANY(mcs(:) > 1.) .OR. ANY(mcs(:) <= mcr(:)) ) THEN
+       CALL ipslerr_p(error_level, "hydrol_init.", &
+            &     "Wrong parameter value for VWC_SAT.", &
+            &     "This parameter should be greater than VWC_RESIDUAL and less than 1. ", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+
+    !Config Key   = CWRR_KS 
+    !Config Desc  = Hydraulic conductivity Saturation
+    !Config If    = HYDROL_CWRR 
+    !Config Def   = 1060.8, 249.6, 62.4
+    !Config Help  = This parameter will be constant over the entire 
+    !Config         simulated domain, thus independent from soil
+    !Config         texture.   
+    !Config Units = [mm/d]   
+    CALL getin_p("CWRR_KS",ks)
+
+    !! Check parameter value (correct range)
+    IF ( ANY(ks(:) <= zero) ) THEN
+       CALL ipslerr_p(error_level, "hydrol_init.", &
+            &     "Wrong parameter value for CWRR_KS.", &
+            &     "This parameter should be positive. ", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+
+    !Config Key   = WETNESS_TRANSPIR_MAX
+    !Config Desc  = Soil moisture above which transpir is max
+    !Config If    = HYDROL_CWRR
+    !Config Def   = 0.5, 0.5, 0.5
+    !Config Help  = This parameter is independent from soil texture for
+    !Config         the time being.
+    !Config Units = [-]    
+    CALL getin_p("WETNESS_TRANSPIR_MAX",pcent)
+
+    !! Check parameter value (correct range)
+    IF ( ANY(pcent(:) <= zero) .OR. ANY(pcent(:) > 1.) ) THEN
+       CALL ipslerr_p(error_level, "hydrol_init.", &
+            &     "Wrong parameter value for WETNESS_TRANSPIR_MAX.", &
+            &     "This parameter should be positive and less or equals than 1. ", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+
+    !Config Key   = VWC_FC 
+    !Config Desc  = Volumetric water content field capacity
+    !Config If    = HYDROL_CWRR
+    !Config Def   = 0.32, 0.32, 0.32
+    !Config Help  = This parameter is independent from soil texture for
+    !Config         the time being.
+    !Config Units = [m3/m3]   
+    CALL getin_p("VWC_FC",mcf)
+
+    !! Check parameter value (correct range)
+    IF ( ANY(mcf(:) > mcs(:)) ) THEN
+       CALL ipslerr_p(error_level, "hydrol_init.", &
+            &     "Wrong parameter value for VWC_FC.", &
+            &     "This parameter should be less than VWC_SAT. ", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+
+    !Config Key   = VWC_WP
+    !Config Desc  = Volumetric water content Wilting pt
+    !Config If    = HYDROL_CWRR
+    !Config Def   = 0.10, 0.10, 0.10 
+    !Config Help  = This parameter is independent from soil texture for
+    !Config         the time being.
+    !Config Units = [m3/m3]   
+    CALL getin_p("VWC_WP",mcw)
+
+    !! Check parameter value (correct range)
+    IF ( ANY(mcw(:) > mcf(:)) .OR. ANY(mcw(:) < mcr(:)) ) THEN
+       CALL ipslerr_p(error_level, "hydrol_init.", &
+            &     "Wrong parameter value for VWC_WP.", &
+            &     "This parameter should be greater or equal than VWC_RESIDUAL and less or equal than VWC_SAT.", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+
+    !Config Key   = VWC_MIN_FOR_WET_ALB
+    !Config Desc  = Vol. wat. cont. above which albedo is cst
+    !Config If    = HYDROL_CWRR
+    !Config Def   = 0.25, 0.25, 0.25
+    !Config Help  = This parameter is independent from soil texture for
+    !Config         the time being.
+    !Config Units = [m3/m3]  
+    CALL getin_p("VWC_MIN_FOR_WET_ALB",mc_awet)
+
+    !! Check parameter value (correct range)
+    IF ( ANY(mc_awet(:) < 0) ) THEN
+       CALL ipslerr_p(error_level, "hydrol_init.", &
+            &     "Wrong parameter value for VWC_MIN_FOR_WET_ALB.", &
+            &     "This parameter should be positive. ", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+
+    !Config Key   = VWC_MAX_FOR_DRY_ALB
+    !Config Desc  = Vol. wat. cont. below which albedo is cst
+    !Config If    = HYDROL_CWRR
+    !Config Def   = 0.1, 0.1, 0.1
+    !Config Help  = This parameter is independent from soil texture for
+    !Config         the time being.
+    !Config Units = [m3/m3]   
+    CALL getin_p("VWC_MAX_FOR_DRY_ALB",mc_adry)
+
+    !! Check parameter value (correct range)
+    IF ( ANY(mc_adry(:) < 0) .OR. ANY(mc_adry(:) > mc_awet(:)) ) THEN
+       CALL ipslerr_p(error_level, "hydrol_init.", &
+            &     "Wrong parameter value for VWC_MAX_FOR_DRY_ALB.", &
+            &     "This parameter should be positive and not greater than VWC_MIN_FOR_WET_ALB.", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+
+    !! 3 Other array allocation
+
+ ! Soil Wetness Index! tzjswi 
+    ALLOCATE (swi(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in swi. We stop. We need kjpindex words =',kjpindex
+       CALL ipslerr(3,'hydrol.f90','hydrol_init','','')
+    ENDIF
+
+
+    ALLOCATE (mask_veget(kjpindex,nvm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable mask_veget','','')
+
+    ALLOCATE (mask_soiltile(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable mask_soiltile','','')
+
+    ALLOCATE (humrelv(kjpindex,nvm,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable humrelv','','')
+
+    ALLOCATE (vegstressv(kjpindex,nvm,nstm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable vegstressv','','')
+
+    ALLOCATE (us(kjpindex,nvm,nstm,nslm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable us','','')
+
+    ALLOCATE (precisol(kjpindex,nvm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable precisol','','')
+
+    ALLOCATE (precisol_ns(kjpindex,nstm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable precisol_nc','','')
+
+    ALLOCATE (free_drain_coef(kjpindex,nstm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable free_drain_coef','','')
+
+    ALLOCATE (zwt_force(kjpindex,nstm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable zwt_force','','')
+
+    ALLOCATE (frac_bare_ns(kjpindex,nstm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable frac_bare_ns','','')
+
+    ALLOCATE (water2infilt(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable water2infilt','','')
+
+    ALLOCATE (ae_ns(kjpindex,nstm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable ae_ns','','')
+
+    ALLOCATE (evap_bare_lim_ns(kjpindex,nstm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable evap_bare_lim_ns','','')
+
+    ALLOCATE (rootsink(kjpindex,nslm,nstm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable rootsink','','')
+
+    ALLOCATE (subsnowveg(kjpindex),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable subsnowveg','','')
+
+    ALLOCATE (subsnownobio(kjpindex,nnobio),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable subsnownobio','','')
+
+    ALLOCATE (icemelt(kjpindex),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable icemelt','','')
+
+    ALLOCATE (subsinksoil(kjpindex),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable subsinksoil','','')
+
+    ALLOCATE (mx_eau_var(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable mx_eau_var','','')
+
+    ALLOCATE (vegtot(kjpindex),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable vegtot','','')
+
+    ALLOCATE (resdist(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable resdist','','')
+
+    ALLOCATE (humtot(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable humtot','','')
+
+    ALLOCATE (resolv(kjpindex),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable resolv','','')
+
+    ALLOCATE (k(kjpindex,nslm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable k','','')
+
+    IF (ok_freeze_cwrr) THEN
+       ALLOCATE (kk_moy(kjpindex,nslm),stat=ier) 
+       IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable kk_moy','','')
+       kk_moy(:,:) = 276.48
+
+       ALLOCATE (kk(kjpindex,nslm,nstm),stat=ier) 
+       IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable kk','','')
+       kk(:,:,:) = 276.48
+    ENDIF
+
+    ALLOCATE (a(kjpindex,nslm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable a','','')
+
+    ALLOCATE (b(kjpindex,nslm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable b','','')
+
+    ALLOCATE (d(kjpindex,nslm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable d','','')
+
+    ALLOCATE (e(kjpindex,nslm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable e','','')
+
+    ALLOCATE (f(kjpindex,nslm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable f','','')
+
+    ALLOCATE (g1(kjpindex,nslm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable g1','','')
+
+    ALLOCATE (ep(kjpindex,nslm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable ep','','')
+
+    ALLOCATE (fp(kjpindex,nslm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable fp','','')
+
+    ALLOCATE (gp(kjpindex,nslm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable gp','','')
+
+    ALLOCATE (rhs(kjpindex,nslm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable rhs','','')
+
+    ALLOCATE (srhs(kjpindex,nslm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable srhs','','')
+
+    ALLOCATE (tmc(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tmc','','')
+
+    ALLOCATE (tmcs(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tmcs','','')
+
+    ALLOCATE (tmcr(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tmcr','','')
+
+    ALLOCATE (tmc_litter(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tmc_litter','','')
+
+    ALLOCATE (tmc_litt_mea(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tmc_litt_mea','','')
+
+    ALLOCATE (tmc_litter_res(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tmc_litter_res','','')
+
+    ALLOCATE (tmc_litter_wilt(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tmc_litter_wilt','','')
+
+    ALLOCATE (tmc_litter_field(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tmc_litter_field','','')
+
+    ALLOCATE (tmc_litter_sat(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tmc_litter_sat','','')
+
+    ALLOCATE (tmc_litter_awet(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tmc_litter_awet','','')
+
+    ALLOCATE (tmc_litter_adry(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tmc_litter_adry','','')
+
+    ALLOCATE (tmc_litt_wet_mea(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tmc_litt_wet_mea','','')
+
+    ALLOCATE (tmc_litt_dry_mea(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tmc_litt_dry_mea','','')
+
+    ALLOCATE (v1(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable v1','','')
+
+    ALLOCATE (ru_ns(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable ru_ns','','')
+    ru_ns(:,:) = zero
+
+    ALLOCATE (dr_ns(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable dr_ns','','')
+    dr_ns(:,:) = zero
+
+    ALLOCATE (tr_ns(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tr_ns','','')
+
+    ALLOCATE (cvs_over_veg(kjpindex,nvm,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable cvs_over_veg','','')
+
+    ALLOCATE (vegetmax_soil(kjpindex,nvm,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable vegetmax_soil','','')
+
+    ALLOCATE (mc(kjpindex,nslm,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable mc','','')
+
+    ALLOCATE (mcl(kjpindex, nslm, nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable mcl','','')
+
+    IF (ok_freeze_cwrr) THEN
+       ALLOCATE (profil_froz_hydro(kjpindex, nslm),stat=ier)
+       IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable profil_froz_hydrol','','')
+       profil_froz_hydro(:,:) = zero
+       
+       ALLOCATE (temp_hydro(kjpindex, nslm),stat=ier)
+       IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable temp_hydro','','')
+       temp_hydro(:,:) = 280.
+    ENDIF
+    
+    ALLOCATE (profil_froz_hydro_ns(kjpindex, nslm, nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable profil_froz_hydro_ns','','')
+    profil_froz_hydro_ns(:,:,:) = zero
+    
+    ALLOCATE (frac_hydro_diag(nslm, nbdl),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable frac_hydro_diag','','')
+
+    ALLOCATE (soilmoist(kjpindex,nslm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable soilmoist','','')
+
+    ALLOCATE (soil_wet(kjpindex,nslm,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable soil_wet','','')
+
+    ALLOCATE (soil_wet_litter(kjpindex,nstm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable soil_wet_litter','','')
+
+    ALLOCATE (qflux(kjpindex,nslm,nstm),stat=ier) 
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable qflux','','')
+
+    ALLOCATE (tmat(kjpindex,nslm,3),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tmat','','')
+
+    ALLOCATE (stmat(kjpindex,nslm,3),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable stmat','','')
+
+    ALLOCATE (nroot(nvm, nstm, nslm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable nroot','','')
+
+    ALLOCATE (kfact_root(kjpindex, nslm, nstm), stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable kfact_root','','')
+    ! three variables added by yitong yao 4 Jan 2021
+    ALLOCATE (soil_waterinf_ns(kjpindex, nslm, nstm), stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable soil_waterinf','','')
+
+    ALLOCATE (soil_dtinf_ns(kjpindex, nslm, nstm), stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable soil_dtinf','','')
+
+    ALLOCATE (soil_infilttmp_ns(kjpindex, nslm, nstm), stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable soil_infilttmp','','')
+
+    ALLOCATE (soil_km_ns(kjpindex, nslm, nstm), stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable soil_km','','')
+
+    ALLOCATE (soil_smcinfilt_ns(kjpindex, nslm, nstm), stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable soil_smcinfilt','','')
+
+    ALLOCATE (soil_resinfilt_ns(kjpindex, nslm, nstm), stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable soil_resinfilt','','')
+
+    ALLOCATE (soil_totalinfilt_ns(kjpindex,nstm), stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable soil_totalinfilt','','')
+
+    ALLOCATE (begin_infilt_ns(kjpindex,nstm), stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable begin_infilt','','')
+
+    ! above added 
+
+    ALLOCATE (kfact(nslm, nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable kfact','','')
+
+    ALLOCATE (zz(nslm+1),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable zz','','')
+
+!jgjg    ALLOCATE (dz(nslm+1),stat=ier)
+    ALLOCATE (dz(nslm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable dz','','')
+    
+    ALLOCATE (dh(nslm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable dh','','')
+
+    ALLOCATE (mc_lin(imin:imax, nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable mc_lin','','')
+
+    ALLOCATE (k_lin(imin:imax, nslm, nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable k_lin','','')
+
+    ALLOCATE (d_lin(imin:imax, nslm, nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable d_lin','','')
+
+    ALLOCATE (a_lin(imin:imax, nslm, nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable a_lin','','')
+
+    ALLOCATE (b_lin(imin:imax, nslm, nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable b_lin','','')
+
+    !  If we check the water balance we need two more variables
+    IF ( check_waterbal ) THEN
+       ALLOCATE (tot_water_beg(kjpindex),stat=ier)
+       IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tot_water_beg','','')
+
+       ALLOCATE (tot_water_end(kjpindex),stat=ier)
+       IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tot_water_end','','')
+
+       ALLOCATE (tot_flux(kjpindex),stat=ier)
+       IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tot_flux','','')
+    ENDIF
+
+    ALLOCATE (undermcr(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable undermcr','','')
+
+    ALLOCATE (tot_watveg_beg(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tot_watveg_beg','','')
+    
+    ALLOCATE (tot_watveg_end(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tot_watvag_end','','')
+    
+    ALLOCATE (tot_watsoil_beg(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tot_watsoil_beg','','')
+    
+    ALLOCATE (tot_watsoil_end(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable tot_watsoil_end','','')
+    
+    ALLOCATE (delsoilmoist(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable delsoilmoist','','')
+    
+    ALLOCATE (delintercept(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable delintercept','','')
+    
+    ALLOCATE (delswe(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable delswe','','')
+    
+    ALLOCATE (snow_beg(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable snow_beg','','')
+    
+    ALLOCATE (snow_end(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable snow_end','','')
+    
+    !! 4 Open restart input file and read data for HYDROLOGIC process
+! tzjwb
+!       IF (printlev>=3) WRITE (numout,*) ' we have to read a restart file for HYDROLOGIC variables'
+
+       IF (is_root_prc) CALL ioconf_setatt_p('UNITS', '-')
+       !
+       DO jst=1,nstm
+          ! var_name= "mc_1" ... "mc_3"
+           WRITE (var_name,"('moistc_',I1)") jst
+           IF (is_root_prc) CALL ioconf_setatt_p('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
+       
+       DO jst=1,nstm
+          ! var_name= "mcl_1" ... "mcl_3"
+           WRITE (var_name,"('moistcl_',I1)") jst
+           IF (is_root_prc) CALL ioconf_setatt_p('LONG_NAME',var_name)
+           CALL restget_p (rest_id, var_name, nbp_glo, nslm , 1, kjit, .TRUE., mcl(:,:,jst), "gather", nbp_glo, index_g)
+       END DO
+
+       IF (is_root_prc) CALL ioconf_setatt_p('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
+             IF (is_root_prc) CALL ioconf_setatt_p('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'
+       IF (is_root_prc) THEN
+          CALL ioconf_setatt_p('UNITS', '-')
+          CALL ioconf_setatt_p('LONG_NAME','Coefficient for free drainage at bottom of soil')
+       ENDIF
+       CALL restget_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, .TRUE., free_drain_coef, "gather", nbp_glo, index_g)
+       !
+       var_name= 'zwt_force'
+       IF (is_root_prc) THEN
+          CALL ioconf_setatt_p('UNITS', 'm')
+          CALL ioconf_setatt_p('LONG_NAME','Prescribed water table depth')
+       ENDIF
+       CALL restget_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, .TRUE., zwt_force, "gather", nbp_glo, index_g)
+       !
+       var_name= 'water2infilt'
+       IF (is_root_prc) THEN
+          CALL ioconf_setatt_p('UNITS', '-')
+          CALL ioconf_setatt_p('LONG_NAME','Remaining water to be infiltrated on top of the soil')
+       ENDIF
+       CALL restget_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, .TRUE., water2infilt, "gather", nbp_glo, index_g)
+       !
+       var_name= 'ae_ns'
+       IF (is_root_prc) THEN
+          CALL ioconf_setatt_p('UNITS', 'kg/m^2')
+          CALL ioconf_setatt_p('LONG_NAME','Bare soil evap on each soil type')
+       ENDIF
+       CALL restget_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, .TRUE., ae_ns, "gather", nbp_glo, index_g)
+       !
+       var_name= 'snow'        
+       IF (is_root_prc) THEN
+          CALL ioconf_setatt_p('UNITS', 'kg/m^2')
+          CALL ioconf_setatt_p('LONG_NAME','Snow mass')
+       ENDIF
+       CALL restget_p (rest_id, var_name, nbp_glo, 1  , 1, kjit, .TRUE., snow, "gather", nbp_glo, index_g)
+       !
+       var_name= 'snow_age'
+       IF (is_root_prc) THEN
+          CALL ioconf_setatt_p('UNITS', 'd')
+          CALL ioconf_setatt_p('LONG_NAME','Snow age')
+       ENDIF
+       CALL restget_p (rest_id, var_name, nbp_glo, 1  , 1, kjit, .TRUE., snow_age, "gather", nbp_glo, index_g)
+       !
+       var_name= 'snow_nobio'
+       IF (is_root_prc) THEN
+          CALL ioconf_setatt_p('UNITS', 'kg/m^2')
+          CALL ioconf_setatt_p('LONG_NAME','Snow on other surface types')
+       ENDIF
+       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'
+       IF (is_root_prc) THEN
+          CALL ioconf_setatt_p('UNITS', 'd')
+          CALL ioconf_setatt_p('LONG_NAME','Snow age on other surface types')
+       ENDIF
+       CALL restget_p (rest_id, var_name, nbp_glo, nnobio  , 1, kjit, .TRUE., snow_nobio_age, "gather", nbp_glo, index_g)
+       !
+       var_name= 'qsintveg'
+       IF (is_root_prc) THEN
+          CALL ioconf_setatt_p('UNITS', 'kg/m^2')
+          CALL ioconf_setatt_p('LONG_NAME','Intercepted moisture')
+       ENDIF
+       CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., qsintveg, "gather", nbp_glo, index_g)
+
+       var_name= 'evap_bare_lim_ns'
+       IF (is_root_prc) THEN
+          CALL ioconf_setatt_p('UNITS', '?')
+          CALL ioconf_setatt_p('LONG_NAME','?')
+       ENDIF
+       CALL restget_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, .TRUE., evap_bare_lim_ns, "gather", nbp_glo, index_g)
+       CALL setvar_p (evap_bare_lim_ns, val_exp, 'NO_KEYWORD', 0.0)
+
+
+       var_name= 'resdist'
+       IF (is_root_prc) THEN
+          CALL ioconf_setatt_p('UNITS', '-')
+          CALL ioconf_setatt_p('LONG_NAME','soiltile values from previous time-step')
+       ENDIF
+       CALL restget_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, .TRUE., resdist, "gather", nbp_glo, index_g)
+       
+       IF (is_root_prc) CALL ioconf_setatt_p('UNITS', '-')
+       DO jst=1,nstm
+          ! var_name= "cvs_over_veg_1" ... "cvs_over_veg_3"
+          WRITE (var_name,"('cvs_over_veg_',i1)") jst
+          IF (is_root_prc) CALL ioconf_setatt_p('LONG_NAME',var_name)
+          CALL restget_p (rest_id, var_name, nbp_glo,  nvm, 1, kjit, .TRUE., cvs_over_veg(:,:,jst), "gather",  nbp_glo, index_g)
+       END DO
+       
+       IF ( check_waterbal ) THEN
+          var_name= 'tot_water_beg'
+          IF (is_root_prc) THEN
+             CALL ioconf_setatt_p('UNITS', 'kg/m^2')
+             CALL ioconf_setatt_p('LONG_NAME','Previous Total water')
+          ENDIF
+          CALL restget_p (rest_id, var_name, nbp_glo, 1  , 1, kjit, .TRUE., tot_water_beg, "gather", nbp_glo, index_g)
+       ENDIF
+
+       ! Read drysoil_frac. It will be initalized later in hydrol_var_init if the varaible is not find in restart file.
+       IF (is_root_prc) THEN
+          CALL ioconf_setatt_p('UNITS', '')
+          CALL ioconf_setatt_p('LONG_NAME','Function of litter wetness')
+       ENDIF
+       CALL restget_p (rest_id, 'drysoil_frac', nbp_glo, 1  , 1, kjit, .TRUE., drysoil_frac, "gather", nbp_glo, index_g)
+
+
+    !! 5 get restart values if none were found in the restart file
+       !
+       !Config Key   = HYDROL_MOISTURE_CONTENT
+       !Config Desc  = Soil moisture on each soil tile and levels
+       !Config If    = HYDROL_CWRR       
+       !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.
+       !Config Units = [m3/m3]
+       !
+       CALL setvar_p (mc, val_exp, 'HYDROL_MOISTURE_CONTENT', 0.3_r_std)
+
+       ! Initialize mcl as mc if it is not found in the restart file
+       IF ( ALL(mcl(:,:,:)==val_exp) ) THEN
+          mcl(:,:,:) = mc(:,:,:)
+       END IF
+
+       
+       !Config Key   = US_INIT
+       !Config Desc  = US_NVM_NSTM_NSLM
+       !Config If    = HYDROL_CWRR       
+       !Config Def   = 0.0
+       !Config Help  = The initial value of us (relative 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.
+       !Config Units = [-]
+       !
+       DO jsl=1,nslm
+          CALL setvar_p (us(:,:,:,jsl), val_exp, 'US_INIT', zero)
+       ENDDO
+       !
+       !Config Key   = ZWT_FORCE
+       !Config Desc  = Prescribed water depth, dimension nstm
+       !Config If    = HYDROL_CWRR       
+       !Config Def   = undef undef undef
+       !Config Help  = The initial value of zwt_force if its value is not found
+       !Config         in the restart file. undef corresponds to a case whith no forced WT. 
+       !Config         This should only be used if the model is started without a restart file.
+       !Config Units = [m]
+       
+       ALLOCATE (zwt_default(nstm),stat=ier)
+       IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable zwt_default','','')
+       zwt_default(:) = undef_sechiba
+       CALL setvar_p (zwt_force, val_exp, 'ZWT_FORCE', zwt_default )
+
+       zforce = .FALSE.
+       DO jst=1,nstm
+          IF (zwt_force(1,jst) <= zmaxh) zforce = .TRUE. ! AD16*** check if OK with vertical_soil
+       ENDDO
+       !
+       !Config Key   = FREE_DRAIN_COEF
+       !Config Desc  = Coefficient for free drainage at bottom, dimension nstm
+       !Config If    = HYDROL_CWRR       
+       !Config Def   = 1.0 1.0 1.0
+       !Config Help  = The initial value of free drainage coefficient 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.
+       !Config Units = [-]
+              
+       ALLOCATE (free_drain_max(nstm),stat=ier)
+       IF (ier /= 0) CALL ipslerr_p(3,'hydrol_init','Problem in allocate of variable free_drain_max','','')
+       free_drain_max(:)=coef_max_drain
+       !DO jst=1,nstm
+       !   write(*,*) 'free_drain_max_',jst,' ',free_drain_max(jst)
+       !ENDDO
+       !CALL setvar_p (free_drain_coef, val_exp, 'FREE_DRAIN_COEF', free_drain_max)
+! tzjwb
+       DO ji=1,kjpindex
+          free_drain_coef(ji,1)=free_drain_max(1)
+          free_drain_coef(ji,2)=free_drain_max(2)
+          free_drain_coef(ji,3)=free_drain_max(3)
+       ENDDO
+!       IF (printlev>=2) WRITE (numout,*) ' hydrol_init => free_drain_coef = ',free_drain_coef(1,:)
+       DEALLOCATE(free_drain_max)
+       
+       !write(*,*) 'coef_max_drain',coef_max_drain 
+       !DO ji=1,kjpindex
+       !   write(*,*) 'free_drain_coef_setvar 1 ',free_drain_coef(ji,1)
+       !   write(*,*) 'free_drain_coef_setvar 2 ',free_drain_coef(ji,2)
+       !   write(*,*) 'free_drain_coef_setvar 3 ',free_drain_coef(ji,3)
+       !ENDDO  
+       !
+       !Config Key   = WATER_TO_INFILT
+       !Config Desc  = Water to be infiltrated on top of the soil
+       !Config If    = HYDROL_CWRR    
+       !Config Def   = 0.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.
+       !Config Units = [mm]
+       !
+       CALL setvar_p (water2infilt, val_exp, 'WATER_TO_INFILT', zero)
+       !
+       !Config Key   = EVAPNU_SOIL
+       !Config Desc  = Bare soil evap on each soil if not found in restart
+       !Config If    = HYDROL_CWRR  
+       !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.
+       !Config Units = [mm]
+       !
+       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 If    = OK_SECHIBA
+       !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.
+       !Config Units =
+       !
+       CALL setvar_p (snow, val_exp, 'HYDROL_SNOW', zero)
+       !
+       !Config Key   = HYDROL_SNOWAGE
+       !Config Desc  = Initial snow age if not found in restart
+       !Config If    = OK_SECHIBA
+       !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.
+       !Config Units = ***
+       !
+       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 If    = OK_SECHIBA
+       !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.
+       !Config Units = [mm]
+       !
+       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 If    = OK_SECHIBA
+       !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.
+       !Config Units = ***
+       !
+       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 If    = OK_SECHIBA
+       !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. 
+       !Config Units = [mm]
+       !
+       CALL setvar_p (qsintveg, val_exp, 'HYDROL_QSV', zero)
+
+    !! 6 Vegetation array      
+       !
+       ! If resdist is not in restart file, initialize with soiltile
+       IF ( MINVAL(resdist) .EQ.  MAXVAL(resdist) .AND. MINVAL(resdist) .EQ. val_exp) THEN
+          resdist(:,:) = soiltile(:,:)
+       ENDIF
+       !
+       !  Remember that it is only frac_nobio + SUM(veget_max(,:)) that is equal to 1. Thus we need vegtot
+       !
+       DO ji = 1, kjpindex
+          vegtot(ji) = SUM(veget_max(ji,:))
+       ENDDO
+       !
+       !
+       ! compute the masks for veget
+
+
+       mask_veget(:,:) = 0
+       mask_soiltile(:,:) = 0
+
+       DO jst=1,nstm
+          DO ji = 1, kjpindex
+             IF(soiltile(ji,jst) .GT. min_sechiba) THEN
+                mask_soiltile(ji,jst) = 1
+             ENDIF
+          END DO
+       ENDDO
+          
+       DO jv = 1, nvm
+          DO ji = 1, kjpindex
+             IF(veget_max(ji,jv) .GT. min_sechiba) THEN
+                mask_veget(ji,jv) = 1
+             ENDIF
+          END DO
+       END DO
+
+       humrelv(:,:,:) = SUM(us,dim=4)
+
+          
+       !! 7a. Set vegstress
+       ! soiltile(ji,jst) * cvs_over_veg(ji,jv,jst) * vegtot(ji) = 1 if PFT jv belongs to soiltile jst
+       !                                                         = 0 else
+       ! here cvs_over_veg defines the vegetation cover of the previous timestep, consistently with vegstressv and humrelv
+
+
+       CALL setvar_p (cvs_over_veg, val_exp, 'NO_KEYWORD', un)
+
+
+       !
+       var_name= 'vegstress'
+       IF (is_root_prc) THEN
+          CALL ioconf_setatt_p('UNITS', '-')
+          CALL ioconf_setatt_p('LONG_NAME','Vegetation growth moisture stress')
+       ENDIF
+       CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., vegstress, "gather", nbp_glo, index_g)
+
+       vegstressv(:,:,:) = humrelv(:,:,:)
+       ! Calculate vegstress if it is not found in restart file
+       IF (ALL(vegstress(:,:)==val_exp)) THEN
+          DO jv=1,nvm
+             DO ji=1,kjpindex
+                vegstress(ji,jv)=vegstress(ji,jv) + vegstressv(ji,jv,pref_soil_veg(jv))
+             END DO
+          END DO
+       END IF
+       !! 7b. Set humrel   
+       ! Read humrel from restart file
+       var_name= 'humrel'
+       IF (is_root_prc) THEN
+          CALL ioconf_setatt_p('UNITS', '')
+          CALL ioconf_setatt_p('LONG_NAME','Relative humidity')
+       ENDIF
+       CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., humrel, "gather", nbp_glo, index_g)
+
+       ! Calculate humrel if it is not found in restart file
+       IF (ALL(humrel(:,:)==val_exp)) THEN
+          ! set humrel from humrelv, assuming equi-repartition for the first time step
+          humrel(:,:) = zero
+          DO jv=1,nvm
+             DO ji=1,kjpindex
+                humrel(ji,jv)=humrel(ji,jv) + humrelv(ji,jv,pref_soil_veg(jv))      
+             END DO
+          END DO
+       END IF
+
+       ! Read evap_bare_lim from restart file
+       var_name= 'evap_bare_lim'
+       IF (is_root_prc) THEN
+          CALL ioconf_setatt_p('UNITS', '')
+          CALL ioconf_setatt_p('LONG_NAME','Limitation factor for bare soil evaporation')
+       ENDIF
+       CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., evap_bare_lim, "gather", nbp_glo, index_g)
+
+       ! Calculate evap_bare_lim if it was not found in the restart file.
+       IF ( ALL(evap_bare_lim(:) == val_exp) ) THEN
+          DO ji = 1, kjpindex
+             evap_bare_lim(ji) =  SUM(evap_bare_lim_ns(ji,:)*vegtot(ji)*soiltile(ji,:))
+          ENDDO
+       END IF
+
+
+    ! Read from restart file       
+    ! The variables tot_watsoil_beg, tot_watsoil_beg and snwo_beg will be initialized in the end of 
+    ! hydrol_initialize if they were not found in the restart file.
+       
+    var_name= 'tot_watveg_beg'
+    IF (is_root_prc) THEN
+       CALL ioconf_setatt_p('UNITS', '?')
+       CALL ioconf_setatt_p('LONG_NAME','?')
+    ENDIF
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., tot_watveg_beg, "gather", nbp_glo, index_g)
+    
+    var_name= 'tot_watsoil_beg'
+    IF (is_root_prc) THEN
+       CALL ioconf_setatt_p('UNITS', '?')
+       CALL ioconf_setatt_p('LONG_NAME','?')
+    ENDIF
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., tot_watsoil_beg, "gather", nbp_glo, index_g)
+    
+    var_name= 'snow_beg'
+    IF (is_root_prc) THEN
+       CALL ioconf_setatt_p('UNITS', '?')
+       CALL ioconf_setatt_p('LONG_NAME','?')
+    ENDIF
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., snow_beg, "gather", nbp_glo, index_g)
+       
+ 
+    ! Initialize variables for explictsnow module by reading restart file
+! tzjwb
+!    IF (ok_explicitsnow) THEN
+!       CALL explicitsnow_initialize( kjit,     kjpindex, rest_id,    snowrho,   &
+!                                     snowtemp, snowdz,   snowheat,   snowgrain)
+!    END IF
+
+! tzjwb
+   !     IF (printlev>=3) WRITE (numout,*) ' hydrol_init done '
+    
+  END SUBROUTINE hydrol_init
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: hydrol_clear
+!!
+!>\BRIEF        Deallocate arrays 
+!!
+!_ ================================================================================================================================
+!_ hydrol_clear
+
+  SUBROUTINE hydrol_clear()
+
+    ! Allocation for soiltile related parameters
+    IF ( ALLOCATED (nvan)) DEALLOCATE (nvan)
+    IF ( ALLOCATED (avan)) DEALLOCATE (avan)
+    IF ( ALLOCATED (mcr)) DEALLOCATE (mcr)
+    IF ( ALLOCATED (mcs)) DEALLOCATE (mcs)
+    IF ( ALLOCATED (ks)) DEALLOCATE (ks)
+    IF ( ALLOCATED (pcent)) DEALLOCATE (pcent)
+    IF ( ALLOCATED (mcf)) DEALLOCATE (mcf)
+    IF ( ALLOCATED (mcw)) DEALLOCATE (mcw)
+    IF ( ALLOCATED (mc_awet)) DEALLOCATE (mc_awet)
+    IF ( ALLOCATED (mc_adry)) DEALLOCATE (mc_adry)
+    ! Other arrays
+    IF (ALLOCATED (mask_veget)) DEALLOCATE (mask_veget)
+    IF (ALLOCATED (mask_soiltile)) DEALLOCATE (mask_soiltile)
+    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  (frac_bare_ns)) DEALLOCATE (frac_bare_ns)
+    IF (ALLOCATED  (water2infilt)) DEALLOCATE (water2infilt)
+    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  (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_flux)) DEALLOCATE (tot_flux)
+    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)
+    IF (ALLOCATED  (undermcr)) DEALLOCATE (undermcr)
+    IF (ALLOCATED  (v1)) DEALLOCATE (v1)
+    IF (ALLOCATED  (humtot)) DEALLOCATE (humtot)
+    IF (ALLOCATED  (resolv)) DEALLOCATE (resolv)
+    IF (ALLOCATED  (k)) DEALLOCATE (k)
+    IF (ALLOCATED  (kk)) DEALLOCATE (kk)
+    IF (ALLOCATED  (kk_moy)) DEALLOCATE (kk_moy)
+    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  (tmc)) DEALLOCATE (tmc)
+    IF (ALLOCATED  (tmcs)) DEALLOCATE (tmcs)
+    IF (ALLOCATED  (tmcr)) DEALLOCATE (tmcr)
+    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  (ru_ns)) DEALLOCATE (ru_ns)
+    IF (ALLOCATED  (dr_ns)) DEALLOCATE (dr_ns)
+    IF (ALLOCATED  (tr_ns)) DEALLOCATE (tr_ns)
+    IF (ALLOCATED  (cvs_over_veg)) DEALLOCATE (cvs_over_veg)
+    IF (ALLOCATED  (vegetmax_soil)) DEALLOCATE (vegetmax_soil)
+    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)
+    IF (ALLOCATED  (nroot)) DEALLOCATE (nroot)
+    IF (ALLOCATED  (kfact_root)) DEALLOCATE (kfact_root)
+    ! three variables added by yitong yao 4 Jan 2021
+    IF (ALLOCATED  (soil_waterinf_ns)) DEALLOCATE (soil_waterinf_ns)
+    IF (ALLOCATED  (soil_dtinf_ns)) DEALLOCATE (soil_dtinf_ns)
+    IF (ALLOCATED  (soil_infilttmp_ns)) DEALLOCATE (soil_infilttmp_ns)
+    IF (ALLOCATED  (soil_km_ns)) DEALLOCATE (soil_km_ns)
+    IF (ALLOCATED  (soil_smcinfilt_ns)) DEALLOCATE (soil_smcinfilt_ns)
+    IF (ALLOCATED  (soil_totalinfilt_ns)) DEALLOCATE (soil_totalinfilt_ns)
+    IF (ALLOCATED  (begin_infilt_ns)) DEALLOCATE (begin_infilt_ns)
+    IF (ALLOCATED  (soil_resinfilt_ns)) DEALLOCATE (soil_resinfilt_ns)
+    ! above added 
+    IF (ALLOCATED  (kfact)) DEALLOCATE (kfact)
+    IF (ALLOCATED  (zz)) DEALLOCATE (zz)
+    IF (ALLOCATED  (dz)) DEALLOCATE (dz)
+    IF (ALLOCATED  (dh)) DEALLOCATE (dh)
+    IF (ALLOCATED  (mc_lin)) DEALLOCATE (mc_lin)
+    IF (ALLOCATED  (k_lin)) DEALLOCATE (k_lin)
+    IF (ALLOCATED  (d_lin)) DEALLOCATE (d_lin)
+    IF (ALLOCATED  (a_lin)) DEALLOCATE (a_lin)
+    IF (ALLOCATED  (b_lin)) DEALLOCATE (b_lin)
+    IF (ALLOCATED  (frac_hydro_diag)) DEALLOCATE (frac_hydro_diag)
+    IF (ALLOCATED  (swi)) DEALLOCATE (swi) !tzjswi 
+
+  END SUBROUTINE hydrol_clear
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: hydrol_tmc_update
+!!
+!>\BRIEF        This routine updates the soil moisture profiles when the vegetation fraction have changed. 
+!!
+!! DESCRIPTION  :
+!! 
+!!    This routine update tmc and mc with variation of veget_max (LAND_USE or DGVM activated)
+!! 
+!!
+!!
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_tmc_update
+  SUBROUTINE hydrol_tmc_update ( kjpindex, veget_max, soiltile, qsintveg, resdist )
+
+    !! 0.1 Input variables
+    INTEGER(i_std), INTENT(in)                          :: kjpindex      !! domain size
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)   :: veget_max     !! max fraction of vegetation type
+    REAL(r_std), DIMENSION (kjpindex,nstm), INTENT (in) :: soiltile      !! Fraction of each soil tile (0-1, unitless)
+
+    !! 0.3 Modified variables
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)   :: qsintveg   !! Amount of water in the canopy interception 
+    REAL(r_std), DIMENSION (kjpindex, nstm), INTENT(inout) :: resdist    !! Soiltile from previous time-step
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                           :: ji, jv, jst,jsl
+    LOGICAL                                  :: soil_upd        !! True if soiltile changed since last time step
+    LOGICAL                                  :: error=.FALSE.   !! If true, exit in the end of subroutine
+    REAL(r_std), DIMENSION(kjpindex,nstm)    :: vmr             !! Change in soiltile
+    REAL(r_std), DIMENSION(kjpindex)         :: vmr_sum
+    REAL(r_std), DIMENSION(kjpindex,nslm)    :: mc_dilu         !! Total loss of moisture content
+    REAL(r_std), DIMENSION(kjpindex)         :: infil_dilu      !! Total loss for water2infilt
+    REAL(r_std), DIMENSION(kjpindex,nstm)    :: tmc_old         !! tmc before calculations
+    REAL(r_std), DIMENSION(kjpindex,nstm)    :: water2infilt_old!! water2infilt before calculations
+    REAL(r_std), DIMENSION (kjpindex,nvm)    :: qsintveg_old    !! qsintveg before calculations
+    REAL(r_std), DIMENSION(kjpindex)         :: test
+
+    !! 0. Check if soiltiles changed since last time step
+    soil_upd=SUM(ABS(soiltile(:,:)-resdist(:,:))) .GT. zero
+! tzjwb
+!    IF (printlev>=3) WRITE (numout,*) 'soil_upd ', soil_upd
+!WRITE(numout,*) 'soil_up' ,soil_upd
+
+    IF (check_cwrr) THEN
+       ! Save soil moisture for later use
+       tmc_old(:,:) = tmc(:,:) 
+       water2infilt_old(:,:) = water2infilt(:,:)
+       qsintveg_old(:,:) = qsintveg(:,:)
+    ENDIF
+
+    !! 1. If a PFT has disapperead as result from a veget_max change, 
+    !!    then add canopy water to surface water.
+
+    DO ji=1,kjpindex
+       DO jv=1,nvm
+          IF ((veget_max(ji,jv).LT.min_sechiba).AND.(qsintveg(ji,jv).GT.0.)) THEN
+!WRITE(numout,*) 'PFT' ,ji
+             jst=pref_soil_veg(jv) ! soil tile index
+             water2infilt(ji,jst) = water2infilt(ji,jst) + qsintveg(ji,jv)/resdist(ji,jst)
+             qsintveg(ji,jv) = zero
+          ENDIF
+       ENDDO
+    ENDDO
+    
+    !! 2. Compute new soil moisture if soiltile changed due to veget_max's change
+    IF (soil_upd) THEN
+!WRITE(numout,*) 'soiltie changed' ,ji
+       !! 2.1 Define the change in soiltile
+       vmr(:,:) = soiltile(:,:) - resdist(:,:)  ! resdist is the previous values of soiltiles 
+
+       ! Total area loss by the three soil tiles
+       DO ji=1,kjpindex
+          vmr_sum(ji)=SUM(vmr(ji,:),MASK=vmr(ji,:).LT.zero)
+       ENDDO
+
+       !! 2.2 Shrinking soil tiles
+       !! 2.2.1 Total loss of moisture content from the shrinking soil tiles, expressed by soil layer
+       mc_dilu(:,:)=zero
+       DO jst=1,nstm
+          DO jsl = 1, nslm
+             DO ji=1,kjpindex
+                IF ( vmr(ji,jst) < zero ) THEN
+                   mc_dilu(ji,jsl) = mc_dilu(ji,jsl) + mc(ji,jsl,jst) * vmr(ji,jst) / vmr_sum(ji)
+                ENDIF
+             ENDDO
+          ENDDO
+       ENDDO
+
+       !! 2.2.2 Total loss of water2inft from the shrinking soil tiles
+       infil_dilu(:)=zero
+       DO jst=1,nstm
+          DO ji=1,kjpindex
+             IF ( vmr(ji,jst) < zero ) THEN
+                infil_dilu(ji) = infil_dilu(ji) + water2infilt(ji,jst) * vmr(ji,jst) / vmr_sum(ji)
+             ENDIF
+          ENDDO
+       ENDDO
+
+       !! 2.3 Each gaining soil tile gets moisture proportionally to both the total loss and its areal increase 
+
+       ! As the original mc from each soil tile are in [mcr,mcs] and we do weighted avrage, the new mc are in [mcr,mcs]
+       ! The case where the soiltile is created (soiltile_old=0) works as the other cases
+
+       ! 2.3.1 Update mc(kjpindex,nslm,nstm) !m3/m3
+       DO jst=1,nstm
+          DO jsl = 1, nslm
+             DO ji=1,kjpindex
+                IF ( vmr(ji,jst) > zero ) THEN
+                   mc(ji,jsl,jst) = ( mc(ji,jsl,jst) * resdist(ji,jst) + mc_dilu(ji,jsl) * vmr(ji,jst) ) / soiltile(ji,jst)
+                   ! NB : soiltile can not be zero for case vmr > zero, see slowproc_veget
+                ENDIF
+             ENDDO
+          ENDDO
+       ENDDO
+       
+       ! 2.3.2 Update water2inft
+       DO jst=1,nstm
+          DO ji=1,kjpindex
+             IF ( vmr(ji,jst) > zero ) THEN !donc soiltile>0     
+                water2infilt(ji,jst) = ( water2infilt(ji,jst) * resdist(ji,jst) + infil_dilu(ji) * vmr(ji,jst) ) / soiltile(ji,jst)
+             ENDIF !donc resdist>0
+          ENDDO
+       ENDDO
+
+       ! 2.3.3 Case where soiltile < min_sechiba 
+       DO jst=1,nstm
+          DO ji=1,kjpindex
+             IF ( soiltile(ji,jst) .LT. min_sechiba ) THEN
+                water2infilt(ji,jst) = zero
+                mc(ji,:,jst) = zero
+             ENDIF
+          ENDDO
+       ENDDO
+
+
+    ENDIF ! soil_upd  ! false in our case
+
+
+    !2.3.3 we compute tmc(kjpindex,nstm) and humtot!
+    DO jst=1,nstm
+       DO ji=1,kjpindex
+!WRITE(numout,*) 'mc av l1' ,ji, jst, mc(ji,1,jst),  mc(ji,2,jst)
+             tmc(ji,jst) = dz(2) * ( trois*mc(ji,1,jst) + mc(ji,2,jst) )/huit
+!WRITE(numout,*) 'tmc1' ,ji, jst, tmc(ji,jst)
+             DO jsl = 2,nslm-1
+!WRITE(numout,*) 'mc av lother' ,ji, jst, jsl, mc(ji,jsl,jst),  mc(ji,jsl-1,jst), mc(ji,jsl+1,jst)
+                tmc(ji,jst) = tmc(ji,jst) + dz(jsl) * (trois*mc(ji,jsl,jst)+mc(ji,jsl-1,jst))/huit &
+                     + dz(jsl+1) * (trois*mc(ji,jsl,jst)+mc(ji,jsl+1,jst))/huit
+             ENDDO
+!WRITE(numout,*) 'tmc2' ,ji, jst, tmc(ji,jst)
+             tmc(ji,jst) = tmc(ji,jst) + dz(nslm) * (trois*mc(ji,nslm,jst) + mc(ji,nslm-1,jst))/huit
+             tmc(ji,jst) = tmc(ji,jst) + water2infilt(ji,jst)
+!WRITE(numout,*) 'tmc3' ,ji, jst, tmc(ji,jst)
+             ! WARNING tmc is increased by water2infilt(ji,jst), but mc is not modified !
+       ENDDO
+    ENDDO
+
+    humtot(:) = zero
+    DO jst=1,nstm
+       DO ji=1,kjpindex
+          humtot(ji) = humtot(ji) + soiltile(ji,jst) * tmc(ji,jst)
+       ENDDO
+    ENDDO
+
+    !! 4 check
+    IF (check_cwrr) THEN
+       DO ji=1,kjpindex
+          test(ji) = ABS(SUM(tmc(ji,:)*soiltile(ji,:)) - SUM(tmc_old(ji,:)*resdist(ji,:)) + &
+               SUM(qsintveg(ji,:)) - SUM(qsintveg_old(ji,:))) ! sum(soiltile)=1
+          IF ( test(ji) .GT.  10.*allowed_err ) THEN
+             WRITE(numout,*) 'tmc update WRONG: ji',ji
+             WRITE(numout,*) 'tot water avant:',SUM(tmc_old(ji,:)*resdist(ji,:)) + SUM(qsintveg_old(ji,:))
+             WRITE(numout,*) 'tot water apres:',SUM(tmc(ji,:)*soiltile(ji,:)) + SUM(qsintveg(ji,:))
+             WRITE(numout,*) 'err:',test(ji)
+             WRITE(numout,*) 'allowed_err:',allowed_err
+             WRITE(numout,*) 'tmc:',tmc(ji,:)
+             WRITE(numout,*) 'tmc_old:',tmc_old(ji,:)
+             WRITE(numout,*) 'qsintveg:',qsintveg(ji,:)
+             WRITE(numout,*) 'qsintveg_old:',qsintveg_old(ji,:)
+             WRITE(numout,*) 'SUMqsintveg:',SUM(qsintveg(ji,:))
+             WRITE(numout,*) 'SUMqsintveg_old:',SUM(qsintveg_old(ji,:))
+             WRITE(numout,*) 'veget_max:',veget_max(ji,:)
+             WRITE(numout,*) 'soiltile:',soiltile(ji,:)
+             WRITE(numout,*) 'resdist:',resdist(ji,:)
+             WRITE(numout,*) 'vmr:',vmr(ji,:)
+             WRITE(numout,*) 'vmr_sum:',vmr_sum(ji)
+             DO jst=1,nstm
+                WRITE(numout,*) 'mc(',jst,'):',mc(ji,:,jst)
+             ENDDO
+             WRITE(numout,*) 'water2infilt:',water2infilt(ji,:)
+             WRITE(numout,*) 'water2infilt_old:',water2infilt_old(ji,:)
+             WRITE(numout,*) 'infil_dilu:',infil_dilu(ji)
+             WRITE(numout,*) 'mc_dilu:',mc_dilu(ji,:)
+
+             error=.TRUE.
+             CALL ipslerr_p(2, 'hydrol_tmc_update', 'Error in water balance', 'We STOP in the end of this subroutine','')
+          ENDIF
+       ENDDO
+    ENDIF
+
+    !! Now that the work is done, update resdist
+    resdist(:,:) = soiltile(:,:)
+
+    !
+    !!  Exit if error was found previously in this subroutine
+    !
+    IF ( error ) THEN
+       WRITE(numout,*) 'One or more errors have been detected in hydrol_tmc_update. Model stops.'
+       CALL ipslerr_p(3, 'hydrol_tmc_update', 'We will STOP now.',&
+                  & 'One or several fatal errors were found previously.','')
+    END IF
+
+! tzjwb
+!    IF (printlev>=3) WRITE (numout,*) ' hydrol_tmc_update done '
+
+  END SUBROUTINE hydrol_tmc_update
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: hydrol_var_init
+!!
+!>\BRIEF        This routine initializes hydrologic parameters to define K and D, and diagnostic hydrologic variables.  
+!!
+!! DESCRIPTION  :
+!! - 1 compute the depths
+!! - 2 compute the profile for roots
+!! - 3 compute the profile for ksat, a and n Van Genuchten parameter
+!! - 4 compute the linearized values of k, a, b and d for the resolution of Fokker Planck equation
+!! - 5 water reservoirs initialisation
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_var_init
+
+  SUBROUTINE hydrol_var_init (kjpindex, veget, veget_max, soiltile, njsc, &
+       mx_eau_var, shumdiag_perma, k_litt, &
+       drysoil_frac, qsintveg, mc_layh, mcl_layh, tmc_layh) 
+
+    ! interface description
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                          :: kjpindex      !! Domain size (number of grid cells) (1)
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)   :: veget_max     !! PFT fractions within grid-cells (1; 1)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)   :: veget         !! Effective fraction of vegetation by PFT (1; 1)
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)    :: njsc          !! Index of the dominant soil textural class 
+                                                                         !! in the grid cell (1-nscm, unitless) 
+    REAL(r_std), DIMENSION (kjpindex,nstm), INTENT (in) :: soiltile      !! Fraction of each soil tile (0-1, unitless)
+
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: mx_eau_var    !! Maximum water content of the soil 
+                                                                         !! @tex $(kg m^{-2})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out) :: shumdiag_perma!! Percent of porosity filled with water (mc/mcs)
+                                                                         !! used for the thermal computations
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: k_litt        !! Mean litter hydraulic conductivity
+                                                                         !! @tex $(mm d^{-1})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)    :: drysoil_frac  !! function of litter humidity
+    REAL(r_std), DIMENSION (kjpindex,nslm), INTENT (out):: mc_layh       !! Volumetric soil moisture content for each layer in hydrol(liquid+ice) [m3/m3]
+    REAL(r_std), DIMENSION (kjpindex,nslm), INTENT (out):: mcl_layh      !! Volumetric soil moisture content for each layer in hydrol(liquid) [m3/m3]
+    REAL(r_std), DIMENSION (kjpindex,nslm), INTENT (out):: tmc_layh      !! Total soil moisture content for each layer in hydrol(liquid+ice) [mm]
+
+    !! 0.3 Modified variables
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)  :: qsintveg    !! Water on vegetation due to interception
+                                                                         !! @tex $(kg m^{-2})$ @endtex  
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                      :: ji, jv        !! Grid-cell and PFT indices (1)
+    INTEGER(i_std)                                      :: jst, jsc, jsl !! Soiltile, Soil Texture, and Soil layer indices (1)
+    INTEGER(i_std)                                      :: i, jd         !! Index (1)
+    REAL(r_std)                                         :: m             !! m=1-1/n (unitless)
+    REAL(r_std)                                         :: frac          !! Relative linearized VWC (unitless)
+    REAL(r_std)                                         :: avan_mod      !! VG parameter a modified from  exponantial profile
+                                                                         !! @tex $(mm^{-1})$ @endtex
+    REAL(r_std)                                         :: nvan_mod      !! VG parameter n  modified from  exponantial profile
+                                                                         !! (unitless)
+    REAL(r_std), DIMENSION(nslm,nscm)                   :: afact, nfact  !! Multiplicative factor for decay of a and n with depth
+                                                                         !! (unitless)
+    ! parameters for "soil densification" with depth
+    REAL(r_std)                                         :: dp_comp       !! Depth at which the 'compacted' value of ksat
+                                                                         !! is reached (m)
+    REAL(r_std)                                         :: f_ks          !! Exponential factor for decay of ksat with depth 
+                                                                         !! @tex $(m^{-1})$ @endtex 
+    ! Fixed parameters from fitted relationships
+    REAL(r_std)                                         :: n0            !! fitted value for relation log((n-n0)/(n_ref-n0)) = 
+                                                                         !! nk_rel * log(k/k_ref) 
+                                                                         !! (unitless)
+    REAL(r_std)                                         :: nk_rel        !! fitted value for relation log((n-n0)/(n_ref-n0)) = 
+                                                                         !! nk_rel * log(k/k_ref) 
+                                                                         !! (unitless)
+    REAL(r_std)                                         :: a0            !! fitted value for relation log((a-a0)/(a_ref-a0)) = 
+                                                                         !! ak_rel * log(k/k_ref) 
+                                                                         !! @tex $(mm^{-1})$ @endtex
+    REAL(r_std)                                         :: ak_rel        !! fitted value for relation log((a-a0)/(a_ref-a0)) = 
+                                                                         !! ak_rel * log(k/k_ref)
+                                                                         !! (unitless) 
+    REAL(r_std)                                         :: kfact_max     !! Maximum factor for Ks decay with depth (unitless)
+    REAL(r_std)                                         :: k_tmp, tmc_litter_ratio
+    INTEGER(i_std), PARAMETER                           :: error_level = 3 !! Error level for consistency check
+                                                                           !! Switch to 2 tu turn fatal errors into warnings
+    REAL(r_std), DIMENSION (kjpindex,nslm,nstm)         :: tmc_layh_s      !! total soil moisture content for each layer in hydrol and for each soiltile (mm)
+    INTEGER(i_std)                                      :: jiref           !! To identify the mc_lins where k_lin and d_lin 
+                                                                           !! need special treatment
+
+! tzjdz
+REAL(r_std)                                         :: nroot_tmp
+
+
+!_ ================================================================================================================================
+
+!!??Aurelien: Les 3 parametres qui suivent pourait peut-Ãªtre mis dans hydrol_init?
+    !
+    !
+    !Config Key   = CWRR_NKS_N0 
+    !Config Desc  = fitted value for relation log((n-n0)/(n_ref-n0)) = nk_rel * log(k/k_ref)
+    !Config Def   = 0.95
+    !Config If    = HYDROL_CWRR 
+    !Config Help  =
+    !Config Units = [-]
+    n0 = 0.95
+    CALL getin_p("CWRR_NKS_N0",n0)
+
+    !! Check parameter value (correct range)
+    IF ( n0 < zero ) THEN
+       CALL ipslerr_p(error_level, "hydrol_var_init.", &
+            &     "Wrong parameter value for CWRR_NKS_N0.", &
+            &     "This parameter should be non-negative. ", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+
+    !Config Key   = CWRR_NKS_POWER
+    !Config Desc  = fitted value for relation log((n-n0)/(n_ref-n0)) = nk_rel * log(k/k_ref)
+    !Config Def   = 0.34
+    !Config If    = HYDROL_CWRR 
+    !Config Help  =
+    !Config Units = [-]
+    nk_rel = 0.34
+    CALL getin_p("CWRR_NKS_POWER",nk_rel)
+
+    !! Check parameter value (correct range)
+    IF ( nk_rel < zero ) THEN
+       CALL ipslerr_p(error_level, "hydrol_var_init.", &
+            &     "Wrong parameter value for CWRR_NKS_POWER.", &
+            &     "This parameter should be non-negative. ", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+
+    !Config Key   = CWRR_AKS_A0 
+    !Config Desc  = fitted value for relation log((a-a0)/(a_ref-a0)) = ak_rel * log(k/k_ref)
+    !Config Def   = 0.00012
+    !Config If    = HYDROL_CWRR 
+    !Config Help  =
+    !Config Units = [1/mm]
+    a0 = 0.00012
+    CALL getin_p("CWRR_AKS_A0",a0)
+
+    !! Check parameter value (correct range)
+    IF ( a0 < zero ) THEN
+       CALL ipslerr_p(error_level, "hydrol_var_init.", &
+            &     "Wrong parameter value for CWRR_AKS_A0.", &
+            &     "This parameter should be non-negative. ", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+
+    !Config Key   = CWRR_AKS_POWER
+    !Config Desc  = fitted value for relation log((a-a0)/(a_ref-a0)) = ak_rel * log(k/k_ref)
+    !Config Def   = 0.53
+    !Config If    = HYDROL_CWRR 
+    !Config Help  =
+    !Config Units = [-]
+    ak_rel = 0.53
+    CALL getin_p("CWRR_AKS_POWER",ak_rel)
+
+    !! Check parameter value (correct range)
+    IF ( nk_rel < zero ) THEN
+       CALL ipslerr_p(error_level, "hydrol_var_init.", &
+            &     "Wrong parameter value for CWRR_AKS_POWER.", &
+            &     "This parameter should be non-negative. ", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+
+    !Config Key   = KFACT_DECAY_RATE
+    !Config Desc  = Factor for Ks decay with depth
+    !Config Def   = 2.0
+    !Config If    = HYDROL_CWRR 
+    !Config Help  =  
+    !Config Units = [1/m]
+    f_ks = 2.0
+    CALL getin_p ("KFACT_DECAY_RATE", f_ks)
+
+    !! Check parameter value (correct range)
+    IF ( f_ks <= zero ) THEN
+       CALL ipslerr_p(error_level, "hydrol_var_init.", &
+            &     "Wrong parameter value for KFACT_DECAY_RATE.", &
+            &     "This parameter should be positive. ", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+
+    !Config Key   = KFACT_STARTING_DEPTH
+    !Config Desc  = Depth for compacted value of Ks 
+    !Config Def   = 0.3
+    !Config If    = HYDROL_CWRR 
+    !Config Help  =  
+    !Config Units = [m]
+    dp_comp = 0.3
+    CALL getin_p ("KFACT_STARTING_DEPTH", dp_comp)
+
+    !! Check parameter value (correct range)
+    IF ( dp_comp <= zero ) THEN
+       CALL ipslerr_p(error_level, "hydrol_var_init.", &
+            &     "Wrong parameter value for KFACT_STARTING_DEPTH.", &
+            &     "This parameter should be positive. ", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+
+    !Config Key   = KFACT_MAX
+    !Config Desc  = Maximum Factor for Ks increase due to vegetation
+    !Config Def   = 10.0
+    !Config If    = HYDROL_CWRR 
+    !Config Help  =
+    !Config Units = [-]
+    kfact_max = 10.0
+    CALL getin_p ("KFACT_MAX", kfact_max)
+
+    !! Check parameter value (correct range)
+    IF ( kfact_max < 10. ) THEN
+       CALL ipslerr_p(error_level, "hydrol_var_init.", &
+            &     "Wrong parameter value for KFACT_MAX.", &
+            &     "This parameter should be greater than 10. ", &
+            &     "Please, check parameter value in run.def. ")
+    END IF
+
+    
+    !-
+    !! 1 Depths are stored in module vertical_soil_var
+    !-
+    ! Transform from m into mm
+    DO jsl=1,nslm
+       zz(jsl) = znh(jsl)*mille
+       dz(jsl) = dnh(jsl)*mille
+       dh(jsl) = dlh(jsl)*mille
+    ENDDO
+    zz(nslm+1) = zz(nslm)
+
+    DO jst=1,nstm ! loop on soiltiles
+
+       !-
+       !! 2 compute the root density profile
+       !-
+       !! The three following equations concerning nroot computation are derived from the integrals 
+       !! of equations C9 to C11 of De Rosnay's (1999) PhD thesis (page 158).
+       !! The occasional absence of minus sign before humcste parameter is correct.
+       DO jv = 1,nvm
+          DO jsl = 2, nslm-1
+	!     WRITE (*,*) 'jv=',jv,'	jsl=',jsl
+	!     WRITE (*,*) 'humcste(jv)=',humcste(jv)
+	!     WRITE (*,*) 'zz(jsl)=',zz(jsl)
+	!     WRITE (*,*) 'zz(nslm)=',zz(nslm)
+	!     WRITE (*,*) 'dz(jsl)=',dz(jsl)
+	!     WRITE (*,*) 'dz(jsl+1)=',dz(jsl+1)
+	!     WRITE (*,*) 'dz(2)=',dz(2)
+             nroot(jv,jst,jsl) = (EXP(-humcste(jv)*zz(jsl)/mille)) * &
+                     & (EXP(humcste(jv)*dz(jsl)/mille/deux) - &
+                     & EXP(-humcste(jv)*dz(jsl+1)/mille/deux))/ &
+                     & (EXP(-humcste(jv)*dz(2)/mille/deux) &
+                     & -EXP(-humcste(jv)*zz(nslm)/mille))
+          ENDDO
+       ENDDO
+
+
+
+       DO jv=1,nvm
+          nroot(jv,jst,1) = zero
+          nroot(jv,jst,nslm) = (EXP(humcste(jv)*dz(nslm)/mille/deux) -un) * &
+                  & EXP(-humcste(jv)*zz(nslm)/mille) / &
+                  & (EXP(-humcste(jv)*dz(2)/mille/deux) &
+                  & -EXP(-humcste(jv)*zz(nslm)/mille))
+       ENDDO
+    ENDDO
+
+       !! An exponential factor is used to increase ks near the surface depending on the amount of roots in the soil 
+       !! through a geometric average over the vegets
+       !! This comes from the PhD thesis of d'Orgeval, 2006, p82; d'Orgeval et al. 2008, Eqs. 3-4
+       !! (Calibrated against Hapex-Sahel measurements)
+
+!WRITE(*,*) "nroot 2 tzj",  nroot
+
+! tzj Dbug
+    kfact_root(:,:,:) = un
+    DO jsl = 1, nslm
+       DO jv = 2, nvm
+          jst = pref_soil_veg(jv)
+          DO ji = 1, kjpindex
+             IF(soiltile(ji,jst) .GT. min_sechiba) THEN
+                kfact_root(ji,jsl,jst) = kfact_root(ji,jsl,jst) * &
+                     & MAX((MAXVAL(ks_usda)/ks(njsc(ji)))**(- veget_max(ji,jv)/2 * (humcste(jv)*zz(jsl)/mille - un)/deux), &
+                     un) 
+                ! modified by yitong yao in 3 Jan 2021
+                IF (pres_kfact .EQ. 1) THEN
+                   IF (kfact_root(ji,jsl,jst) .LT. 1.3) THEN
+                        kfact_root(ji,jsl,jst)=min_kfactroot
+                   ENDIF
+                ENDIF
+                ! above modified 
+
+!                kfact_root(ji,jsl,jst) = kfact_root(ji,jsl,jst) * &
+!                     & MAX((MAXVAL(ks_usda)/ks(njsc(ji)))**(- vegetmax_soil(ji,jv,jst)* (humcste(jv)*zz(jsl)/mille - un)/deux), &
+!                     un)
+
+
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDDO
+    !-
+    !! 3 Compute the profile for ksat, a and n
+    !-
+
+    ! For every soil texture
+    DO jsc = 1, nscm 
+       DO jsl=1,nslm
+          ! PhD thesis of d'Orgeval, 2006, p81, Eq. 4.38; d'Orgeval et al. 2008, Eq. 2
+          ! Calibrated against Hapex-Sahel measurements
+          kfact(jsl,jsc) = MIN(MAX(EXP(- f_ks * (zz(jsl)/mille - dp_comp)), un/kfact_max),un)
+          ! PhD thesis of d'Orgeval, 2006, p81, Eqs. 4.39; 4.42, and Fig 4.14 
+          !write(*,*) 'kfact', jsl, ' ', kfact(jsl,jsc), ' depth ', zz(jsl)
+          nfact(jsl,jsc) = ( kfact(jsl,jsc) )**nk_rel
+          afact(jsl,jsc) = ( kfact(jsl,jsc) )**ak_rel
+       ENDDO
+    ENDDO
+
+    ! For every soil texture
+    DO jsc = 1, nscm
+       !-
+       !! 4 compute the linearized values of k, a, b and d
+       !-
+       ! Calculate the matrix coef for Dublin model (de Rosnay, 1999; p149)
+       ! piece-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.
+
+       ! We define 51 bounds for 50 bins of mc between mcr and mcs
+       mc_lin(imin,jsc)=mcr(jsc)
+       mc_lin(imax,jsc)=mcs(jsc)
+       DO ji= imin+1, imax-1 ! ji=2,50
+          mc_lin(ji,jsc) = mcr(jsc) + (ji-imin)*(mcs(jsc)-mcr(jsc))/(imax-imin)
+       ENDDO
+
+       DO jsl = 1, nslm
+          ! From PhD thesis of d'Orgeval, 2006, p81, Eq. 4.42
+          nvan_mod = n0 + (nvan(jsc)-n0) * nfact(jsl,jsc)
+          avan_mod = a0 + (avan(jsc)-a0) * afact(jsl,jsc)
+          m = un - un / nvan_mod
+          ! We apply Van Genuchten equation for K(theta) based on Ks(z)=ks(jsc) * kfact(jsl,jsc)
+          DO ji = imax,imin,-1 
+             frac=MIN(un,(mc_lin(ji,jsc)-mcr(jsc))/(mcs(jsc)-mcr(jsc)))
+             k_lin(ji,jsl,jsc) = ks(jsc) * kfact(jsl,jsc) * (frac**0.5) * ( un - ( un - frac ** (un/m)) ** m )**2
+          ENDDO
+
+          ! k_lin should not be zero, nor too small
+          ! We track jiref, the bin under which mc is too small and we may get zero k_lin     
+          ji=imax-1
+          DO WHILE ((k_lin(ji,jsl,jsc) > 1.e-32) .and. (ji>0))
+             jiref=ji
+             ji=ji-1
+          ENDDO
+          DO ji=jiref-1,imin,-1
+             k_lin(ji,jsl,jsc)=k_lin(ji+1,jsl,jsc)/10.
+          ENDDO
+         
+          DO ji = imin,imax-1 ! ji=1,50
+             ! We deduce a_lin and b_lin based on continuity between segments k_lin = a_lin*mc-lin+b_lin
+             a_lin(ji,jsl,jsc) = (k_lin(ji+1,jsl,jsc)-k_lin(ji,jsl,jsc)) / (mc_lin(ji+1,jsc)-mc_lin(ji,jsc))
+             b_lin(ji,jsl,jsc)  = k_lin(ji,jsl,jsc) - a_lin(ji,jsl,jsc)*mc_lin(ji,jsc)
+
+             ! We calculate the d_lin for each mc bin, from Van Genuchten equation for D(theta)
+             ! d_lin is constant and taken as the arithmetic mean between the values at the bounds of each bin 
+             IF (ji.NE.imin .AND. ji.NE.imax-1) THEN
+                frac=MIN(un,(mc_lin(ji,jsc)-mcr(jsc))/(mcs(jsc)-mcr(jsc)))
+                d_lin(ji,jsl,jsc) =(k_lin(ji,jsl,jsc) / (avan_mod*m*nvan_mod)) *  &
+                     ( (frac**(-un/m))/(mc_lin(ji,jsc)-mcr(jsc)) ) * &
+                     (  frac**(-un/m) -un ) ** (-m)
+                frac=MIN(un,(mc_lin(ji+1,jsc)-mcr(jsc))/(mcs(jsc)-mcr(jsc)))
+                d_lin(ji+1,jsl,jsc) =(k_lin(ji+1,jsl,jsc) / (avan_mod*m*nvan_mod))*&
+                     ( (frac**(-un/m))/(mc_lin(ji+1,jsc)-mcr(jsc)) ) * &
+                     (  frac**(-un/m) -un ) ** (-m)
+                d_lin(ji,jsl,jsc) = undemi * (d_lin(ji,jsl,jsc)+d_lin(ji+1,jsl,jsc))
+             ELSE IF(ji.EQ.imax-1) THEN
+                d_lin(ji,jsl,jsc) =(k_lin(ji,jsl,jsc) / (avan_mod*m*nvan_mod)) * &
+                     ( (frac**(-un/m))/(mc_lin(ji,jsc)-mcr(jsc)) ) *  &
+                     (  frac**(-un/m) -un ) ** (-m)
+             ENDIF
+          ENDDO
+
+          ! Special case for ji=imin
+          d_lin(imin,jsl,jsc) = d_lin(imin+1,jsl,jsc)/1000.
+
+          ! We adjust d_lin where k_lin was previously adjusted otherwise we might get non-monotonous variations
+          ! We don't want d_lin = zero
+          DO ji=jiref-1,imin,-1
+             d_lin(ji,jsl,jsc)=d_lin(ji+1,jsl,jsc)/10.
+          ENDDO
+
+       ENDDO
+    ENDDO
+    !! 5 Water reservoir initialisation
+    !
+!!$    DO jst = 1,nstm
+!!$       DO ji = 1, kjpindex
+!!$          mx_eau_var(ji) = mx_eau_var(ji) + soiltile(ji,jst)*&
+!!$               &   zmaxh*mille*mcs(njsc(ji))
+!!$       END DO
+!!$    END DO
+!!$    IF (check_CWRR) THEN
+!!$       IF ( ANY ( ABS( mx_eau_var(:) - zmaxh*mille*mcs(njsc(:)) ) > min_sechiba ) ) THEN
+!!$          ji=MAXLOC ( ABS( mx_eau_var(:) - zmaxh*mille*mcs(njsc(:)) ) , 1)
+!!$          WRITE(numout, *) "Erreur formule simplifiÃÂ©e mx_eau_var ! ", mx_eau_var(ji), zmaxh*mille*mcs(njsc(ji))
+!!$          WRITE(numout, *) "err = ",ABS(mx_eau_var(ji) - zmaxh*mille*mcs(njsc(ji)))
+!!$          STOP 1
+!!$       ENDIF
+!!$    ENDIF
+
+    mx_eau_var(:) = zero
+    mx_eau_var(:) = zmaxh*mille*mcs(njsc(:)) 
+
+    DO ji = 1,kjpindex 
+       IF (vegtot(ji) .LE. zero) THEN
+          mx_eau_var(ji) = mx_eau_nobio*zmaxh
+          ! Aurelien: what does vegtot=0 mean? is it like frac_nobio=1? But if 0<frac_nobio<1 ???
+       ENDIF
+
+    END DO
+
+    ! Compute the litter humidity, shumdiag and fry
+    k_litt(:) = zero
+    tmc_litt_mea(:) = zero
+    tmc_litt_wet_mea(:) = zero
+    tmc_litt_dry_mea(:) = zero
+    shumdiag_perma(:,:) = zero
+    humtot(:) = zero
+    tmc(:,:) = zero
+   swi(:) = zero  !tzjswi 
+    ! Loop on soiltiles to compute the variables (ji,jst)
+    DO jst=1,nstm 
+       DO ji = 1, kjpindex
+          tmcs(ji,jst)=zmaxh* mille*mcs(njsc(ji))
+          tmcr(ji,jst)=zmaxh* mille*mcr(njsc(ji))
+       ENDDO
+    ENDDO
+!WRITE(numout,*) 'tmcr 10',tmcr(10,:)       
+!WRITE(numout,*) 'tmcs 10',tmcs(10,:)       
+!WRITE(numout,*) 'tmcr2 10',mcr(njsc(10))    
+!WRITE(numout,*) 'tmcr2 10',mcs(njsc(10))    
+!WRITE(numout,*) 'njsc 10',njsc(10)   
+
+
+!WRITE(numout,*) 'tmcr 11',tmcr(11,:)
+!WRITE(numout,*) 'tmcs 11',tmcs(11,:)
+!WRITE(numout,*) 'tmcr2 11',mcr(njsc(11))
+!WRITE(numout,*) 'tmcr2 11',mcs(njsc(11))
+!
+!WRITE(numout,*) 'tmcr 20',tmcr(20,:)
+!WRITE(numout,*) 'tmcs 20',tmcs(20,:)
+!WRITE(numout,*) 'tmcr2 20',mcr(njsc(20))
+!WRITE(numout,*) 'tmcr2 20',mcs(njsc(20))
+    
+
+
+    ! The total soil moisture for each soiltile:
+    DO jst=1,nstm
+       DO ji=1,kjpindex
+          tmc(ji,jst)= dz(2) * ( trois*mc(ji,1,jst)+ mc(ji,2,jst))/huit
+       END DO
+    ENDDO
+
+    DO jst=1,nstm 
+       DO jsl=2,nslm-1
+          DO ji=1,kjpindex
+             tmc(ji,jst) = tmc(ji,jst) + dz(jsl) * ( trois*mc(ji,jsl,jst) + mc(ji,jsl-1,jst))/huit &
+                  & + dz(jsl+1)*(trois*mc(ji,jsl,jst) + mc(ji,jsl+1,jst))/huit
+          END DO
+       END DO
+    ENDDO
+
+    DO jst=1,nstm 
+       DO ji=1,kjpindex
+          tmc(ji,jst) = tmc(ji,jst) +  dz(nslm) * (trois * mc(ji,nslm,jst) + mc(ji,nslm-1,jst))/huit
+          tmc(ji,jst) = tmc(ji,jst) + water2infilt(ji,jst)
+       ENDDO
+    END DO
+
+!JG: hydrol_tmc_update should not be called in the initialization phase. Call of hydrol_tmc_update makes the model restart differenlty.    
+!    ! If veget has been updated before restart (with LAND USE or DGVM),
+!    ! tmc and mc must be modified with respect to humtot conservation.
+!   CALL hydrol_tmc_update ( kjpindex, veget_max, soiltile, qsintveg, resdist )
+
+    ! The litter variables:
+    ! level 1
+    DO jst=1,nstm 
+       DO ji=1,kjpindex
+          tmc_litter(ji,jst) = dz(2) * (trois*mc(ji,1,jst)+mc(ji,2,jst))/huit
+          tmc_litter_wilt(ji,jst) = dz(2) * mcw(njsc(ji)) / deux
+          tmc_litter_res(ji,jst) = dz(2) * mcr(njsc(ji)) / deux
+          tmc_litter_field(ji,jst) = dz(2) * mcf(njsc(ji)) / deux
+          tmc_litter_sat(ji,jst) = dz(2) * mcs(njsc(ji)) / deux
+          tmc_litter_awet(ji,jst) = dz(2) * mc_awet(njsc(ji)) / deux
+          tmc_litter_adry(ji,jst) = dz(2) * mc_adry(njsc(ji)) / deux
+       ENDDO
+    END DO
+    ! sum from level 2 to 4
+    DO jst=1,nstm 
+       DO jsl=2,4
+          DO ji=1,kjpindex
+             tmc_litter(ji,jst) = tmc_litter(ji,jst) + dz(jsl) * & 
+                  & ( trois*mc(ji,jsl,jst) + mc(ji,jsl-1,jst))/huit &
+                  & + dz(jsl+1)*(trois*mc(ji,jsl,jst) + mc(ji,jsl+1,jst))/huit
+             tmc_litter_wilt(ji,jst) = tmc_litter_wilt(ji,jst) + &
+                  &(dz(jsl)+ dz(jsl+1))*& 
+                  & mcw(njsc(ji))/deux
+             tmc_litter_res(ji,jst) = tmc_litter_res(ji,jst) + &
+                  &(dz(jsl)+ dz(jsl+1))*& 
+                  & mcr(njsc(ji))/deux
+             tmc_litter_sat(ji,jst) = tmc_litter_sat(ji,jst) + &
+                  &(dz(jsl)+ dz(jsl+1))* & 
+                  & mcs(njsc(ji))/deux
+             tmc_litter_field(ji,jst) = tmc_litter_field(ji,jst) + &
+                  & (dz(jsl)+ dz(jsl+1))* & 
+                  & mcf(njsc(ji))/deux
+             tmc_litter_awet(ji,jst) = tmc_litter_awet(ji,jst) + &
+                  &(dz(jsl)+ dz(jsl+1))* & 
+                  & mc_awet(njsc(ji))/deux
+             tmc_litter_adry(ji,jst) = tmc_litter_adry(ji,jst) + &
+                  & (dz(jsl)+ dz(jsl+1))* & 
+                  & mc_adry(njsc(ji))/deux
+          END DO
+       END DO
+    END DO
+
+    ! Soil wetness profiles (W-Ww)/(Ws-Ww)
+    DO jst=1,nstm 
+       DO ji=1,kjpindex
+          soil_wet(ji,1,jst) = MIN(un, MAX(zero,&
+               &(trois*mc(ji,1,jst) + mc(ji,2,jst) - quatre*mcw(njsc(ji)))&
+               & /(quatre*(mcs(njsc(ji))-mcw(njsc(ji)))) ))
+          ! here we set that humrelv=0 in PFT1
+          humrelv(ji,1,jst) = zero
+       ENDDO
+    END DO
+    
+    DO jst=1,nstm 
+       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)/(dz(jsl)+dz(jsl+1))) &
+                  & + mc(ji,jsl+1,jst)*(dz(jsl+1)/(dz(jsl)+dz(jsl+1))) &
+                  & - quatre*mcw(njsc(ji))) / (quatre*(mcs(njsc(ji))-mcw(njsc(ji)))) ))
+          END DO
+       END DO
+    END DO
+
+    DO jst=1,nstm 
+       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(njsc(ji)))/(quatre*(mcs(njsc(ji))-mcw(njsc(ji)))) ))
+       ENDDO
+    END DO
+
+    ! Compute the grid averaged values
+    DO jst=1,nstm        
+       DO ji=1,kjpindex
+          !
+          IF ( tmc_litter(ji,jst) < tmc_litter_res(ji,jst)) THEN
+             i = imin
+          ELSE
+             tmc_litter_ratio = (tmc_litter(ji,jst)-tmc_litter_res(ji,jst)) / &
+                  & (tmc_litter_sat(ji,jst)-tmc_litter_res(ji,jst))
+             i= MAX(MIN(INT((imax-imin)*tmc_litter_ratio)+imin , imax-1), imin)
+          ENDIF
+          ! k_litt is an averaged conductivity for saturated infiltration in the 'litter' layer
+          ! This is used for reinfiltration from surface water
+          k_tmp = MAX(k_lin(i,1,njsc(ji))*ks(njsc(ji)), zero)
+          k_litt(ji) = k_litt(ji) + soiltile(ji,jst) * SQRT(k_tmp)
+       ENDDO
+    ENDDO
+
+    DO jst=1,nstm        
+       DO ji=1,kjpindex
+          tmc_litt_wet_mea(ji) =  tmc_litt_wet_mea(ji) + & 
+               & tmc_litter_awet(ji,jst)* soiltile(ji,jst)
+
+          tmc_litt_dry_mea(ji) = tmc_litt_dry_mea(ji) + &
+               & tmc_litter_adry(ji,jst) * soiltile(ji,jst) 
+
+          tmc_litt_mea(ji) = tmc_litt_mea(ji) + &
+               & tmc_litter(ji,jst) * soiltile(ji,jst) 
+       ENDDO
+    ENDDO
+
+    ! Caluculate frac_hydro_diag for interpolation between hydrological and diagnostic axes
+    CALL hydrol_calculate_frac_hydro_diag
+
+    ! Calculate shumdiag_perma (at diagnostic levels)
+    ! Use resdist instead of soiltile because we here need to have 
+    ! shumdiag_perma at the value from previous time step.
+    ! Here, soilmoist is only used as a temporary variable to calculate shumdiag_perma
+    ! (based on resdist=soiltile from previous timestep)
+    soilmoist(:,:) = zero
+    DO jst=1,nstm
+       DO ji=1,kjpindex
+          soilmoist(ji,1) = soilmoist(ji,1) + resdist(ji,jst) * &
+               dz(2) * ( trois*mc(ji,1,jst) + mc(ji,2,jst) )/huit
+          DO jsl = 2,nslm-1
+             soilmoist(ji,jsl) = soilmoist(ji,jsl) + resdist(ji,jst) * &
+                  ( dz(jsl) * (trois*mc(ji,jsl,jst)+mc(ji,jsl-1,jst))/huit &
+                  + dz(jsl+1) * (trois*mc(ji,jsl,jst)+mc(ji,jsl+1,jst))/huit )
+          END DO
+          soilmoist(ji,nslm) = soilmoist(ji,nslm) + resdist(ji,jst) * &
+               dz(nslm) * (trois*mc(ji,nslm,jst) + mc(ji,nslm-1,jst))/huit
+       ENDDO
+    ENDDO
+    ! -- shumdiag_perma for restart   
+    DO jd=1,nbdl
+       DO ji=1,kjpindex        
+          DO jsl = 1, nslm
+             shumdiag_perma(ji,jd) = soilmoist(ji,jsl)*frac_hydro_diag(jsl,jd) &
+                  /(dh(jsl)*mcs(njsc(ji)))
+          ENDDO
+          shumdiag_perma(ji,jd) = MAX(MIN(shumdiag_perma(ji,jd), un), zero) 
+       ENDDO
+    ENDDO
+               
+    ! Calculate drysoil_frac if it was not found in the restart file
+    IF (ALL(drysoil_frac(:) == val_exp)) THEN
+       DO ji=1,kjpindex
+          IF ( tmc_litt_wet_mea(ji) - tmc_litt_dry_mea(ji) > zero ) THEN
+             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)
+          ELSE
+             drysoil_frac(ji) = zero
+          ENDIF
+       END DO
+    END IF
+
+    !! Calculate the volumetric soil moisture content (mc_layh and mcl_layh) needed in 
+    !! thermosoil for the thermal conductivity. Calculate also total soil moisture content(tmc_layh) 
+    !! needed in thermosoil for the heat capacity.
+    mc_layh(:,:) = zero
+    mcl_layh(:,:) = zero
+    tmc_layh(:,:) = zero
+    DO jst=1,nstm
+
+      DO ji=1,kjpindex
+
+         DO jsl=1,nslm !loop layers 
+            mc_layh(ji,jsl) = mc_layh(ji,jsl) + mc(ji,jsl,jst) * soiltile(ji,jst)  * vegtot(ji)
+            mcl_layh(ji,jsl) = mcl_layh(ji,jsl) + mcl(ji,jsl,jst) * soiltile(ji,jst) * vegtot(ji)
+         ENDDO         !end layers 
+         tmc_layh_s(ji,1,jst) = dz(2) * ( trois*mc(ji,1,jst) + mc(ji,2,jst) )/huit 
+      
+         DO jsl = 2,nslm-1
+            tmc_layh_s(ji,jsl,jst) = dz(jsl) * (trois*mc(ji,jsl,jst)+mc(ji,jsl-1,jst))/huit &
+                + dz(jsl+1) * (trois*mc(ji,jsl,jst)+mc(ji,jsl+1,jst))/huit 
+         ENDDO
+            WRITE(numout,*) 'mc(ji,nslm,jst)',ji, jst, mc(ji,nslm-1,jst)
+            WRITE(numout,*) 'mc(ji,nslm,jst)',ji, jst, mc(ji,nslm,jst)
+         tmc_layh_s(ji,nslm,jst) = dz(nslm) * (trois*mc(ji,nslm,jst) + mc(ji,nslm-1,jst))/huit
+            
+           ! WRITE(numout,*) 'tmc layh_soiltile   hydrol', ji,jst, tmc_layh_s(ji,:,jst)
+            !WRITE(numout,*) 'tmc layh_soiltile 2  hydrol', ji, tmc_layh_s(ji,:,2)
+            !WRITE(numout,*) 'tmc layh_soiltile 3  hydrol', ji, tmc_layh_s(ji,:,3)
+            !WRITE(numout,*) 'avant calc tmc_layh(ji,jsl)', ji, tmc_layh(ji,:)
+            !WRITE(numout,*) 'soiltile(ji,jst)', ji,jst, soiltile(ji,jst)
+            !WRITE(numout,*) 'vegtot', ji, vegtot(ji)
+         DO jsl = 1,nslm
+            tmc_layh(ji,jsl) = tmc_layh(ji,jsl) + tmc_layh_s(ji,jsl,jst) * soiltile(ji,jst) * vegtot(ji)
+         ENDDO
+        
+           ! WRITE(numout,*) 'tmc layh hydrol', ji, tmc_layh(ji,:)
+
+      END DO
+    END DO
+
+! tzjwb
+!    IF (printlev>=3) WRITE (numout,*) ' hydrol_var_init done '
+
+  END SUBROUTINE hydrol_var_init
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: hydrol_snow
+!!
+!>\BRIEF        This routine computes snow processes. 
+!!
+!! DESCRIPTION  :
+!! - 0 initialisation
+!! - 1 On vegetation
+!! - 1.1 Compute snow masse
+!! - 1.2 Sublimation 
+!! - 1.2.1 Check that sublimation on the vegetated fraction is possible.
+!! - 1.3. snow melt only if temperature positive
+!! - 1.3.1 enough snow for melting or not
+!! - 1.3.2 not enough snow
+!! - 1.3.3 negative snow - now snow melt
+!! - 1.4 Snow melts only on weight glaciers
+!! - 2 On Land ice
+!! - 2.1 Compute snow
+!! - 2.2 Sublimation 
+!! - 2.3 Snow melt only for continental ice fraction
+!! - 2.3.1 If there is snow on the ice-fraction it can melt
+!! - 2.4 Snow melts only on weight glaciers 
+!! - 3 On other surface types - not done yet
+!! - 4 computes total melt (snow and ice)
+!! - 5 computes snow age on veg and ice (for albedo)
+!! - 5.1 Snow age on vegetation
+!! - 5.2 Snow age on ice
+!! - 6 Diagnose the depth of the snow layer
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_snow
+
+  SUBROUTINE hydrol_snow (kjpindex, precip_rain, precip_snow , temp_sol_new, soilcap,&
+       & frac_nobio, totfrac_nobio, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age, &
+       & tot_melt, snowdepth,snowmelt)
+
+    ! 
+    ! interface description
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex      !! Domain size
+    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+ ...
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: tot_melt      !! Total melt from snow and ice  
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: snowmelt      !! Snow melt
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: snowdepth     !! Snow depth
+
+    !! 0.3 Modified variables
+
+    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, ...
+
+    !! 0.4 Local variables
+
+    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 !
+    REAL(r_std)                                   :: snow_d1k !! The amount of snow that corresponds to a 1K cooling
+
+!_ ================================================================================================================================
+
+    !
+    ! for continental points
+    !
+
+    !
+    !!_0 initialisation
+    !
+    DO jv = 1, nnobio
+       DO ji=1,kjpindex
+          subsnownobio(ji,jv) = zero
+!WRITE(numout,*) 'tzjsnow points nnobio', ji
+       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 Compute snow masse
+       !
+       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
+!WRITE(numout,*) 'snow above snowcriparam', ji
+          subsnownobio(ji,iice) = frac_nobio(ji,iice)*vevapsno(ji)
+          subsnowveg(ji) = vevapsno(ji) - subsnownobio(ji,iice)
+       ELSE
+!WRITE(numout,*) 'snow below snowcriparam', ji
+          ! 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
+!WRITE(numout,*) 'fracnobio sup minsech', ji
+             subsnownobio(ji,iice) = vevapsno(ji)
+             subsnowveg(ji) = zero
+          ELSE 
+             subsnownobio(ji,iice) = zero
+             subsnowveg(ji) = vevapsno(ji)
+          ENDIF
+!WRITE(numout,*) 'fracnobio subsno', ji, vevapsno(ji)
+       ENDIF
+       ! here vevapsno bas been separated into a bio and nobio fractions, without changing the total
+       !
+       !
+    !! 1.2.1 Check that sublimation on the vegetated fraction is possible.
+       !
+       IF (subsnowveg(ji) .GT. snow(ji)) THEN
+!WRITE(numout,*) 'subsnow GT than snow', ji
+          ! What could not be sublimated goes into subsinksoil
+          IF( (un - totfrac_nobio(ji)).GT.min_sechiba) THEN
+             subsinksoil (ji) = (subsnowveg(ji) - snow(ji))/ (un - totfrac_nobio(ji))
+!WRITE(numout,*) 'subsinksoil', ji, subsinksoil (ji)
+          END IF
+          ! Sublimation is thus limited to what is available
+          ! Then, evavpsnow is reduced, of subsinksoil
+          subsnowveg(ji) = snow(ji)
+          snow(ji) = zero
+          vevapsno(ji) = subsnowveg(ji) + subsnownobio(ji,iice)
+!WRITE(numout,*) 'vevapsnow', ji, vevapsno(ji)
+       ELSE
+          snow(ji) = snow(ji) - subsnowveg(ji)
+!WRITE(numout,*) 'snow', ji, snow(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 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 Snow melts above a threshold
+       ! Ice melt only if there is more than a given mass : maxmass_snow,
+       ! But the snow cannot melt more in one time step to what corresponds to
+       ! a 1K cooling. This will lead to a progressive melting of snow above
+       ! maxmass_snow but it is needed as a too strong cooling can destabilise the model.
+       IF ( snow(ji) .GT. maxmass_snow ) THEN
+          snow_d1k = un * soilcap(ji) / chalfu0
+          snowmelt(ji) = snowmelt(ji) + MIN((snow(ji) - maxmass_snow),snow_d1k)
+          snow(ji) = snow(ji) - snowmelt(ji)
+! tzjwb
+!          IF ( printlev >= 3 ) WRITE (numout,*) "Snow was above maxmass_snow (", maxmass_snow,") and we melted ", snowmelt(ji)
+       ENDIF
+       
+    END DO
+    !
+    !! 2 On Land ice
+    !
+    DO ji=1,kjpindex
+       !
+    !! 2.1 Compute snow
+       !
+       !!??Aurelien: pkoi mettre precip_rain en dessous? We considere liquid precipitations becomes instantly snow?  
+       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_snow 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 Snow melts over a threshold
+       !   Ice melt only if there is more than a given mass : maxmass_snow, 
+       !   But the snow cannot melt more in one time step to what corresponds to
+       !   a 1K cooling. This will lead to a progressive melting of snow above
+       !   maxmass_snow but it is needed as a too strong cooling can destabilise the model.
+       !
+       IF ( snow_nobio(ji,iice) .GT. maxmass_snow ) THEN
+          snow_d1k = un * soilcap(ji) / chalfu0
+          icemelt(ji) = MIN((snow_nobio(ji,iice) - maxmass_snow),snow_d1k)
+          snow_nobio(ji,iice) = snow_nobio(ji,iice) - icemelt(ji)
+! tzjwb
+!          IF ( printlev >= 3 ) WRITE (numout,*) "Snow was above maxmass_snow ON ICE (", maxmass_snow,") and we melted ", icemelt(ji)
+       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'
+       CALL ipslerr_p(3,'hydrol_snow','nnobio > 1 not allowded','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) * dt_sechiba/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) * dt_sechiba/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 Diagnose the depth of the snow layer
+    !
+
+    DO ji = 1, kjpindex
+       snowdepth(ji) = snow(ji) /sn_dens
+    ENDDO
+! tzjwb
+!    IF (printlev>=3) WRITE (numout,*) ' hydrol_snow done '
+
+  END SUBROUTINE hydrol_snow
+
+   
+!! ================================================================================================================================
+!! SUBROUTINE 	: hydrol_canop
+!!
+!>\BRIEF        This routine computes canopy processes.
+!!
+!! DESCRIPTION  :
+!! - 1 evaporation off the continents
+!! - 1.1 The interception loss is take off the canopy. 
+!! - 1.2 precip_rain is shared for each vegetation type
+!! - 1.3 Limits the effect and sum what receives soil
+!! - 1.4 swap qsintveg to the new value
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_canop
+
+  SUBROUTINE hydrol_canop (kjpindex, precip_rain, vevapwet, veget_max, veget, qsintmax, &
+       & qsintveg,precisol,tot_melt)
+
+    ! 
+    ! interface description
+    !
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    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_max   !! max fraction of vegetation type
+    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
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(out)       :: precisol    !! Water fallen onto the ground (throughfall)
+
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: qsintveg    !! Water on vegetation due to interception
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                           :: ji, jv
+    REAL(r_std), DIMENSION (kjpindex,nvm)                    :: zqsintvegnew
+
+!_ ================================================================================================================================
+
+    ! 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=2,nvm
+       qsintveg(:,jv) = qsintveg(:,jv) - vevapwet(:,jv)
+    END DO
+
+    !     It is raining :
+    !! 1.2 precip_rain is shared for each vegetation type
+    !
+    qsintveg(:,1) = zero
+    DO jv=2,nvm
+       qsintveg(:,jv) = qsintveg(:,jv) + veget(:,jv) * ((1-throughfall_by_pft(jv))*precip_rain(:))
+       !write(*,*) 'print_interception_ratio', throughfall_by_pft(jv)
+    END DO
+   ! write(*,*) 'print_interception_ratio', throughfall_by_pft(jv)
+    !
+    !write(*,*) 'vevapwet_hyd',vevapwet(1,2)
+    !! 1.3 Limits the effect and sum what receives soil
+    !
+    precisol(:,1)=veget_max(:,1)*precip_rain(:)
+    DO jv=2,nvm
+       DO ji = 1, kjpindex
+          zqsintvegnew(ji,jv) = MIN (qsintveg(ji,jv),qsintmax(ji,jv)) 
+          precisol(ji,jv) = (veget(ji,jv)*throughfall_by_pft(jv)*precip_rain(ji)) + &
+               qsintveg(ji,jv) - zqsintvegnew (ji,jv) + &
+               (veget_max(ji,jv) - veget(ji,jv))*precip_rain(ji)
+       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_max(ji,jv)/vegtot(ji)
+          ENDIF
+       ENDDO
+    END DO
+    !   
+    !
+    !! 1.4 swap qsintveg to the new value
+    !
+    DO jv=2,nvm
+       qsintveg(:,jv) = zqsintvegnew (:,jv)
+    END DO
+! tzjwb
+!    IF (printlev>=3) WRITE (numout,*) ' hydrol_canop done '
+
+  END SUBROUTINE hydrol_canop
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: hydrol_vegupd
+!!
+!>\BRIEF        Vegetation update   
+!!
+!! DESCRIPTION  :
+!!   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.
+!!
+!! - 1 Update of vegetation is it needed?
+!! - 2 calculate water mass that we have to redistribute
+!! - 3 put it into reservoir of plant whose surface area has grown
+!! - 4 Soil tile gestion
+!! - 5 update the corresponding masks
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_vegupd
+
+  SUBROUTINE hydrol_vegupd(kjpindex, veget, veget_max, soiltile, qsintveg, resdist, frac_bare)
+
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    ! 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)   :: soiltile         !! Fraction of each soil tile (0-1, unitless)
+
+    !! 0.2 Output variables
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(out)    :: frac_bare        !! Fraction(of veget_max) of bare soil in each vegetation type
+
+    !! 0.3 Modified variables
+
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)  :: qsintveg         !! Water on old vegetation 
+    REAL(r_std), DIMENSION (kjpindex, nstm), INTENT(inout) :: resdist         !! Soiltile from previous time-step
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                 :: ji,jv,jst
+    REAL(r_std), DIMENSION(kjpindex)               :: tot_vegetmax_soil
+
+!_ ================================================================================================================================
+
+    !! 1 If veget has been updated at last time step (with LAND USE or DGVM),
+    !! tmc and mc must be modified with respect to humtot conservation.
+    CALL hydrol_tmc_update ( kjpindex, veget_max, soiltile, qsintveg, resdist )
+
+    ! Remember that it is only frac_nobio + SUM(veget_max(,:)) that is equal to 1. Thus we need vegtot
+    DO ji = 1, kjpindex
+       vegtot(ji) = SUM(veget_max(ji,:))
+    ENDDO
+
+    ! Compute the masks for veget
+    
+    mask_veget(:,:) = 0
+    mask_soiltile(:,:) = 0
+    
+    DO jst=1,nstm
+       DO ji = 1, kjpindex
+          IF(soiltile(ji,jst) .GT. min_sechiba) THEN
+             mask_soiltile(ji,jst) = 1
+          ENDIF
+       END DO
+    ENDDO
+          
+    DO jv = 1, nvm
+       DO ji = 1, kjpindex
+          IF(veget_max(ji,jv) .GT. min_sechiba) THEN
+             mask_veget(ji,jv) = 1
+          ENDIF
+       END DO
+    END DO
+
+    ! Compute vegetmax_soil 
+    vegetmax_soil(:,:,:) = zero
+    DO jv = 1, nvm
+       jst = pref_soil_veg(jv)
+       DO ji=1,kjpindex
+          ! for veget distribution used in sechiba via humrel
+          IF (mask_soiltile(ji,jst).GT.0 .AND. vegtot(ji) > min_sechiba) THEN
+             vegetmax_soil(ji,jv,jst)=veget_max(ji,jv)/soiltile(ji,jst)
+          ENDIF
+       ENDDO
+    ENDDO
+
+    IF (check_cwrr .AND. first_hydrol_main) THEN
+       ! somme(soiltile * vegetmax_soil ) = 1
+       tot_vegetmax_soil(:)=zero
+       DO jst = 1, nstm
+          DO jv = 1,nvm
+             DO ji=1,kjpindex
+                tot_vegetmax_soil(ji)=tot_vegetmax_soil(ji)+soiltile(ji,jst)*vegetmax_soil(ji,jv,jst)
+             ENDDO
+          ENDDO
+       ENDDO
+
+       DO ji=1,kjpindex
+          IF ( ABS( tot_vegetmax_soil(ji) - vegtot(ji) ) > 10*EPS1 ) THEN
+             WRITE(numout,*) 'vegetmax_soil SPLIT FALSE:ji=',ji,&
+                  tot_vegetmax_soil(ji)
+             WRITE(numout,*) 'err',ABS( tot_vegetmax_soil(ji) - vegtot(ji) )
+             WRITE(numout,*) 'vegtot',vegtot(ji)
+             DO jv=1,nvm
+                WRITE(numout,*) 'jv,veget_max,vegetmax_soil',jv,veget_max(ji,jv),vegetmax_soil(ji,jv,:)
+             END DO
+             CALL ipslerr_p(3, 'hydrol_vegupd', 'Error in tot_vegetmax_soil or vegtot','','')
+          ENDIF
+       ENDDO
+    ENDIF
+
+    ! Calculate frac_bare (previosly done in slowproc_veget)
+    DO ji =1, kjpindex
+       IF( veget_max(ji,1) .GT. min_sechiba ) THEN
+          frac_bare(ji,1) = un
+       ELSE
+          frac_bare(ji,1) = zero
+       ENDIF
+    ENDDO
+    DO jv = 2, nvm
+       DO ji =1, kjpindex
+          IF( veget_max(ji,jv) .GT. min_sechiba ) THEN
+             frac_bare(ji,jv) = un - veget(ji,jv)/veget_max(ji,jv)
+          ELSE
+             frac_bare(ji,jv) = zero
+          ENDIF
+       ENDDO
+    ENDDO
+
+    ! Tout dans cette routine est maintenant certainement obsolete (veget_max etant constant) en dehors des lignes 
+    ! suivantes et le calcul de frac_bare:
+    frac_bare_ns(:,:) = zero
+    DO jst = 1, nstm
+       DO jv = 1, nvm
+          DO ji =1, kjpindex
+             IF(vegtot(ji) .GT. min_sechiba) THEN
+                frac_bare_ns(ji,jst) = frac_bare_ns(ji,jst) + vegetmax_soil(ji,jv,jst) * frac_bare(ji,jv) / vegtot(ji)
+             ENDIF
+          END DO
+       ENDDO
+    END DO
+    
+! tzjwb
+!    IF (printlev>=3) WRITE (numout,*) ' hydrol_vegupd done '
+
+  END SUBROUTINE hydrol_vegupd
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: hydrol_flood
+!!
+!>\BRIEF        This routine computes the evolution of the surface reservoir (floodplain).  
+!!
+!! DESCRIPTION  :
+!! - 1 Take out vevapflo from the reservoir and transfer the remaining to subsinksoil
+!! - 2 Compute the total flux from floodplain floodout (transfered to routing)
+!! - 3 Discriminate between precip over land and over floodplain
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_flood
+
+  SUBROUTINE hydrol_flood (kjpindex, vevapflo, flood_frac, flood_res, floodout)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex         !!
+    ! input fields
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: flood_frac       !! Fraction of floodplains in grid box
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: floodout         !! Flux to take out from floodplains
+
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: flood_res        !! Floodplains reservoir estimate
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: vevapflo         !! Evaporation over floodplains
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                           :: ji, jv           !! Indices
+    REAL(r_std), DIMENSION (kjpindex)                        :: temp             !! 
+
+!_ ================================================================================================================================
+    !- 
+    !! 1 Take out vevapflo from the reservoir and transfer the remaining to subsinksoil 
+    !-
+    DO ji = 1,kjpindex
+       temp(ji) = MIN(flood_res(ji), vevapflo(ji))
+    ENDDO
+    DO ji = 1,kjpindex
+       flood_res(ji) = flood_res(ji) - temp(ji)
+       subsinksoil(ji) = subsinksoil(ji) + vevapflo(ji) - temp(ji)
+       vevapflo(ji) = temp(ji)
+    ENDDO
+
+    !- 
+    !! 2 Compute the total flux from floodplain floodout (transfered to routing) 
+    !-
+    DO ji = 1,kjpindex
+       floodout(ji) = vevapflo(ji) - flood_frac(ji) * SUM(precisol(ji,:))
+    ENDDO
+
+    !-
+    !! 3 Discriminate between precip over land and over floodplain
+    !-
+    DO jv=1, nvm
+       DO ji = 1,kjpindex
+          precisol(ji,jv) = precisol(ji,jv) * (1 - flood_frac(ji))
+       ENDDO
+    ENDDO 
+
+! tzjwb
+!    IF (printlev>=3) WRITE (numout,*) ' hydrol_flood done'
+
+  END SUBROUTINE hydrol_flood
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: hydrol_soil
+!!
+!>\BRIEF        This routine computes soil processes with CWRR scheme (Richards equation solved by finite differences).
+!! Note that the water fluxes are in kg/m2/dt_sechiba.
+!!
+!! DESCRIPTION  :
+!! 0. Initialisation, and split 2d variables to 3d variables, per soil tile
+!! -- START MAIN LOOP (prognostic loop to update mc and mcl) OVER SOILTILES
+!! 1. FIRSTLY, WE CHANGE MC BASED ON EXTERNAL FLUXES, ALL APPLIED AT THE SOIL SURFACE
+!! 1.1 Reduces water2infilt and water2extract to their difference 
+!! 1.2 To remove water2extract (including bare soilevaporation) from top layer
+!! 1.3 Infiltration
+!! 1.4 Reinfiltration of surface runoff : compute temporary surface water and extract from runoff
+!! 2. SECONDLY, WE UPDATE MC FROM DIFFUSION, INCLUDING DRAINAGE AND ROOTSINK
+!!    This will act on mcl (liquid water content) only
+!! 2.1 K and D are recomputed after infiltration
+!! 2.2 Set the tridiagonal matrix coefficients for the diffusion/redistribution scheme
+!! 2.3 We define mcl (liquid water content) based on mc and profil_froz_hydro_ns
+!! 2.4 We calculate the total SM at the beginning of the routine tridiag for water conservation check
+!! 2.5 Defining where diffusion is solved : everywhere
+!! 2.6 We define the system of linear equations for mcl redistribution
+!! 2.7 Solves diffusion equations
+!! 2.8 Computes drainage = bottom boundary condition, consistent with rhs(ji,jsl=nslm)
+!! 2.9 For water conservation check during redistribution, we calculate the total liquid SM
+!!     at the end of the routine tridiag, and we compare the difference with the flux...
+!! 3. AFTER DIFFUSION/REDISTRIBUTION
+!! 3.1 Updating mc, as all the following checks against saturation will compare mc to mcs
+!! 3.2 Correct here the possible over-saturation values (subroutine hydrol_soil_smooth_over_mcs2 acts on mc)
+!!     Here hydrol_soil_smooth_over_mcs2 discard all excess as ru_corr_ns, oriented to either ru_ns or dr_ns
+!! 3.3 Negative runoff is reported to drainage
+!! 3.4 Optional block to force saturation below zwt_force
+!! 3.5 Diagnosing the effective water table depth
+!! 3.6 Diagnose under_mcr to adapt water stress calculation below
+!! 4. At the end of the prognostic calculations, we recompute important moisture variables
+!! 4.1 Total soil moisture content (water2infilt added below)
+!! 4.2 mcl is a module variable; we update it here for calculating bare soil evaporation,
+!! 5. Optional check of the water balance of soil column (if check_cwrr)
+!! 5.1 Computation of the vertical water fluxes
+!! 5.2 Total mc conservation
+!! 5.3 Total mc should not reach zero, or the tridiag solver will have problems
+!! 6. SM DIAGNOSTICS FOR OTHER ROUTINES, MODULES, OR NEXT STEP
+!! 6.1 Total soil moisture, soil moisture at litter levels, soil wetness, us, humrelv, vesgtressv
+!! 6.2 We need to turn off evaporation when is_under_mcr
+!! 6.3 Calculate the volumetric soil moisture content (mc_layh and mcl_layh) needed in thermosoil
+!! 6.4 The hydraulic conductivities exported here are the ones used in the diffusion/redistribution
+!! -- ENDING THE MAIN LOOP ON SOILTILES
+!! 7. Summing 3d variables into 2d variables
+!! 8. XIOS export of local variables, including water conservation checks
+!! 9. COMPUTING EVAP_BARE_LIM_NS FOR NEXT TIME STEP, WITH A LOOP ON SOILTILES
+!!    The principle is to run a dummy integration of the water redistribution scheme
+!!    to check if the SM profile can sustain a potential evaporation.
+!!    If not, the dummy integration is redone from the SM profile of the end of the normal integration,
+!!    with a boundary condition leading to a very severe water limitation: mc(1)=mcr
+!! 10. evap_bar_lim is the grid-cell scale beta
+!! 11. Exit if error was found previously in this subroutine
+!!
+!! RECENT CHANGE(S) : 2016 by A. Ducharne
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) :
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_soil
+
+!  SUBROUTINE hydrol_soil (kjpindex, veget_max, soiltile, njsc, reinf_slope, &
+!       & transpir, vevapnu, evapot, evapot_penm, runoff, drainage, &
+!       & returnflow, reinfiltration, irrigation, &
+!       & tot_melt, evap_bare_lim, shumdiag, shumdiag_perma,&
+!       & k_litt, litterhumdiag, humrel,vegstress, drysoil_frac, &
+!       & stempdiag,snow, &
+!       & snowdz, tot_bare_soil, mc_layh, mcl_layh, tmc_layh)
+! tzjwb    ! 
+  SUBROUTINE hydrol_soil (kjpindex, veget_max, soiltile, njsc, reinf_slope, &
+       & transpir, vevapnu, evapot, evapot_penm, runoff, drainage, &
+       & returnflow, reinfiltration, irrigation, &
+       & tot_melt, evap_bare_lim, shumdiag, shumdiag_perma,&
+       & k_litt, litterhumdiag, humrel,vegstress, drysoil_frac, &
+       & stempdiag,snow , tot_bare_soil, mc_layh, mcl_layh, tmc_layh, swc,ksave,soil_waterinf_ns, soil_dtinf_ns, soil_infilttmp_ns, soil_km_ns, soil_smcinfilt_ns, soil_totalinfilt_ns, begin_infilt_ns, soil_resinfilt_ns)
+! tzjswc
+
+    ! interface description
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                               :: kjpindex 
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)       :: veget_max        !! Map of max vegetation types [-]
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)         :: njsc             !! Index of the dominant soil textural class 
+                                                                                 !!   in the grid cell (1-nscm, unitless)
+    REAL(r_std), DIMENSION (kjpindex,nstm), INTENT (in)      :: soiltile         !! Fraction of each soil tile (0-1, unitless)
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)        :: transpir         !! Transpiration  
+                                                                                 !!  @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT (in)           :: reinf_slope      !! Fraction of surface runoff that reinfiltrates
+                                                                                 !!  (unitless, [0-1])
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: returnflow       !! Water returning to the soil from the bottom
+                                                                                 !!  @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: reinfiltration   !! Water returning to the top of the soil
+                                                                                 !!  @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: irrigation       !! Irrigation
+                                                                                 !!  @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: evapot           !! Potential evaporation
+                                                                                 !!  @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: evapot_penm      !! Potential evaporation "Penman" (Milly's correction)
+                                                                                 !!  @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: tot_melt         !! Total melt from snow and ice
+                                                                                 !!  @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in)       :: stempdiag        !! Diagnostic temp profile from thermosoil
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: snow             !! Snow mass
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex
+ !   REAL(r_std), DIMENSION (kjpindex,nsnow),INTENT(in)       :: snowdz           !! Snow depth (m)
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: tot_bare_soil    !! Total evaporating bare soil fraction 
+                                                                                 !!  (unitless, [0-1])
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: runoff           !! Surface runoff
+                                                                                 !!  @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: drainage         !! Drainage
+                                                                                 !!  @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: evap_bare_lim    !! Limitation factor (beta) for bare soil evaporation  
+                                                                                 !! on each soil column (unitless, [0-1])
+    REAL(r_std), DIMENSION (kjpindex,nbdl), INTENT (out)     :: shumdiag         !! Relative soil moisture in each diag soil layer 
+                                                                                 !! with respect to (mcf-mcw) (unitless, [0-1])
+    REAL(r_std), DIMENSION (kjpindex,nbdl), INTENT (out)     :: shumdiag_perma   !! Percent of porosity filled with water (mc/mcs)
+                                                                                 !! in each diag soil layer (for the thermal computations)
+                                                                                 !! (unitless, [0-1])
+    REAL(r_std), DIMENSION (kjpindex), INTENT (out)          :: k_litt           !! Litter approximated hydraulic conductivity
+                                                                                 !!  @tex $(mm d^{-1})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT (out)          :: litterhumdiag    !! Mean of soil_wet_litter across soil tiles
+                                                                                 !! (unitless, [0-1])
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(out)      :: vegstress        !! Veg. moisture stress (only for vegetation 
+                                                                                 !! growth) (unitless, [0-1])
+    REAL(r_std), DIMENSION (kjpindex), INTENT (out)          :: drysoil_frac     !! Function of the litter humidity
+    REAL(r_std), DIMENSION (kjpindex,nslm), INTENT (out)     :: mc_layh          !! Volumetric water content (liquid + ice) for each soil layer
+                                                                                 !! averaged across soiltiles (for thermosoil)
+                                                                                 !!  @tex $(m^{3} m^{-3})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex,nslm), INTENT (out)     :: mcl_layh         !! Volumetric liquid water content for each soil layer 
+                                                                                 !! averaged across soiltiles (for thermosoil)
+                                                                                 !!  @tex $(m^{3} m^{-3})$ @endtex 
+    REAL(r_std), DIMENSION (kjpindex,nslm), INTENT (out)     :: tmc_layh         !! Soil moisture (liquid + ice) for soil each layer 
+                                                                                 !! averaged across soiltiles (for thermosoil)
+                                                                                 !!  @tex $(m^{3} m^{-3})$ @endtex 
+
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: vevapnu          !! Bare soil evaporation
+                                                                                 !!  @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (inout)    :: humrel           !! Relative humidity (0-1, dimensionless)
+! tzjswc tzjrs
+    REAL(r_std), DIMENSION (kjpindex,nslm,nstm), INTENT(inout) :: swc !! Soil water content (a copy of mc)
+    REAL(r_std), DIMENSION (kjpindex,nslm,nstm), INTENT(inout) :: ksave !! Soil conductivity (a copy of k for each soil type)
+   REAL(r_std), DIMENSION (kjpindex,nslm,nstm), INTENT(inout) :: soil_waterinf_ns
+   REAL(r_std), DIMENSION (kjpindex,nslm,nstm), INTENT(inout) :: soil_dtinf_ns
+   REAL(r_std), DIMENSION (kjpindex,nslm,nstm), INTENT(inout) :: soil_infilttmp_ns
+   REAL(r_std), DIMENSION (kjpindex,nslm,nstm), INTENT(inout) :: soil_km_ns
+   REAL(r_std), DIMENSION (kjpindex,nslm,nstm), INTENT(inout) :: soil_smcinfilt_ns
+   REAL(r_std), DIMENSION (kjpindex,nslm,nstm), INTENT(inout) :: soil_resinfilt_ns
+   REAL(r_std), DIMENSION (kjpindex,nstm), INTENT(inout)  :: begin_infilt_ns
+   REAL(r_std), DIMENSION (kjpindex,nstm), INTENT(inout)  :: soil_totalinfilt_ns    
+!! 0.4 Local variables
+
+!    INTEGER(i_std)                                 :: ji, jv, jsl, jst           !! Indices
+    INTEGER(i_std)                                 :: ji, jv, jsl, jst, ivm           !! Indices
+    REAL(r_std), PARAMETER                         :: frac_mcs = 0.66            !! Temporary depth
+    REAL(r_std), DIMENSION(kjpindex)               :: temp                       !! Temporary value for fluxes
+    REAL(r_std), DIMENSION(kjpindex)               :: tmcold                     !! Total SM at beginning of hydrol_soil (kg/m2)
+    REAL(r_std), DIMENSION(kjpindex)               :: tmcint                     !! Ancillary total SM (kg/m2)
+    REAL(r_std), DIMENSION(kjpindex,nslm)          :: mcint                      !! To save mc values for future use
+    REAL(r_std), DIMENSION(kjpindex,nslm)          :: mclint                     !! To save mcl values for future use
+    LOGICAL, DIMENSION(kjpindex,nstm)              :: is_under_mcr               !! Identifies under residual soil moisture points
+    LOGICAL, DIMENSION(kjpindex)                   :: is_over_mcs                !! Identifies over saturated soil moisture points 
+    REAL(r_std), DIMENSION(kjpindex)               :: deltahum,diff              !!
+    LOGICAL(r_std), DIMENSION(kjpindex)            :: test                       !!
+    REAL(r_std), DIMENSION(kjpindex)               :: water2extract              !! Water flux to be extracted at the soil surface
+                                                                                 !!  @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std), DIMENSION(kjpindex)               :: returnflow_soil            !! Water from the routing back to the bottom of 
+                                                                                 !! the soil @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std), DIMENSION(kjpindex)               :: reinfiltration_soil        !! Water from the routing back to the top of the 
+                                                                                 !! soil @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std), DIMENSION(kjpindex)               :: irrigation_soil            !! Water from irrigation returning to soil moisture 
+                                                                                 !!  @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std), DIMENSION(kjpindex)               :: flux_infilt                !! Water to infiltrate
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(kjpindex)               :: flux_bottom                !! Flux at bottom of the soil column
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(kjpindex)               :: flux_top                   !! Flux at top of the soil column (for bare soil evap)
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex,nstm)         :: qinfilt_ns                 !! Effective infiltration flux per soil tile
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex   
+    REAL(r_std), DIMENSION (kjpindex)              :: qinfilt                    !! Effective infiltration flux  
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION (kjpindex,nstm)         :: ru_infilt_ns               !! Surface runoff from hydrol_soil_infilt per soil tile
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex   
+    REAL(r_std), DIMENSION (kjpindex)              :: ru_infilt                  !! Surface runoff from hydrol_soil_infilt 
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex 
+! three variables were added by yitong yao 4 Jan 2021
+!REAL(r_std), DIMENSION (kjpindex,nslm,nstm)         :: soil_waterinf_ns
+!REAL(r_std), DIMENSION (kjpindex,nslm,nstm)         :: soil_dtinf_ns
+!REAL(r_std), DIMENSION (kjpindex,nslm,nstm)         :: soil_infilttmp_ns
+!REAL(r_std), DIMENSION (kjpindex,nslm,nstm)         :: soil_km_ns
+!REAL(r_std), DIMENSION (kjpindex,nslm,nstm)         :: soil_smcinfilt_ns
+! above added     
+
+REAL(r_std), DIMENSION (kjpindex,nstm)         :: ru_corr_ns                 !! Surface runoff produced to correct excess per soil tile
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex)              :: ru_corr                    !! Surface runoff produced to correct excess 
+                                                                                 !!  @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex  
+    REAL(r_std), DIMENSION (kjpindex,nstm)         :: ru_corr2_ns                !! Correction of negative surface runoff per soil tile
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex)              :: ru_corr2                   !! Correction of negative surface runoff
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION (kjpindex,nstm)         :: dr_corr_ns                 !! Drainage produced to correct excess
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex,nstm)         :: dr_corrnum_ns              !! Drainage produced to correct numerical errors in tridiag
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex    
+    REAL(r_std), DIMENSION (kjpindex)              :: dr_corr                    !! Drainage produced to correct excess 
+                                                                                 !!  @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex)              :: dr_corrnum                 !! Drainage produced to correct numerical errors in tridiag
+                                                                                 !!  @tex $(kg m^{-2} dt\_sechiba^{-1})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex,nslm)         :: dmc                        !! Delta mc when forcing saturation (zwt_force) 
+                                                                                 !!  @tex $(m^{3} m^{-3})$ @endtex 
+    REAL(r_std), DIMENSION (kjpindex,nstm)         :: dr_force_ns                !! Delta drainage when forcing saturation (zwt_force) 
+                                                                                 !!  per soil tile  @tex $(kg m^{-2})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex)              :: dr_force                   !! Delta drainage when forcing saturation (zwt_force)
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex  
+    REAL(r_std), DIMENSION (kjpindex,nstm)         :: wtd_ns                     !! Effective water table depth (m)
+    REAL(r_std), DIMENSION (kjpindex)              :: wtd                        !! Mean water table depth in the grid-cell (m)
+    REAL(r_std), DIMENSION (kjpindex,nslm,nstm)    :: tmc_layh_ns                !! Soil moisture content forin  each soil layer
+                                                                                 !! and each soiltile
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex
+    LOGICAL                                        :: error=.FALSE.              !! If true, exit in the end of subroutine
+
+    ! For the calculation of soil_wet and us/humrel/vegstress 
+    REAL(r_std), DIMENSION (kjpindex,nslm)         :: sm                         !! Soil moisture of each layer
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex
+    REAL(r_std), DIMENSION (kjpindex,nslm)         :: smw                        !! Soil moisture of each layer at wilting point
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION (kjpindex,nslm)         :: smf                        !! Soil moisture of each layer at field capacity
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex   
+    REAL(r_std), DIMENSION (kjpindex,nslm)         :: sms                        !! Soil moisture of each layer at saturation
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION (kjpindex,nslm)         :: sm_nostress                !! Soil moisture of each layer at which us reaches 1
+                                                                                 !!  @tex $(kg m^{-2})$ @endtex 
+    ! For water conservation checks (in mm/dtstep unless otherwise mentioned)
+    REAL(r_std), DIMENSION (kjpindex,nstm)         :: check_infilt_ns             !! Water conservation diagnostic at routine scale
+    REAL(r_std), DIMENSION (kjpindex,nstm)         :: check1_ns                   !! Water conservation diagnostic at routine scale
+    REAL(r_std), DIMENSION (kjpindex,nstm)         :: check_tr_ns                 !! Water conservation diagnostic at routine scale
+    REAL(r_std), DIMENSION (kjpindex,nstm)         :: check_over_ns               !! Water conservation diagnostic at routine scale
+    REAL(r_std), DIMENSION (kjpindex,nstm)         :: check_under_ns              !! Water conservation diagnostic at routine scale
+    REAL(r_std), DIMENSION(kjpindex)               :: tmci                        !! Total soil moisture at beginning of routine (kg/m2)
+    REAL(r_std), DIMENSION(kjpindex)               :: tmcf                        !! Total soil moisture at end of routine (kg/m2)
+    REAL(r_std), DIMENSION(kjpindex)               :: diag_tr                     !! Transpiration flux
+    REAL(r_std), DIMENSION (kjpindex)              :: check_infilt                !! Water conservation diagnostic at routine scale 
+    REAL(r_std), DIMENSION (kjpindex)              :: check1                      !! Water conservation diagnostic at routine scale 
+    REAL(r_std), DIMENSION (kjpindex)              :: check_tr                    !! Water conservation diagnostic at routine scale 
+    REAL(r_std), DIMENSION (kjpindex)              :: check_over                  !! Water conservation diagnostic at routine scale 
+    REAL(r_std), DIMENSION (kjpindex)              :: check_under                 !! Water conservation diagnostic at routine scale
+ !tzjdz
+    REAL(r_std), DIMENSION (nslm)                       :: nroot_tmp
+!    REAL(r_std), DIMENSION (kjpindex,nslm)         :: smf_tmp
+!    REAL(r_std), DIMENSION (kjpindex,nslm)         :: smw_tmp
+
+
+! Declaration for dynamic roots 
+REAL(r_std),DIMENSION(kjpindex,nbdl,nstm)       :: phi_soiltile        !! soil water potentential per soil layer per soil tile 
+REAL(r_std),DIMENSION(kjpindex,nbdl,nstm)       :: phi_soil     !! soil water potentential per soil layer per soil tile 
+REAL(r_std), DIMENSION(kjpindex,nbdl,nstm)      :: ksaveUNIT            !! Soil water potential per soil layer per soiltile higher
+REAL(r_std), DIMENSION(kjpindex,nbdl,nstm)      :: e_frac            !! Soilwater potential per soil layer per soiltile higher 
+REAL(r_std), DIMENSION(kjpindex,nbdl,nstm)      :: e_max            !! Soilwater potential per soil layer per soiltile higher 
+REAL(r_std), DIMENSION(kjpindex,nbdl,nstm)      :: res_soil            !! Soil water potential per soil layer per soiltile higher 
+REAL(r_std), DIMENSION(nbdl)                   :: slr     !! @tex
+REAL(r_std), DIMENSION(nbdl)                   :: rs     !! @tex
+REAL(r_std), DIMENSION(nbdl)                   :: lr     !! @tex
+REAL(r_std), DIMENSION(nbdl,nvm)                :: root_dens           !! root density per layer
+REAL(r_std), DIMENSION(nvm)                     :: rpc                 !!scaling factor for integral
+REAL(r_std),DIMENSION (kjpindex,nbdl,nstm)      :: swc_adj             !!Volumetric soil water content, adjusted when it is lower 
+
+REAL(r_std), DIMENSION(nbdl+1)                :: z_soil
+!! Soil levels (m)
+LOGICAL, SAVE                                  :: rsoilroot = .TRUE.
+!$OMP THREADPRIVATE(rsoilroot)
+!_ ================================================================================================================================
+
+    !ex! 0.1 Arrays with DIMENSION(kjpindex)
+    
+    returnflow_soil(:) = zero
+    reinfiltration_soil(:) = zero
+    irrigation_soil(:) = zero
+    qflux(:,:,:) = zero
+    mc_layh(:,:) = zero ! for thermosoil
+    mcl_layh(:,:) = zero ! for thermosoil
+    tmc_layh(:,:) = zero ! for thermosoil
+    tmc_layh_ns(:,:,:) = zero
+    IF (ok_freeze_cwrr) THEN
+       kk(:,:,:)=zero
+       kk_moy(:,:)=zero
+    ENDIF
+    undermcr(:) = zero ! needs to be initialized outside from jst loop
+    
+    ! initialize five variables added by yitong yao 5 Jan 2021
+    !soil_waterinf_ns(:,:,:)=zero
+    !soil_dtinf_ns(:,:,:)=zero
+    !soil_infilttmp_ns(:,:,:)=zero
+    !soil_km_ns(:,:,:)=zero
+    !soil_smcinfilt_ns(:,:,:)=zero
+    ! above added 
+    IF (ok_freeze_cwrr) THEN
+       
+       ! 0.1 Calculate the temperature and fozen fraction at the hydrological levels
+       
+       ! AD16*** This subroutine could probably be simplified massively given
+       ! that hydro and T share the same vertical discretization 
+       ! Here stempdiag is in from thermosoil and temp_hydro is out
+     !  CALL hydrol_calculate_temp_hydro(kjpindex, stempdiag, snow,snowdz)
+       CALL hydrol_calculate_temp_hydro(kjpindex, stempdiag, snow)
+       
+       ! Calculates profil_froz_hydro_ns as a function of temp_hydro, and mc if ok_thermodynamical_freezing
+       ! These values will be kept till the end of the prognostic loop
+       DO jst=1,nstm
+          CALL hydrol_soil_froz(kjpindex,jst,njsc)
+       ENDDO
+
+    ELSE
+  
+       profil_froz_hydro_ns(:,:,:) = zero
+             
+    ENDIF
+
+    !! 0.2 Split 2d variables to 3d variables, per soil tile
+    !  Here, the evaporative fluxes are distributed over the soiltiles as a function of the 
+    !    corresponding control factors; they are normalized to vegtot
+    !  At step 7, the reverse transformation is used for the fluxes produced in hydrol_soil
+    !    flux_cell(ji)=sum(flux_ns(ji,jst)*soiltile(ji,jst)*vegtot(ji))
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+CALL getin_p('rsoilroot',rsoilroot)  !!! CHECK if OK 
+!WRITE(*,*) "test flagtzj hydrol", rsoilroot
+
+phi_soiltile(:,:,:) = -un ! need to calculate the soil water potential 
+!initialize just in case
+!e_frac(:,:,:) = -un
+
+! WRITE(*,*) "phi_soiltile debut",phi_soiltile
+
+ z_soil(1)= 0.
+ z_soil(2:nslm+1) = diaglev(1:nslm)
+!WRITE(*,*) "zsoil hydrol", z_soil
+
+
+DO ji=1,kjpindex
+
+  ! need to calculate the soil water potential 
+       !! Calculate soil water potential
+       !  Swc calculated in hydrol.f90 cannot be lower than or equal 
+       !  to the residual soil water content for each soiltile.
+  DO jsl = 1, nslm
+
+          DO jv = 1,nstm
+          IF (mc(ji,jsl,jv) .LE. mcr(njsc(ji)))  THEN
+          swc_adj(ji,jsl,jv) = mcr(njsc(ji))  + .00001
+          ELSE
+          swc_adj(ji,jsl,jv) = mc(ji,jsl,jv)
+          END IF
+
+          ENDDO !soiltype
+  !in sechiba_hydrol_arch l_first perhaps no need here
+
+          DO jv =1, nstm
+               IF (swc_adj(ji,jsl,jv) .GT. min_stomate .AND. &
+                  (swc_adj(ji,jsl,jv) - mcr(njsc(ji))) .GT. min_stomate) THEN
+
+                      phi_soiltile(ji,jsl,jv) = &
+                           - ( cte_grav * rho_h2o * kilo_to_unit * &
+                             ( 1/(avan(njsc(ji))*kilo_to_unit) ) * &
+                             ( ( (swc_adj(ji,jsl,jv) - mcr(njsc(ji)) ) / &
+                             ( mcs(njsc(ji)) - mcr(njsc(ji)) ) ) ** &
+                             ( -1 / (1-1/nvan(njsc(ji))) ) - 1) ** &
+                             (1/nvan(njsc(ji)) ) ) / mega_to_unit
+                ELSE 
+                      phi_soiltile(ji,jsl,jv) = zero
+                END IF
+   
+          phi_soil(ji,jsl,:) = MAX(phi_soiltile(ji,jsl,:),pres_soil_potential_min)
+
+          ENDDO !soil type
+   ENDDO ! soil layers
+! in sechiba_hydrol_arch flag initialization off
+
+
+        ! rpc and root_dens computation 
+
+  rpc(:) = un / ( un - EXP( -z_soil(nslm) / humcste(:) ) )
+
+
+  DO jsl = 1, nslm ! Loop over # soil layers
+      root_dens(jsl,:) = rpc(:) * &
+     ( EXP( -z_soil(jsl)/humcste(:)) - &
+      EXP( -z_soil(jsl+1)/humcste(:)) )
+  ENDDO ! Loop over # soil layers
+
+
+  DO ivm=2, nvm
+
+    IF ((rsoilroot) .AND. (ivm .EQ. 2)) THEN
+
+          !! we need the soil conductivity from hydrol_soil_coef (for the soil
+          !type 2 we get ksave) 
+          jst=2
+          CALL hydrol_soil_coef(kjpindex,jst,njsc)
+          ! WRITE(*,*) 'k_hydrol', k
+          ! WRITE(*,*) 'k_save', ksave(:,:,2)
+
+
+         ! THIS CONCERN only ISTM (soiltype=2)  
+         !Define some parameters (hard coded for now, only for PFT2) 
+        ! rr=0.29E-3 !rr fine root radius (m) ; in Bonan et al., 2014 GMD rr â 0.29
+        ! srl=10 ! (m/g specific roots lenght value from Metcalfe et al.,2008)
+
+            DO jsl=1,nslm
+           !!lr(jsl)=root_dens(jsl,jv)*2*biomass(ipts,ivm,iroot,icarbon)* srl ! 
+             lr(jsl)=root_dens(jsl,ivm)*2*60*10 ! 
+           ! lr(jsl)=root_dens(jsl,jv)*2*60*10 ! 
+           ! rs(jsl)=(1/(3.14*lr(jsl)*dlh(jsl)))**(1/2)
+             rs(jsl)=(1/(3.14*lr(jsl)))**(1/2)
+
+             ksaveUNIT(ji,jsl,2)=ksave(ji,jsl,2)*1000/(60*60*24)
+             res_soil(ji,jsl,2)=(LOG(rs(jsl)/0.29E-3))/(dlh(jsl)*2*3.14*lr(jsl)*(ksaveUNIT(ji,jsl,2)/(9.8*18E-5*1E-3)))
+             e_max(ji,jsl,2)= (phi_soil(ji,jsl,2)-(-4))/res_soil(ji,jsl,2)
+             IF (e_max(ji,jsl,2) .LT. min_sechiba)  e_max(ji,jsl,2) = 0
+
+            ENDDO !loop over soil layers
+
+            IF (SUM(e_max(ji,:,2)) .GT. min_sechiba) THEN
+                DO jsl=1,nslm
+                e_frac(ji,jsl,2)=e_max(ji,jsl,2)/SUM(e_max(ji,:,2))
+                ENDDO
+            ELSE 
+                ! e_frac(ji,jsl,2)= - un
+                 e_frac(ji,jsl,2)= zero
+            ENDIF !condition sur e_max
+
+    ELSE
+   ! e_frac(ji,:,:) = -un
+    e_frac(ji,:,:) = zero
+    ENDIF !rsoil  ivm=2
+
+ENDDO ! pft loop
+ENDDO ! land points
+
+
+    CALL hydrol_split_soil (kjpindex, veget_max, soiltile, vevapnu, transpir, humrel, evap_bare_lim, tot_bare_soil, e_frac)
+!WRITE(numout,*) 'Eroot_sink  per pft', rootsink(10,:,3)
+
+    !! 0.3 Common variables related to routing, with all return flow applied to the soil surface
+    ! The fluxes coming from the routing are uniformly splitted into the soiltiles,
+    !    but are normalized to vegtot like the above fluxes: 
+    !            flux_ns(ji,jst)=flux_cell(ji)/vegtot(ji)
+    ! It is the case for : irrigation_soil(ji) and reinfiltration_soil(ji) cf below
+    ! It is also the case for subsinksoil(ji), which is divided by (1-tot_frac_nobio) at creation in hydrol_snow
+    ! AD16*** The transformation in 0.2 and 0.3 is likely to induce conservation problems
+    !         when tot_frac_nobio NE 0, since sum(soiltile) NE vegtot in this case
+    
+    DO ji=1,kjpindex
+       IF(vegtot(ji).GT.min_sechiba) THEN
+          ! returnflow_soil is assumed to enter from the bottom, but it is not possible with CWRR
+          returnflow_soil(ji) = zero
+          reinfiltration_soil(ji) = (returnflow(ji) + reinfiltration(ji))/vegtot(ji)
+          irrigation_soil(ji) = irrigation(ji)/vegtot(ji)
+       ELSE
+          returnflow_soil(ji) = zero
+          reinfiltration_soil(ji) = zero
+          irrigation_soil(ji) = zero
+       ENDIF
+    ENDDO  
+
+       
+    !! -- START MAIN LOOP (prognostic loop to update mc and mcl) OVER SOILTILES
+    !!    The called subroutines work on arrays with DIMENSION(kjpindex),
+    !!    recursively used for each soiltile jst
+    
+    DO jst = 1,nstm
+
+       is_under_mcr(:,jst) = .FALSE.
+       is_over_mcs(:) = .FALSE.
+       
+       !! 0.4. Keep initial values for future check-up
+       
+       ! Total moisture content (including water2infilt) is saved for balance checks at the end
+       ! In hydrol_tmc_update, tmc is increased by water2infilt(ji,jst), but mc is not modified !
+       tmcold(:) = tmc(:,jst)
+       
+       ! The value of mc is kept in mcint (nstm dimension removed), in case needed for water balance checks 
+       DO jsl = 1, nslm
+          DO ji = 1, kjpindex
+             mcint(ji,jsl) = mask_soiltile(ji,jst) * mc(ji,jsl,jst)
+          ENDDO
+       ENDDO
+       !
+       ! Initial total moisture content : tmcint does not include water2infilt, contrarily to tmcold
+       DO ji = 1, kjpindex
+          tmcint(ji) = dz(2) * ( trois*mcint(ji,1) + mcint(ji,2) )/huit 
+       ENDDO
+       DO jsl = 2,nslm-1
+          DO ji = 1, kjpindex
+             tmcint(ji) = tmcint(ji) + dz(jsl) &
+                  & * (trois*mcint(ji,jsl)+mcint(ji,jsl-1))/huit &
+                  & + dz(jsl+1) * (trois*mcint(ji,jsl)+mcint(ji,jsl+1))/huit
+          ENDDO
+       ENDDO
+       DO ji = 1, kjpindex
+          tmcint(ji) = tmcint(ji) + dz(nslm) &
+               & * (trois * mcint(ji,nslm) + mcint(ji,nslm-1))/huit
+       ENDDO
+
+       !! 1. FIRSTLY, WE CHANGE MC BASED ON EXTERNAL FLUXES, ALL APPLIED AT THE SOIL SURFACE
+       !!   Input = water2infilt(ji,jst) + irrigation_soil(ji) + reinfiltration_soil(ji) + precisol_ns(ji,jst)
+       !!      - negative evaporation fluxes (MIN(ae_ns(ji,jst),zero)+ MIN(subsinksoil(ji),zero))
+       !!   Output = MAX(ae_ns(ji,jst),zero) + subsinksoil(ji) = positive evaporation flux = water2extract
+       ! In practice, negative subsinksoil(ji) is not possible 
+
+       !! 1.1 Reduces water2infilt and water2extract to their difference 
+
+       ! Compares water2infilt and water2extract to keep only difference
+       ! Here, temp is used as a temporary variable to store the min of water to infiltrate vs evaporate
+       DO ji = 1, kjpindex
+          temp(ji) = MIN(water2infilt(ji,jst) + irrigation_soil(ji) + reinfiltration_soil(ji) &
+                         - MIN(ae_ns(ji,jst),zero) - MIN(subsinksoil(ji),zero) + precisol_ns(ji,jst), &
+                           MAX(ae_ns(ji,jst),zero) + MAX(subsinksoil(ji),zero) )
+       ENDDO
+!WRITE(numout,*) 'temp', temp(10)
+       ! The water to infiltrate at the soil surface is either 0, or the difference to what has to be evaporated
+       !   - the initial water2infilt (right hand side) results from qsintveg changes with vegetation updates
+       !   - irrigation_soil is the input flux to the soil surface from irrigation 
+       !   - reinfiltration_soil is the input flux to the soil surface from routing 'including returnflow)
+       !   - eventually, water2infilt holds all fluxes to the soil surface except precisol (reduced by water2extract)
+       DO ji = 1, kjpindex
+          water2infilt(ji,jst) = water2infilt(ji,jst) + irrigation_soil(ji) + reinfiltration_soil(ji) &
+                - MIN(ae_ns(ji,jst),zero) - MIN(subsinksoil(ji),zero) + precisol_ns(ji,jst) &
+                - temp(ji) 
+       ENDDO       
+!  WRITE(numout,*) 'tmp1',jst, water2infilt(10,jst), ae_ns(10,jst), precisol_ns(10,jst) 
+       ! The water to evaporate from the sol surface is either the difference to what has to be infiltrated, or 0
+       !   - subsinksoil is the residual from sublimation is the snowpack is not sufficient
+       !   - how are the negative values of ae_ns taken into account ??? 
+       DO ji = 1, kjpindex
+          water2extract(ji) =  MAX(ae_ns(ji,jst),zero) + MAX(subsinksoil(ji),zero) - temp(ji) 
+       ENDDO
+       ! Here we acknowledge that subsinksoil is part of ae_ns, but ae_ns is not used further
+       ae_ns(:,jst) = ae_ns(:,jst) + subsinksoil(:)  
+
+       !! 1.2 To remove water2extract (including bare soil) from top layer
+       flux_top(:) = water2extract(:)
+
+       !! 1.3 Infiltration
+
+       !! Definition of flux_infilt
+       DO ji = 1, kjpindex
+          ! Initialise the flux to be infiltrated  
+          flux_infilt(ji) = water2infilt(ji,jst) 
+          begin_infilt_ns(ji,jst)=water2infilt(ji,jst)
+       ENDDO
+       
+       !! K and D are computed for the profile of mc before infiltration
+       !! They depend on the fraction of soil ice, given by profil_froz_hydro_ns
+       CALL hydrol_soil_coef(kjpindex,jst,njsc)
+!WRITE(*,*) "hydroltzj conductivity 3", k
+       !! Infiltration and surface runoff are computed
+       !! Infiltration stems from comparing liquid water2infilt to initial total mc (liquid+ice)
+       !! The conductivity comes from hydrol_soil_coef and relates to the liquid phase only
+       !  This seems consistent with ok_freeze
+       CALL hydrol_soil_infilt(kjpindex, jst, njsc, flux_infilt, qinfilt_ns, ru_infilt_ns, &
+            check_infilt_ns, soil_waterinf_ns, soil_dtinf_ns, soil_infilttmp_ns,soil_km_ns,soil_smcinfilt_ns, soil_totalinfilt_ns, soil_resinfilt_ns)
+       ru_ns(:,jst) = ru_infilt_ns(:,jst) 
+
+!WRITE(numout,*) 'tmp ru_ns',jst, ru_ns(10,jst)
+       !! 1.4 Reinfiltration of surface runoff : compute temporary surface water and extract from runoff
+       ! Evrything here is liquid
+       ! RK: water2infilt is both a volume for future reinfiltration (in mm) and a correction term for surface runoff (in mm/dt_sechiba) 
+       IF ( .NOT. doponds ) THEN ! this is the general case...
+          DO ji = 1, kjpindex
+             water2infilt(ji,jst) = reinf_slope(ji) * ru_ns(ji,jst)
+          ENDDO
+       ELSE
+          DO ji = 1, kjpindex           
+             water2infilt(ji,jst) = zero
+          ENDDO
+       ENDIF
+       !
+       DO ji = 1, kjpindex           
+          ru_ns(ji,jst) = ru_ns(ji,jst) - water2infilt(ji,jst)
+       END DO
+!WRITE(numout,*) 'tmp ru_ns2',jst, ru_ns(10,jst)
+       !! 2. SECONDLY, WE UPDATE MC FROM DIFFUSION, INCLUDING DRAINAGE AND ROOTSINK
+       !!    This will act on mcl only
+       
+       !! 2.1 K and D are recomputed after infiltration
+       !! They depend on the fraction of soil ice, still given by profil_froz_hydro_ns 
+       CALL hydrol_soil_coef(kjpindex,jst,njsc)
+!WRITE(*,*) "hydroltzj conductivity 2", k 
+       !! 2.2 Set the tridiagonal matrix coefficients for the diffusion/redistribution scheme
+       !! This process will further act on mcl only, based on a, b, d from hydrol_soil_coef
+       CALL hydrol_soil_setup(kjpindex,jst)
+
+       !! 2.3 We define mcl (liquid water content) based on mc and profil_froz_hydro_ns 
+       DO jsl = 1, nslm
+          DO ji =1, kjpindex
+             mcl(ji,jsl,jst)= MIN( mc(ji,jsl,jst), mcr(njsc(ji)) + &
+                  (un-profil_froz_hydro_ns(ji,jsl,jst))*(mc(ji,jsl,jst)-mcr(njsc(ji))) )
+             ! we always have mcl<=mc
+             ! if mc>mcr, then mcl>mcr; if mc=mcr,mcl=mcr; if mc<mcr, then mcl<mcr
+             ! if profil_froz_hydro_ns=0 (including NOT ok_freeze_cwrr) we keep mcl=mc
+          ENDDO
+       ENDDO
+!WRITE(numout,*) 'tmp mcl',jst, mcl(10,:,jst)
+       ! The value of mcl is kept in mclint (nstm dimension removed), used in the flux computation after diffusion
+       DO jsl = 1, nslm
+          DO ji = 1, kjpindex
+             mclint(ji,jsl) = mask_soiltile(ji,jst) * mcl(ji,jsl,jst)
+          ENDDO
+       ENDDO
+
+       !! 2.4 We calculate the total SM at the beginning of the routine tridiag for water conservation check
+       !  (on mcl only, since the diffusion only modifies mcl)
+       tmci(:) = dz(2) * ( trois*mcl(:,1,jst) + mcl(:,2,jst) )/huit
+       DO jsl = 2,nslm-1
+          tmci(:) = tmci(:) + dz(jsl) * (trois*mcl(:,jsl,jst)+mcl(:,jsl-1,jst))/huit &
+               + dz(jsl+1) * (trois*mcl(:,jsl,jst)+mcl(:,jsl+1,jst))/huit
+       ENDDO
+       tmci(:) = tmci(:) + dz(nslm) * (trois*mcl(:,nslm,jst) + mcl(:,nslm-1,jst))/huit
+
+       !! 2.5 Defining where diffusion is solved : everywhere
+       !! Since mc>mcs is not possible after infiltration, and we accept that mc<mcr
+       !! (corrected later by shutting off all evaporative fluxes in this case)
+       !  Nothing is done if resolv=F
+       resolv(:) = (mask_soiltile(:,jst) .GT. 0)
+
+       !! 2.6 We define the system of linear equations for mcl redistribution,
+       !! based on the matrix coefficients from hydrol_soil_setup
+       !! following the PhD thesis of de Rosnay (1999), p155-157
+       !! The bare soil evaporation (subtracted from infiltration) is used directly as flux_top
+       ! rhs for right-hand side term; fp for f'; gp for g'; ep for e'; with flux=0 !
+       
+       !- First layer
+       DO ji = 1, kjpindex
+          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) * mcl(ji,1,jst) + gp(ji,1)*mcl(ji,2,jst) &
+               &  - flux_top(ji) - (b(ji,1)+b(ji,2))/deux *(dt_sechiba/one_day) - rootsink(ji,1,jst)
+       ENDDO
+       !- soil body
+       DO jsl=2, nslm-1
+          DO ji = 1, kjpindex
+             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)*mcl(ji,jsl-1,jst) + fp(ji,jsl)*mcl(ji,jsl,jst) &
+                  & +  gp(ji,jsl) * mcl(ji,jsl+1,jst) & 
+                  & + (b(ji,jsl-1) - b(ji,jsl+1)) * (dt_sechiba/one_day) / deux & 
+                  & - rootsink(ji,jsl,jst) 
+          ENDDO
+       ENDDO       
+       !- Last layer, including drainage
+       DO ji = 1, kjpindex
+          jsl=nslm
+          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)*mcl(ji,jsl-1,jst) + fp(ji,jsl)*mcl(ji,jsl,jst) &
+               & + (b(ji,jsl-1) + b(ji,jsl)*(un-deux*free_drain_coef(ji,jst))) * (dt_sechiba/one_day) / deux &
+               & - rootsink(ji,jsl,jst)
+          !write(*,*) 'free_drain_coef_rhs ',jst,' ',free_drain_coef(ji,jst)
+       ENDDO
+       !- Store the equations in case needed again
+       DO jsl=1,nslm
+          DO ji = 1, kjpindex
+             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
+!WRITE(numout,*) 'rootsink tmp L1', jst, rootsink(10,1,jst)
+       !! 2.7 Solves diffusion equations, but only in grid-cells where resolv is true, i.e. everywhere (cf 2.2)
+       !!     The result is an updated mcl profile
+
+       CALL hydrol_soil_tridiag(kjpindex,jst)
+
+       !! 2.8 Computes drainage = bottom boundary condition, consistent with rhs(ji,jsl=nslm)
+       ! dr_ns in mm/dt_sechiba, from k in mm/d
+       ! This should be done where resolv=T, like tridiag (drainage is part of the linear system !)
+       DO ji = 1, kjpindex
+          IF (resolv(ji)) THEN
+             dr_ns(ji,jst) = mask_soiltile(ji,jst)*k(ji,nslm)*free_drain_coef(ji,jst) * (dt_sechiba/one_day)
+          ELSE
+             dr_ns(ji,jst) = zero
+          ENDIF
+          !write(*,*) 'free_drain_coef_drns ',jst,' ',free_drain_coef(ji,jst)
+       ENDDO
+ !     WRITE(numout,*) 'dr_ns tmp', jst, dr_ns(10,jst) 
+ !     WRITE(numout,*) 'freedrain', jst, free_drain_coef(10,jst)
+ !     WRITE(numout,*) 'freedrainK', nslm, k(10,nslm)
+       !! 2.9 For water conservation check during redistribution AND CORRECTION, 
+       !!     we calculate the total liquid SM at the end of the routine tridiag
+       tmcf(:) = dz(2) * ( trois*mcl(:,1,jst) + mcl(:,2,jst) )/huit
+       DO jsl = 2,nslm-1
+          tmcf(:) = tmcf(:) + dz(jsl) * (trois*mcl(:,jsl,jst)+mcl(:,jsl-1,jst))/huit &
+               + dz(jsl+1) * (trois*mcl(:,jsl,jst)+mcl(:,jsl+1,jst))/huit
+       ENDDO
+       tmcf(:) = tmcf(:) + dz(nslm) * (trois*mcl(:,nslm,jst) + mcl(:,nslm-1,jst))/huit
+          
+       !! And we compare the difference with the flux...
+       ! Normally, tcmf=tmci-flux_top(ji)-transpir-dr_ns
+       DO ji=1,kjpindex
+          diag_tr(ji)=SUM(rootsink(ji,:,jst))
+       ENDDO
+ !   WRITE(numout,*) 'rootsinkall', jst, rootsink(10,:,jst) 
+
+      ! Here, check_tr_ns holds the inaccuracy during the redistribution phase
+       check_tr_ns(:,jst) = tmcf(:)-(tmci(:)-flux_top(:)-dr_ns(:,jst)-diag_tr(:))
+
+       !! We solve here the numerical errors that happen when the soil is close to saturation
+       !! and drainage very high, and which lead to negative check_tr_ns: the soil dries more 
+       !! than what is demanded by the fluxes, so we need to increase the fluxes.
+       !! This is done by increasing the drainage, but this increase is limited to 50%
+       !! There are also instances of positive check_tr_ns, larger when the drainage is high
+       !! They are similarly corrected by a decrease of dr_ns, in the same limit of 50%
+       !  This 50% limit is completely arbitrary, and aims at keeping track of very anomalous behaviours
+       !  Note that using min_sechiba=E-8 in the test would be too permissive
+       !  (< 4.8 E-6 mm/d while we can get TWBR<E-12mm/d when everything's ok) 
+       DO ji=1,kjpindex
+          IF ( ABS(check_tr_ns(ji,jst)) .LT. 0.5 * dr_ns(ji,jst) ) THEN
+             dr_corrnum_ns(ji,jst) = -check_tr_ns(ji,jst)
+             dr_ns(ji,jst) = dr_ns(ji,jst) + dr_corrnum_ns(ji,jst) ! dr_ns increases/decrease if check_tr negative/positive
+          ELSE
+             dr_corrnum_ns(ji,jst) = zero
+          ENDIF
+       ENDDO
+       
+       !! For water conservation check during redistribution
+       IF (check_cwrr2) THEN          
+          check_tr_ns(:,jst) = tmcf(:)-(tmci(:)-flux_top(:)-dr_ns(:,jst)-diag_tr(:)) 
+       ENDIF
+
+       !! 3. AFTER DIFFUSION/REDISTRIBUTION
+
+       !! 3.1 Updating mc, as all the following checks against saturation will compare mc to mcs
+       !      The frozen fraction is constant, so that any water flux to/from a layer changes
+       !      both mcl and the ice amount. The assumption behind this is that water entering/leaving
+       !      a soil layer immediately freezes/melts with the proportion profil_froz_hydro_ns/(1-profil_...)
+       DO jsl = 1, nslm
+          DO ji =1, kjpindex
+             mc(ji,jsl,jst) = MAX( mcl(ji,jsl,jst), mcl(ji,jsl,jst) + &
+                  profil_froz_hydro_ns(ji,jsl,jst)*(mc(ji,jsl,jst)-mcr(njsc(ji))) )
+             ! if profil_froz_hydro_ns=0 (including NOT ok_freeze_cwrr) we get mc=mcl
+          ENDDO
+       ENDDO
+
+       !! 3.2 Correct here the possible over-saturation values (subroutine hydrol_soil_smooth_over_mcs2 acts on mc)
+       !    Oversaturation results from numerical inaccuracies and can be frequent if free_drain_coef=0
+       !    Here hydrol_soil_smooth_over_mcs2 discard all excess as ru_corr_ns, oriented to either ru_ns or dr_ns
+       !    The former routine hydrol_soil_smooth_over_mcs, which keeps most of the excess in the soiltile
+       !    after smoothing, first downward then upward, is kept in the module but not used here 
+       dr_corr_ns(:,jst) = zero
+       ru_corr_ns(:,jst) = zero
+
+       call hydrol_soil_smooth_over_mcs2(kjpindex, jst, njsc, is_over_mcs, ru_corr_ns, check_over_ns)
+       
+       ! In absence of freezing, if F is large enough, the correction of oversaturation is sent to drainage       
+       DO ji = 1, kjpindex
+          IF ((free_drain_coef(ji,jst) .GE. 0.5) .AND. (.NOT. ok_freeze_cwrr) ) THEN
+             dr_corr_ns(ji,jst) = ru_corr_ns(ji,jst) 
+             ru_corr_ns(ji,jst) = zero
+          ENDIF
+       ENDDO
+       dr_ns(:,jst) = dr_ns(:,jst) + dr_corr_ns(:,jst)
+       ru_ns(:,jst) = ru_ns(:,jst) + ru_corr_ns(:,jst)
+
+       !! 3.3 Negative runoff is reported to drainage
+       !  Since we computed ru_ns directly from hydrol_soil_infilt, ru_ns should not be negative
+             
+       ru_corr2_ns(:,jst) = zero
+       DO ji = 1, kjpindex
+          IF (ru_ns(ji,jst) .LT. zero) THEN
+! tzjwb
+!             IF (printlev>=3)  WRITE (numout,*) 'NEGATIVE RU_NS: runoff and drainage before correction',&
+!        ru_ns(ji,jst),dr_ns(ji,jst)
+             dr_ns(ji,jst)=dr_ns(ji,jst)+ru_ns(ji,jst)
+             ru_corr2_ns(ji,jst) = -ru_ns(ji,jst)
+             ru_ns(ji,jst)= 0.
+          END IF          
+       ENDDO
+
+       !! 3.4 Optional block to force saturation below zwt_force
+       ! We test if zwt_force(1,jst) <= zmaxh, to avoid steps 1 and 2 if unnecessary
+       
+       IF (zwt_force(1,jst) <= zmaxh) THEN
+
+          !! We force the nodes below zwt_force to be saturated
+          !  As above, we compare mc to mcs 
+          DO jsl = 1,nslm
+             DO ji = 1, kjpindex
+                dmc(ji,jsl) = zero
+                IF ( ( zz(jsl) >= zwt_force(ji,jst)*mille ) ) THEN
+                   dmc(ji,jsl) = mcs(njsc(ji)) - mc(ji,jsl,jst) ! addition to reach mcs (m3/m3) = positive value
+                   mc(ji,jsl,jst) = mcs(njsc(ji))
+                ENDIF
+             ENDDO
+          ENDDO
+          
+          !! To ensure conservation, this needs to be balanced by a negative change in drainage (in kg/m2/dt)
+          DO ji = 1, kjpindex
+             dr_force_ns(ji,jst) = dz(2) * ( trois*dmc(ji,1) + dmc(ji,2) )/huit ! top layer = initialization
+          ENDDO
+          DO jsl = 2,nslm-1 ! intermediate layers
+             DO ji = 1, kjpindex
+                dr_force_ns(ji,jst) = dr_force_ns(ji,jst) + dz(jsl) &
+                     & * (trois*dmc(ji,jsl)+dmc(ji,jsl-1))/huit &
+                     & + dz(jsl+1) * (trois*dmc(ji,jsl)+dmc(ji,jsl+1))/huit
+             ENDDO
+          ENDDO
+          DO ji = 1, kjpindex
+             dr_force_ns(ji,jst) = dr_force_ns(ji,jst) + dz(nslm) & ! bottom layer
+                  & * (trois * dmc(ji,nslm) + dmc(ji,nslm-1))/huit
+             dr_ns(ji,jst) = dr_ns(ji,jst) - dr_force_ns(ji,jst) ! dr_force_ns is positive and dr_ns must be reduced
+          END DO
+
+       ELSE          
+
+          dr_force_ns(:,jst) = zero 
+
+       ENDIF
+
+       !! 3.5 Diagnosing the effective water table depth:
+       !!     Defined as as the smallest jsl value when mc(jsl) is no more at saturation (mcs), starting from the bottom
+       !      If there is a part of the soil which is saturated but underlain with unsaturated nodes,
+       !      this is not considered as a water table
+       DO ji = 1, kjpindex
+          wtd_ns(ji,jst) = undef_sechiba ! in meters
+          jsl=nslm
+          DO WHILE ( (mc(ji,jsl,jst) .EQ. mcs(njsc(ji))) .AND. (jsl > 1) )
+             wtd_ns(ji,jst) = zz(jsl)/mille ! in meters
+             jsl=jsl-1
+          ENDDO
+       ENDDO
+
+       !! 3.6 Diagnose under_mcr to adapt water stress calculation below
+       !      This routine does not change tmc but decides where we should turn off ET to prevent further mc decrease
+       !      Like above, the tests are made on total mc, compared to mcr
+ 
+!WRITE(numout,*) 'Bsmotth', jst, mc(10,:,jst)
+       CALL hydrol_soil_smooth_under_mcr(kjpindex, jst, njsc, is_under_mcr, check_under_ns)
+!WRITE(numout,*) 'After',jst, mc(10,:,jst)
+ 
+       !! 4. At the end of the prognostic calculations, we recompute important moisture variables
+
+       !! 4.1 Total soil moisture content (water2infilt added below)
+       DO ji = 1, kjpindex
+          tmc(ji,jst) = dz(2) * ( trois*mc(ji,1,jst) + mc(ji,2,jst) )/huit
+       ENDDO
+       DO jsl = 2,nslm-1
+          DO ji = 1, kjpindex
+             tmc(ji,jst) = tmc(ji,jst) + dz(jsl) &
+                  & * (trois*mc(ji,jsl,jst)+mc(ji,jsl-1,jst))/huit &
+                  & + dz(jsl+1) * (trois*mc(ji,jsl,jst)+mc(ji,jsl+1,jst))/huit
+          ENDDO
+       ENDDO
+       DO ji = 1, kjpindex
+          tmc(ji,jst) = tmc(ji,jst) + dz(nslm) &
+               & * (trois * mc(ji,nslm,jst) + mc(ji,nslm-1,jst))/huit
+       END DO
+
+       !! 4.2 mcl is a module variable; we update it here for calculating bare soil evaporation,
+       !!     and in case we would like to export it (xios)
+       DO jsl = 1, nslm
+          DO ji =1, kjpindex
+             mcl(ji,jsl,jst)= MIN( mc(ji,jsl,jst), mcr(njsc(ji)) + &
+                  (un-profil_froz_hydro_ns(ji,jsl,jst))*(mc(ji,jsl,jst)-mcr(njsc(ji))) )
+             ! if profil_froz_hydro_ns=0 (including NOT ok_freeze_cwrr) we keep mcl=mc
+          ENDDO
+       ENDDO
+       
+       !! 5. Optional check of the water balance of soil column (if check_cwrr)
+
+       IF (check_cwrr) THEN
+
+          !! 5.1 Computation of the vertical water fluxes
+          CALL hydrol_soil_flux(kjpindex,jst,mclint,flux_top)
+          
+          !! 5.2 Total mc conservation 
+          DO ji = 1,kjpindex   
+             deltahum(ji) = (tmc(ji,jst) - tmcold(ji))
+             diff(ji) = flux_infilt(ji) - flux_top(ji) - SUM(rootsink(ji,:,jst)) &
+                   -ru_ns(ji,jst) - dr_ns(ji,jst)
+             test(ji) = (ABS(deltahum(ji)-diff(ji))*mask_soiltile(ji,jst) .GT. allowed_err)
+ 
+             IF (test(ji)) THEN              
+                WRITE (numout,*)'CWRR water conservation pb:',ji,jst,njsc(ji),deltahum(ji)-diff(ji)
+                WRITE (numout,*)'tmc,tmcold,diff',tmc(ji,jst),tmcold(ji),deltahum(ji)
+                WRITE(numout,*) 'evapot,evapot_penm,ae_ns,flux_top',evapot(ji),evapot_penm(ji),&
+                     ae_ns(ji,jst),flux_top(ji)
+                WRITE (numout,*)'ru_ns,dr_ns,SUM(rootsink)',ru_ns(ji,jst),dr_ns(ji,jst), &
+                     SUM(rootsink(ji,:,jst))
+                WRITE (numout,*)'precisol, flux_infilt',precisol_ns(ji,jst)
+                WRITE (numout,*)'irrigation, returnflow, reinfiltration', &
+                      irrigation_soil(ji),returnflow_soil(ji),reinfiltration_soil(ji)
+                WRITE (numout,*)'mc',mc(ji,:,jst) ! along jsl
+                WRITE (numout,*)'qflux',qflux(ji,:,jst) ! along jsl
+                WRITE (numout,*)'k', k(ji,:) ! along jsl
+                WRITE (numout,*)'soiltile',soiltile(ji,jst)
+                WRITE (numout,*)'veget_max', veget_max(ji,:)
+                
+                error=.TRUE.
+                CALL ipslerr_p(2, 'hydrol_soil', 'We will STOP in the end of this subroutine.',&
+                     & 'CWRR water balance check','')
+             ENDIF
+          ENDDO
+
+          !! 5.3 Total mc should not reach zero, or the tridiag solver will have problems
+          DO ji = 1,kjpindex
+             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,evapot_penm,ae_ns,flux_top',evapot(ji),evapot_penm(ji),&
+                     ae_ns(ji,jst),flux_top(ji)
+                WRITE (numout,*)'ru_ns,dr_ns,SUM(rootsink)',ru_ns(ji,jst),dr_ns(ji,jst), &
+                     SUM(rootsink(ji,:,jst))
+                WRITE (numout,*)'precisol, flux_infilt',precisol_ns(ji,jst)
+                WRITE (numout,*)'irrigation, returnflow, reinfiltration', &
+                      irrigation_soil(ji),returnflow_soil(ji),reinfiltration_soil(ji)
+                WRITE (numout,*)'mc',mc(ji,:,jst) ! along jsl
+                WRITE (numout,*)'qflux',qflux(ji,:,jst) ! along jsl
+                WRITE (numout,*)'k', k(ji,:) ! along jsl
+                WRITE (numout,*)'soiltile',soiltile(ji,jst)
+                WRITE (numout,*)'veget_max', veget_max(ji,:)              
+
+                error=.TRUE.
+                CALL ipslerr_p(2, 'hydrol_soil', 'We will STOP in the end of this subroutine.',&
+                     & 'CWRR MC NEGATIVE','')
+             ENDIF
+          END DO
+
+       ENDIF
+
+       !! 6. SM DIAGNOSTICS FOR OTHER ROUTINES, MODULES, OR NEXT STEP
+       !    Starting here, mc and mcl should not change anymore 
+       
+       !! 6.1 Total soil moisture, soil moisture at litter levels, soil wetness, us, humrelv, vesgtressv
+       !!     (based on mc)
+
+       !! In output, tmc includes water2infilt(ji,jst)
+       DO ji=1,kjpindex
+          tmc(ji,jst) = tmc(ji,jst) + water2infilt(ji,jst)
+       END DO
+       
+       ! The litter is the 4 top levels of the soil
+       ! 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) * ( 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) * & 
+                  & ( trois*mc(ji,jsl,jst) + mc(ji,jsl-1,jst))/huit &
+                  & + dz(jsl+1)*(trois*mc(ji,jsl,jst) + mc(ji,jsl+1,jst))/huit
+          END DO
+       END DO
+
+       ! Subsequent calculation 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
+
+       ! Preliminary calculation of various soil moistures (for each layer, in kg/m2)
+       sm(:,1)  = dz(2) * (trois*mc(:,1,jst) + mc(:,2,jst))/huit
+       smw(:,1) = dz(2) * (quatre*mcw(njsc(:)))/huit
+       smf(:,1) = dz(2) * (quatre*mcf(njsc(:)))/huit
+       sms(:,1) = dz(2) * (quatre*mcs(njsc(:)))/huit
+       DO jsl = 2,nslm-1
+          sm(:,jsl)  = dz(jsl) * (trois*mc(:,jsl,jst)+mc(:,jsl-1,jst))/huit &
+               + dz(jsl+1) * (trois*mc(:,jsl,jst)+mc(:,jsl+1,jst))/huit
+          smw(:,jsl) = dz(jsl) * ( quatre*mcw(njsc(:)) )/huit &
+               + dz(jsl+1) * ( quatre*mcw(njsc(:)) )/huit
+          smf(:,jsl) = dz(jsl) * ( quatre*mcf(njsc(:)) )/huit &
+               + dz(jsl+1) * ( quatre*mcf(njsc(:)) )/huit
+          sms(:,jsl) = dz(jsl) * ( quatre*mcs(njsc(:)) )/huit &
+               + dz(jsl+1) * ( quatre*mcs(njsc(:)) )/huit
+       ENDDO
+       sm(:,nslm)  = dz(nslm) * (trois*mc(:,nslm,jst) + mc(:,nslm-1,jst))/huit      
+       smw(:,nslm) = dz(nslm) * (quatre*mcw(njsc(:)))/huit
+       smf(:,nslm) = dz(nslm) * (quatre*mcf(njsc(:)))/huit
+       sms(:,nslm) = dz(nslm) * (quatre*mcs(njsc(:)))/huit
+       ! sm_nostress = soil moisture of each layer at which us reaches 1, here at the middle of [smw,smf]
+       DO jsl = 1,nslm
+          sm_nostress(:,jsl) = smw(:,jsl) + pcent(njsc(:)) * (smf(:,jsl)-smw(:,jsl))
+       END DO
+             
+       ! Soil wetness profiles (W-Ww)/(Ws-Ww)
+       ! soil_wet is the ratio of available soil moisture to max available soil moisture
+       ! (ie soil moisture at saturation minus soil moisture at wilting point).
+       ! soil wet is a water stress for stomate, to control C decomposition
+       DO jsl=1,nslm
+          DO ji=1,kjpindex
+             soil_wet(ji,jsl,jst) = MIN(un, MAX(zero, &
+                  (sm(ji,jsl)-smw(ji,jsl))/(sms(ji,jsl)-smw(ji,jsl)) ))
+          END DO
+       END DO
+
+       ! Compute us and the new humrelv to use in sechiba (with loops on the vegetation types)
+       ! This is the water stress for transpiration (diffuco) and photosynthesis (diffuco)
+       ! humrel is never used in stomate
+
+       ! -- PFT1
+       humrelv(:,1,jst) = zero        
+       ! -- Top layer
+       DO jv = 2,nvm
+          DO ji=1,kjpindex
+             !- Here we make the assumption that roots do not take water from the 1st layer. 
+             us(ji,jv,jst,1) = zero
+             humrelv(ji,jv,jst) = zero ! initialisation of the sum
+          END DO
+       ENDDO
+
+!!! special for larix: dynamic nroot to optimize water use tzjdz (for all trees
+!now)
+!           IF (dyn_nroot_larix) THEN
+!WRITE(*,*) "tzjdz 1", nroot
+      IF (dyn_nroot_tree) THEN
+!WRITE(*,*) "tzjdz ON"
+           DO jv = 1, nvm
+!             IF ( is_tree(jv) .AND. is_deciduous(jv) .AND. is_needleleaf(jv)
+             IF ( is_tree(jv) ) THEN
+
+               DO ji=1,kjpindex    
+                 nroot_tmp(:)=zero    
+
+                 DO jsl = 2,nslm
+!  nroot_tmp(jsl)=(sm(ji,jsl)-smw_tmp(ji,jsl))/(pcent(njsc(ji))*(smf_tmp(ji,jsl)-smw_tmp(ji,jsl)))*(smf(ji,jsl)-smw(ji,jsl))/(smf_tmp(ji,jsl)-smw_tmp(ji,jsl))
+  nroot_tmp(jsl)=(sm(ji,jsl)-smw(ji,jsl))/(pcent(njsc(ji))*(smf(ji,jsl)-smw(ji,jsl)))*(smf(ji,jsl)-smw(ji,jsl))/(smf(ji,jsl)-smw(ji,jsl))
+                        IF (nroot(jv,jst,jsl) .EQ. zero) nroot_tmp(jsl)=zero
+                 ENDDO
+    
+                 IF (SUM(nroot_tmp(:)) .GT. zero )        nroot(jv,jst,:)=nroot_tmp(:)/SUM(nroot_tmp(:))
+              ENDDO
+             ENDIF
+           ENDDO
+         ENDIF
+!WRITE(*,*) "tzjdz 2", nroot
+
+!WRITE(*,*) "tzjdz DONE", nroot
+       ! -- Intermediate and bottom layers
+       DO jsl = 2,nslm
+          DO jv = 2, nvm
+             DO ji=1,kjpindex
+                ! AD16*** Although plants can only withdraw liquid water, we compute here the water stress
+                ! based on mc and the corresponding thresholds mcs, pcent, or potentially mcw and mcf
+                ! This is consistent with assuming that ice is uniformly distributed within the poral space
+                ! In such a case, freezing makes mcl and the "liquid" porosity smaller than the "total" values
+                ! And it is the same for all the moisture thresholds, which are proportional to porosity.
+                ! Since the stress is based on relative moisture, it could thus independent from the porosity
+                ! at first order, thus independent from freezing.             
+                us(ji,jv,jst,jsl) = MIN(un, MAX(zero, &
+                  (sm(ji,jsl)-smw(ji,jsl))/(sm_nostress(ji,jsl)-smw(ji,jsl)) )) * nroot(jv,jst,jsl)
+
+                humrelv(ji,jv,jst) = humrelv(ji,jv,jst) + us(ji,jv,jst,jsl)
+             END DO
+          END DO
+       ENDDO
+!WRITE(*,*) "tzjdz humrelv", jst, humrelv(10,:,jst)
+!WRITE(*,*) "us tzj LAYER5",jst, us(10,:,3,5)
+!WRITE(*,*) "nroot",nroot
+!WRITE(*,*) "humrelv",humrelv
+       !! vegstressv is the water stress for phenology in stomate
+       !! It varies linearly from zero at wilting point to 1 at field capacity
+       vegstressv(:,:,jst) = zero
+       DO jv = 2, nvm
+          DO ji=1,kjpindex
+             DO jsl=1,nslm
+                vegstressv(ji,jv,jst) = vegstressv(ji,jv,jst) + &
+                     MIN(un, MAX(zero, (sm(ji,jsl)-smw(ji,jsl))/(smf(ji,jsl)-smw(ji,jsl)) )) &
+                     * nroot(jv,jst,jsl)
+             END DO
+          END DO
+       END DO
+!WRITE(numout,*) 'vegstressv(ji,jv,jst)', jst, vegstressv(10,:,jst)
+
+       ! -- If the PFT is absent, the corresponding humrelv and vegstressv = 0
+       DO jv = 2, nvm
+          DO ji = 1, kjpindex
+             IF (vegetmax_soil(ji,jv,jst) .LT. min_sechiba) THEN
+                humrelv(ji,jv,jst) = zero
+                vegstressv(ji,jv,jst) = zero
+                us(ji,jv,jst,:) = zero
+             ENDIF
+          END DO
+       END DO
+
+       !! 6.2 We need to turn off evaporation when is_under_mcr
+       !!     We set us, humrelv and vegstressv to zero in this case
+       !!     WARNING: It's different from having locally us=0 in the soil layers(s) where mc<mcr
+       !!              This part is crucial to preserve water conservation
+       DO jsl = 1,nslm
+          DO jv = 2, nvm
+             WHERE (is_under_mcr(:,jst))
+                us(:,jv,jst,jsl) = zero
+                e_frac(:,jsl,3)=zero  !TEST
+ 
+                free_drain_coef(:,jst)=zero   !!!! PONEYBUGachecker tzj
+             ELSEWHERE
+                ! modified by yitong yao 28 NOV 2020
+                 free_drain_coef(:,jst)=coef_max_drain
+                ! modified above
+                  !DO ji=1,kjpindex
+                  !     free_drain_coef(ji,jst)=coef_max_drain
+                  !ENDDO
+             ENDWHERE
+
+          ENDDO
+       ENDDO
+       ! added by yitong yao 27 NOV 12:52am
+       !DO ji=1,kjpindex
+       !   write(*,*) 'free_drain_coef_turnoff',free_drain_coef(ji,2)
+       !ENDDO
+
+       ! added by yitong yao above 
+       DO jv = 2, nvm
+          WHERE (is_under_mcr(:,jst))
+             humrelv(:,jv,jst) = zero
+          ENDWHERE
+       ENDDO
+       
+       ! For consistency in stomate, we also set moderwilt and soil_wet to zero in this case. 
+       ! They are used later for shumdiag and shumdiag_perma
+       DO jsl = 1,nslm
+          WHERE (is_under_mcr(:,jst))
+             soil_wet(:,jsl,jst) = zero
+          ENDWHERE
+       ENDDO
+
+       ! Counting the nb of under_mcr occurences in each grid-cell 
+       WHERE (is_under_mcr(:,jst))
+          undermcr = undermcr + un
+       ENDWHERE
+
+       !! 6.3 Calculate the volumetric soil moisture content (mc_layh and mcl_layh) needed in 
+       !!     thermosoil for the thermal conductivity. Calculate also total soil moisture content(tmc_layh) 
+       !!     needed in thermosoil for the heat capacity.
+       ! AD060316 WE MAY USE SM TO SIMPLIFY THESE LINES
+       DO ji=1,kjpindex
+          DO jsl=1,nslm
+             mc_layh(ji,jsl) = mc_layh(ji,jsl) + mc(ji,jsl,jst) * soiltile(ji,jst) * vegtot(ji) 
+             mcl_layh(ji,jsl) = mcl_layh(ji,jsl) + mcl(ji,jsl,jst) * soiltile(ji,jst) * vegtot(ji)
+          ENDDO
+          tmc_layh_ns(ji,1,jst) = dz(2) * ( trois*mc(ji,1,jst) + mc(ji,2,jst) )/huit
+          DO jsl = 2,nslm-1
+             tmc_layh_ns(ji,jsl,jst) = dz(jsl) * (trois*mc(ji,jsl,jst)+mc(ji,jsl-1,jst))/huit &
+                  + dz(jsl+1) * (trois*mc(ji,jsl,jst)+mc(ji,jsl+1,jst))/huit
+          ENDDO
+          tmc_layh_ns(ji,nslm,jst) = dz(nslm) * (trois*mc(ji,nslm,jst) + mc(ji,nslm-1,jst))/huit
+          DO jsl = 1,nslm
+             tmc_layh(ji,jsl) = tmc_layh(ji,jsl) + tmc_layh_ns(ji,jsl,jst) * soiltile(ji,jst) * vegtot(ji)
+          ENDDO
+       END DO
+
+       !! 6.4 The hydraulic conductivities exported here are the ones used in the diffusion/redistribution
+       ! (no call of hydrol_soil_coef since 2.1)
+       IF (ok_freeze_cwrr) THEN
+          DO ji = 1, kjpindex
+             kk_moy(ji,:) =kk_moy(ji,:)+soiltile(ji,jst)*k(ji,:) 
+             kk(ji,:,jst)=k(ji,:)
+          ENDDO
+       ENDIF
+       
+! tzjwb
+!      IF (printlev>=3) WRITE (numout,*) ' prognostic/diagnostic part of hydrol_soil done for jst =', jst          
+
+   END DO  ! end of loop on soiltile
+
+    !! -- ENDING THE MAIN LOOP ON SOILTILES
+
+    !! 7. Summing 3d variables into 2d variables 
+    CALL hydrol_diag_soil (kjpindex, veget_max, soiltile, njsc, runoff, drainage, &
+         & evapot, vevapnu, returnflow, reinfiltration, irrigation, &
+         & shumdiag,shumdiag_perma, k_litt, litterhumdiag, humrel, vegstress, drysoil_frac,tot_melt)
+
+    ! Means of wtd, runoff and drainage corrections, across soiltiles    
+    wtd(:) = zero 
+    ru_corr(:) = zero
+    ru_corr2(:) = zero
+    dr_corr(:) = zero
+    dr_corrnum(:) = zero
+    dr_force(:) = zero
+    DO jst = 1, nstm
+       DO ji = 1, kjpindex 
+          wtd(ji) = wtd(ji) + soiltile(ji,jst) * wtd_ns(ji,jst)
+          IF (vegtot(ji) .GT. min_sechiba) THEN ! to mimic hydrol_diag_soil
+             ru_corr(ji) = ru_corr(ji) + vegtot(ji) * soiltile(ji,jst) * ru_corr_ns(ji,jst)
+             ru_corr2(ji) = ru_corr2(ji) + vegtot(ji) * soiltile(ji,jst) * ru_corr2_ns(ji,jst)
+             dr_corr(ji) = dr_corr(ji) + vegtot(ji) * soiltile(ji,jst) * dr_corr_ns(ji,jst)
+             dr_corrnum(ji) = dr_corrnum(ji) + vegtot(ji) * soiltile(ji,jst) * dr_corrnum_ns(ji,jst)
+             dr_force(ji) = dr_force(ji) - vegtot(ji) * soiltile(ji,jst) * dr_force_ns(ji,jst)
+                                       ! the sign is OK to get a negative drainage flux
+          ENDIF
+       ENDDO
+    ENDDO
+
+    ! Means local variables, including water conservation checks
+    ru_infilt(:)=0.
+    qinfilt(:)=0.
+    check_infilt(:)=0.
+    check_tr(:)=0.
+    check_over(:)=0.
+    check_under(:)=0.
+    DO jst = 1, nstm
+       DO ji = 1, kjpindex 
+          IF (vegtot(ji) .GT. min_sechiba) THEN ! to mimic hydrol_diag_soil
+             ru_infilt(ji) = ru_infilt(ji) + vegtot(ji) * soiltile(ji,jst) * ru_infilt_ns(ji,jst)
+             qinfilt(ji) = qinfilt(ji) + vegtot(ji) * soiltile(ji,jst) * qinfilt_ns(ji,jst)
+          ENDIF
+       ENDDO
+    ENDDO
+ 
+    IF (check_cwrr2) THEN
+       DO jst = 1, nstm
+          DO ji = 1, kjpindex 
+             IF (vegtot(ji) .GT. min_sechiba) THEN ! to mimic hydrol_diag_soil
+                check_infilt(ji) = check_infilt(ji) + vegtot(ji) * soiltile(ji,jst) * check_infilt_ns(ji,jst)
+                check_tr(ji) = check_tr(ji) + vegtot(ji) * soiltile(ji,jst) * check_tr_ns(ji,jst)
+                check_over(ji) = check_over(ji) + vegtot(ji) * soiltile(ji,jst) * check_over_ns(ji,jst)
+                check_under(ji) =  check_under(ji) + vegtot(ji) * soiltile(ji,jst) * check_under_ns(ji,jst)
+             ENDIF
+          ENDDO
+       ENDDO
+    END IF
+    !! 8. COMPUTING EVAP_BARE_LIM_NS FOR NEXT TIME STEP, WITH A LOOP ON SOILTILES
+    !!    The principle is to run a dummy integration of the water redistribution scheme
+    !!    to check if the SM profile can sustain a potential evaporation.
+    !!    If not, the dummy integration is redone from the SM profile of the end of the normal integration,
+    !!    with a boundary condition leading to a very severe water limitation: mc(1)=mcr
+
+    ! evap_bare_lim = beta factor for bare soil evaporation
+    evap_bare_lim(:) = zero
+    evap_bare_lim_ns(:,:) = zero
+
+    ! Loop on soil tiles  
+    DO jst = 1,nstm
+
+       !! 8.1 Save actual mc, mcl, and tmc for restoring at the end of the time step
+       !!      and calculate tmcint corresponding to mc without water2infilt
+       DO jsl = 1, nslm
+          DO ji = 1, kjpindex
+             mcint(ji,jsl) = mask_soiltile(ji,jst) * mc(ji,jsl,jst)
+             mclint(ji,jsl) = mask_soiltile(ji,jst) * mcl(ji,jsl,jst)
+          ENDDO
+       ENDDO
+
+       DO ji = 1, kjpindex
+          temp(ji) = tmc(ji,jst)
+          tmcint(ji) = temp(ji) - water2infilt(ji,jst) ! to estimate bare soil evap based on water budget
+       ENDDO
+
+       !! 8.2 Since we estimate bare soile evap for the next time step, we update profil_froz_hydro and mcl
+       !     (effect of mc only, the change in temp_hydro is neglected)
+       IF ( ok_freeze_cwrr ) CALL hydrol_soil_froz(kjpindex,jst,njsc)
+        DO jsl = 1, nslm
+          DO ji =1, kjpindex
+             mcl(ji,jsl,jst)= MIN( mc(ji,jsl,jst), mcr(njsc(ji)) + &
+                  (un-profil_froz_hydro_ns(ji,jsl,jst))*(mc(ji,jsl,jst)-mcr(njsc(ji))) )
+             ! if profil_froz_hydro_ns=0 (including NOT ok_freeze_cwrr) we keep mcl=mc
+          ENDDO
+       ENDDO          
+
+       !! 8.3 K and D are recomputed for the updated profile of mc/mcl
+       CALL hydrol_soil_coef(kjpindex,jst,njsc)
+! tzjrs
+!WRITE(*,*) "hydrol conductivity",jst, k 
+ksave(:,:,jst)=k
+!WRITE(*,*) "hydroltzj conductivity 1", ksave(:,:,2)
+!WRITE(*,*) "hydroltzj conductivity 1", k 
+       !! 8.4 Set the tridiagonal matrix coefficients for the diffusion/redistribution scheme
+       CALL hydrol_soil_setup(kjpindex,jst)
+       resolv(:) = (mask_soiltile(:,jst) .GT. 0) 
+
+       !! 8.5 We define the system of linear equations, based on matrix coefficients, 
+
+       !- Impose potential evaporation as flux_top in mm/step, assuming the water is available
+       ! Note that this should lead to never have evapnu>evapot_penm(ji)
+
+       ! AD16*** et si evap_bare_lim_ns<0 ?? car on suppose que tmcint > tmc(new)
+       ! (water2inflit permet de propager de la ponded water d'un pas de temps a l'autre:
+       ! peut-on s'en servir pour creer des cas d'evapnu potentielle negative ? a gerer dans diffuco ?)
+       
+       DO ji = 1, kjpindex
+          IF(vegtot(ji).GT.min_sechiba) THEN
+             flux_top(ji) = evapot_penm(ji) * &
+                  AINT(frac_bare_ns(ji,jst)+un-min_sechiba)
+          ELSE
+             flux_top(ji) = zero
+          ENDIF
+       ENDDO
+
+       ! We don't use rootsinks, because we assume there is no transpiration in the bare soil fraction (??)
+       !- First layer
+       DO ji = 1, kjpindex
+          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) * mcl(ji,1,jst) + gp(ji,1)*mcl(ji,2,jst) &
+               - flux_top(ji) - (b(ji,1)+b(ji,2))/deux *(dt_sechiba/one_day)
+       ENDDO
+       !- soil body
+       DO jsl=2, nslm-1
+          DO ji = 1, kjpindex
+             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)*mcl(ji,jsl-1,jst) + fp(ji,jsl)*mcl(ji,jsl,jst) &
+                  +  gp(ji,jsl) * mcl(ji,jsl+1,jst) &
+                  + (b(ji,jsl-1) - b(ji,jsl+1)) * (dt_sechiba/one_day) / deux
+          ENDDO
+       ENDDO
+       !- Last layer
+       DO ji = 1, kjpindex
+          jsl=nslm
+          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)*mcl(ji,jsl-1,jst) + fp(ji,jsl)*mcl(ji,jsl,jst) &
+               + (b(ji,jsl-1) + b(ji,jsl)*(un-deux*free_drain_coef(ji,jst))) * (dt_sechiba/one_day) / deux
+          !write(*,*) 'free_drain_coef_rhs5314 ',jst,' ',free_drain_coef(ji,jst)
+        ENDDO
+       !- Store the equations for later use (9.6)
+       DO jsl=1,nslm
+          DO ji = 1, kjpindex
+             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
+
+       !! 8.6 Solve the diffusion equation, assuming that flux_top=evapot_penm (updates mcl)
+       CALL hydrol_soil_tridiag(kjpindex,jst)
+
+       !! 9.7 Alternative solution with mc(1)=mcr in points where the above solution leads to mcl<mcr 
+       ! hydrol_soil_tridiag calculates mc recursively from the top as a fonction of rhs and tmat 
+       ! We re-use these the above values, but for mc(1)=mcr and the related tmat
+       
+       DO ji = 1, kjpindex
+          ! by construction, mc and mcl are always on the same side of mcr, so we can use mcl here
+          resolv(ji) = (mcl(ji,1,jst).LT.(mcr(njsc(ji))).AND.flux_top(ji).GT.min_sechiba)
+       ENDDO
+       !! Reset the coefficient for diffusion (tridiag is only solved if resolv(ji) = .TRUE.)O
+       DO jsl=1,nslm
+          !- The new condition is to put the upper layer at residual soil moisture
+          DO ji = 1, kjpindex
+             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
+       END DO
+       
+       DO ji = 1, kjpindex
+          tmat(ji,1,2) = un
+          tmat(ji,1,3) = zero
+          rhs(ji,1) = mcr(njsc(ji))
+       ENDDO
+       
+       ! Solves the diffusion equation with new surface bc where resolv=T 
+       CALL hydrol_soil_tridiag(kjpindex,jst)
+
+       !! 8.8 In both case, we have drainage to be consistent with rhs
+       DO ji = 1, kjpindex
+          flux_bottom(ji) = mask_soiltile(ji,jst)*k(ji,nslm)*free_drain_coef(ji,jst) * (dt_sechiba/one_day)
+       ENDDO
+       
+       !! 8.9 Water budget to assess the top flux = soil evaporation
+       !      Where resolv=F at the 2nd step (9.6), it should simply be the potential evaporation
+
+       ! Total soil moisture content for water budget
+
+       DO jsl = 1, nslm
+          DO ji =1, kjpindex
+             mc(ji,jsl,jst) = MAX( mcl(ji,jsl,jst), mcl(ji,jsl,jst) + &
+                  profil_froz_hydro_ns(ji,jsl,jst)*(mc(ji,jsl,jst)-mcr(njsc(ji))) )
+             ! if profil_froz_hydro_ns=0 (including NOT ok_freeze_cwrr) we get mc=mcl
+          ENDDO
+       ENDDO
+       
+       DO ji = 1, kjpindex
+          tmc(ji,jst) = dz(2) * ( trois*mc(ji,1,jst) + mc(ji,2,jst) )/huit
+       ENDDO       
+       DO jsl = 2,nslm-1
+          DO ji = 1, kjpindex
+             tmc(ji,jst) = tmc(ji,jst) + dz(jsl) &
+                  * (trois*mc(ji,jsl,jst)+mc(ji,jsl-1,jst))/huit &
+                  + dz(jsl+1) * (trois*mc(ji,jsl,jst)+mc(ji,jsl+1,jst))/huit
+          ENDDO
+       ENDDO
+       DO ji = 1, kjpindex
+          tmc(ji,jst) = tmc(ji,jst) + dz(nslm) &
+               * (trois * mc(ji,nslm,jst) + mc(ji,nslm-1,jst))/huit
+       END DO
+    
+       ! Deduce upper flux from soil moisture variation and bottom flux
+       ! TMCi-D-BSE=TMC (BSE=bare soil evap=TMCi-TMC-D)
+       ! The numerical errors of tridiag close to saturation cannot be simply solved here,
+       ! we can only hope they are not too large because we don't add water at this stage... 
+       DO ji = 1, kjpindex
+          evap_bare_lim_ns(ji,jst) = mask_soiltile(ji,jst) * &
+               (tmcint(ji)-tmc(ji,jst)-flux_bottom(ji))
+       END DO
+
+       !! 8.10 evap_bare_lim_ns is turned from an evaporation rate to a beta
+       DO ji = 1, kjpindex
+          ! Here we weight evap_bare_lim_ns by the fraction of bare evaporating soil. 
+          ! This is given by frac_bare_ns, taking into account bare soil under vegetation
+          IF(vegtot(ji) .GT. min_sechiba) THEN
+             evap_bare_lim_ns(ji,jst) = evap_bare_lim_ns(ji,jst) * frac_bare_ns(ji,jst)
+          ELSE
+             evap_bare_lim_ns(ji,jst) = 0.
+          ENDIF
+       END DO
+
+       ! We divide by evapot, which is consistent with diffuco (evap_bare_lim_ns < evapot_penm/evapot)
+       ! Further decrease if tmc_litter is below the wilting point
+       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) = evap_bare_lim_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) * evap_bare_lim_ns(ji,jst) / evapot(ji)
+             ! This is very arbitrary, with no justification from the literature
+          ELSE
+             evap_bare_lim_ns(ji,jst) = zero
+          END IF
+          evap_bare_lim_ns(ji,jst)=MAX(MIN(evap_bare_lim_ns(ji,jst),1.),0.)
+       END DO
+
+       !! 8.11 Set evap_bare_lim_ns to zero if is_under_mcr at the end of the prognostic loop
+       !!      (cf us, humrelv, vegstressv in 5.2)
+       WHERE (is_under_mcr(:,jst))
+          evap_bare_lim_ns(:,jst) = zero
+       ENDWHERE
+
+       !! 8.12 Restores mc, mcl, and tmc, to erase the effect of the dummy integrations
+       !!      on these prognostic variables 
+       DO jsl = 1, nslm
+          DO ji = 1, kjpindex
+             mc(ji,jsl,jst) = mask_soiltile(ji,jst) * mcint(ji,jsl)
+             mcl(ji,jsl,jst) = mask_soiltile(ji,jst) * mclint(ji,jsl)
+          ENDDO
+       ENDDO
+       DO ji = 1, kjpindex
+          tmc(ji,jst) = temp(ji)
+       ENDDO
+
+    ENDDO !end loop on tiles for dummy integration
+
+    !! 9. evap_bar_lim is the grid-cell scale beta
+    DO ji = 1, kjpindex
+       evap_bare_lim(ji) =  SUM(evap_bare_lim_ns(ji,:)*vegtot(ji)*soiltile(ji,:))
+    ENDDO
+
+
+! tzjswc
+   !! 16 Copy mc to swc for use in sechiba_hydrol_arch
+    swc(:,:,:) = mc(:,:,:)
+!WRITE(*,*) "tzj swc in hydrol", swc
+
+    !! 10. XIOS export of local variables, including water conservation checks
+
+    CALL xios_orchidee_send_field("wtd",wtd) ! in m
+    CALL xios_orchidee_send_field("ru_corr",ru_corr/dt_sechiba)   ! adjustment flux added to surface runoff (included in runoff)
+    CALL xios_orchidee_send_field("ru_corr2",ru_corr2/dt_sechiba)
+    CALL xios_orchidee_send_field("dr_corr",dr_corr/dt_sechiba)   ! adjustment flux added to drainage (included in drainage)
+    CALL xios_orchidee_send_field("dr_corrnum",dr_corrnum/dt_sechiba) 
+    CALL xios_orchidee_send_field("dr_force",dr_force/dt_sechiba) ! adjustement flux added to drainage to sustain a forced wtd
+    CALL xios_orchidee_send_field("qinfilt",qinfilt/dt_sechiba)
+    CALL xios_orchidee_send_field("ru_infilt",ru_infilt/dt_sechiba)
+
+    IF (check_cwrr2) THEN
+       CALL xios_orchidee_send_field("check_infilt",check_infilt/dt_sechiba)
+       CALL xios_orchidee_send_field("check_tr",check_tr/dt_sechiba)
+       CALL xios_orchidee_send_field("check_over",check_over/dt_sechiba)
+       CALL xios_orchidee_send_field("check_under",check_under/dt_sechiba)    
+    END IF
+
+    !! 11. Exit if error was found previously in this subroutine
+    
+    IF ( error ) THEN
+       WRITE(numout,*) 'One or more errors have been detected in hydrol_soil. Model stops.'
+       CALL ipslerr_p(3, 'hydrol_soil', 'We will STOP now.',&
+                  & 'One or several fatal errors were found previously.','')
+    END IF
+
+  END SUBROUTINE hydrol_soil
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_soil_infilt
+!!
+!>\BRIEF        Infiltration
+!!
+!! DESCRIPTION  :
+!! 1. We calculate the total SM at the beginning of the routine
+!! 2. Infiltration process
+!! 2.1 Initialization of time counter and infiltration rate
+!! 2.2 Infiltration layer by layer, accounting for an exponential law for subgrid variability
+!! 2.3 Resulting infiltration and surface runoff
+!! 3. For water conservation check, we calculate the total SM at the beginning of the routine,
+!!    and export the difference with the flux
+!! 5. Local verification 
+!!
+!! RECENT CHANGE(S) : 2016 by A. Ducharne
+!! Adding checks and interactions variables with hydrol_soil, but the processes are unchanged
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_soil_infilt
+
+  SUBROUTINE hydrol_soil_infilt(kjpindex, ins, njsc, flux_infilt, qinfilt_ns, ru_infilt, check, soil_waterinf, soil_dtinf, soil_infilttmp, soil_km, soil_smcinfilt, soil_totalinfilt, soil_resinfilt)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    ! GLOBAL (in or inout)
+    INTEGER(i_std), INTENT(in)                        :: kjpindex        !! Domain size
+    INTEGER(i_std), INTENT(in)                        :: ins
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)  :: njsc            !! Index of the dominant soil textural class in the grid cell
+                                                                         !!  (1-nscm, unitless)
+    REAL(r_std), DIMENSION (kjpindex), INTENT (in)    :: flux_infilt     !! Water to infiltrate
+                                                                         !!  @tex $(kg m^{-2})$ @endtex
+
+    !! 0.2 Output variables
+    REAL(r_std), DIMENSION(kjpindex,nstm), INTENT(out) :: check       !! delta SM - flux (mm/dt_sechiba)
+    REAL(r_std), DIMENSION(kjpindex,nstm), INTENT(out) :: ru_infilt   !! Surface runoff from soil_infilt (mm/dt_sechiba)
+    REAL(r_std), DIMENSION(kjpindex,nstm), INTENT(out) :: qinfilt_ns  !! Effective infiltration flux (mm/dt_sechiba)
+
+    ! three variables added by yitong yao 4 Jan 2021 
+    REAL(r_std), DIMENSION(kjpindex,nslm,nstm), INTENT(inout) :: soil_waterinf
+    REAL(r_std), DIMENSION(kjpindex,nslm,nstm), INTENT(inout) :: soil_dtinf
+    REAL(r_std), DIMENSION(kjpindex,nslm,nstm), INTENT(inout) :: soil_infilttmp
+    REAL(r_std), DIMENSION(kjpindex,nslm,nstm), INTENT(inout) :: soil_km    
+    REAL(r_std), DIMENSION(kjpindex,nslm,nstm), INTENT(inout) :: soil_smcinfilt
+    REAL(r_std), DIMENSION(kjpindex,nslm,nstm), INTENT(inout) :: soil_resinfilt
+    REAL(r_std), DIMENSION(kjpindex,nstm), INTENT(inout)   :: soil_totalinfilt
+! above added 
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                :: ji, jsl      !! Indices
+    REAL(r_std), DIMENSION (kjpindex)             :: wat_inf_pot  !! infiltrable water in the layer
+    REAL(r_std), DIMENSION (kjpindex)             :: wat_inf      !! infiltrated water in the layer
+    REAL(r_std), DIMENSION (kjpindex)             :: dt_tmp       !! time remaining before the end of the time step
+    REAL(r_std), DIMENSION (kjpindex)             :: dt_inf       !! the time it takes to complete the infiltration in the 
+                                                                  !! layer 
+    REAL(r_std)                                   :: k_m          !! the mean conductivity used for the saturated front
+    REAL(r_std), DIMENSION (kjpindex)             :: infilt_tmp   !! infiltration rate for the considered layer 
+    REAL(r_std), DIMENSION (kjpindex)             :: infilt_tot   !! total infiltration 
+    REAL(r_std), DIMENSION (kjpindex)             :: flux_tmp     !! rate at which precip hits the ground
+
+    REAL(r_std), DIMENSION(kjpindex)              :: tmci         !! total SM at beginning of routine (kg/m2)
+    REAL(r_std), DIMENSION(kjpindex)              :: tmcf         !! total SM at end of routine (kg/m2)
+    
+
+!_ ================================================================================================================================
+
+    ! If data (or coupling with GCM) was available, a parameterization for subgrid rainfall could be performed
+
+    !! 1. We calculate the total SM at the beginning of the routine
+    IF (check_cwrr2) THEN
+       tmci(:) = dz(2) * ( trois*mc(:,1,ins) + mc(:,2,ins) )/huit
+       DO jsl = 2,nslm-1
+          tmci(:) = tmci(:) + dz(jsl) * (trois*mc(:,jsl,ins)+mc(:,jsl-1,ins))/huit &
+               + dz(jsl+1) * (trois*mc(:,jsl,ins)+mc(:,jsl+1,ins))/huit
+       ENDDO
+       tmci(:) = tmci(:) + dz(nslm) * (trois*mc(:,nslm,ins) + mc(:,nslm-1,ins))/huit
+    ENDIF
+
+    !! 2. Infiltration process
+
+    !! 2.1 Initialization
+    !soil_waterinf(:,:,ins)=zero
+    !soil_dtinf(:,:,ins)=zero
+    !soil_infilttmp(:,:,ins)=zero
+    !soil_smcinfilt(:,:,ins)=zero
+
+    DO ji = 1, kjpindex
+       !! First we fill up the first layer (about 1mm) without any resistance and quasi-immediately
+       wat_inf_pot(ji) = MAX((mcs(njsc(ji))-mc(ji,1,ins)) * dz(2) / deux, zero)
+       wat_inf(ji) = MIN(wat_inf_pot(ji), flux_infilt(ji))
+       mc(ji,1,ins) = mc(ji,1,ins) + wat_inf(ji) * deux / dz(2)
+       !
+       soil_waterinf(ji,1,ins)=wat_inf(ji)
+       soil_smcinfilt(ji,1,ins)=wat_inf(ji) * deux / dz(2)
+    ENDDO
+    ! initialize three variables added by yitong yao 4 Jan 2021
+    !soil_waterinf(:,:,ins)=zero
+    !soil_dtinf(:,:,ins)=zero
+    !soil_infilttmp(:,:,ins)=zero
+    !soil_smcinfilt(:,:,ins)=zero
+    ! above added 
+    !! Initialize a countdown for infiltration during the time-step and the value of potential runoff
+    dt_tmp(:) = dt_sechiba / one_day
+    !write(*,*) 'dt_tmp', dt_tmp(1)
+    infilt_tot(:) = wat_inf(:)
+    !! Compute the rate at which water will try to infiltrate each layer
+    ! flux_temp is converted here to the same unit as k_m
+    flux_tmp(:) = (flux_infilt(:)-wat_inf(:)) / dt_tmp(:)
+
+    !! 2.2 Infiltration layer by layer 
+    DO jsl = 2, nslm-1
+       DO ji = 1, kjpindex
+          !! Infiltrability of each layer if under a saturated one
+          ! This is computed by an simple arithmetic average because 
+          ! the time step (30min) is not appropriate for a geometric average (advised by Haverkamp and Vauclin)
+          k_m = (k(ji,jsl) + ks(njsc(ji))*kfact(jsl-1,njsc(ji))*kfact_root(ji,jsl,ins)) / deux 
+
+          IF (ok_freeze_cwrr) THEN
+             IF (temp_hydro(ji, jsl) .LT. ZeroCelsius) THEN
+                k_m = k(ji,jsl)
+             ENDIF
+          ENDIF
+
+          !! We compute the mean rate at which water actually infiltrate:
+          ! Subgrid: Exponential distribution of k around k_m, but average p directly used 
+          ! See d'Orgeval 2006, p 78, but it's not fully clear to me (AD16***)
+          infilt_tmp(ji) = k_m * (un - EXP(- flux_tmp(ji) / k_m)) 
+          soil_km(ji,jsl,ins)=k_m
+          !! From which we deduce the time it takes to fill up the layer or to end the time step...
+          wat_inf_pot(ji) =  MAX((mcs(njsc(ji))-mc(ji,jsl,ins)) * (dz(jsl) + dz(jsl+1)) / deux, zero)
+          
+         !write(*,*) 'before_infilt_tmp', infilt_tmp(ji)        
+  
+         IF ( infilt_tmp(ji) > min_sechiba) THEN
+            !write(*,*) 'if larger than 0'
+             dt_inf(ji) =  MIN(wat_inf_pot(ji)/infilt_tmp(ji), dt_tmp(ji))
+             ! The water infiltration TIME has to limited by what is still available for infiltration.
+             IF ( dt_inf(ji) * infilt_tmp(ji) > flux_infilt(ji)-infilt_tot(ji) ) THEN
+                dt_inf(ji) = MAX(flux_infilt(ji)-infilt_tot(ji),zero)/infilt_tmp(ji)
+             ENDIF
+          ELSE
+             dt_inf(ji) = dt_tmp(ji)
+          ENDIF
+          soil_resinfilt(ji,jsl,ins)=flux_infilt(ji)-infilt_tot(ji)
+          !write(*,*) 'dt_tmp_5787', dt_tmp(ji)
+          !write(*,*) 'dt_inf_5707', dt_inf(ji)
+          !write(*,*) 'infilt_tmp', infilt_tmp(ji)
+          !write(*,*) 'water_pot', wat_inf_pot(ji)
+          !!write(*,*) 'water_pot_dt', wat_inf_pot(ji)/infilt_tmp(ji)
+          !!write(*,*) 'infilt_diff', flux_infilt(ji)-infilt_tot(ji)
+          !!write(*,*) 'infilt_diff_dt',(flux_infilt(ji)-infilt_tot(ji))/infilt_tmp(ji)
+          !! The water enters in the layer
+          wat_inf(ji) = dt_inf(ji) * infilt_tmp(ji)
+          ! added by yitong yao 4 Jan 2021
+          soil_waterinf(ji,jsl,ins)=wat_inf(ji)
+          soil_dtinf(ji,jsl,ins)=dt_inf(ji)
+          soil_infilttmp(ji,jsl,ins)=infilt_tmp(ji)
+          ! above added 
+          ! bviously the moisture content
+          mc(ji,jsl,ins) = mc(ji,jsl,ins) + &
+               & wat_inf(ji) * deux / (dz(jsl) + dz(jsl+1))
+          soil_smcinfilt(ji,jsl,ins)=wat_inf(ji) * deux / (dz(jsl) + dz(jsl+1))
+          ! the time remaining before the next time step
+          dt_tmp(ji) = dt_tmp(ji) - dt_inf(ji)
+          ! and finally the infilt_tot (which is just used to check if there is a problem, below) 
+          infilt_tot(ji) = infilt_tot(ji) + infilt_tmp(ji) * dt_inf(ji)
+       ENDDO
+    ENDDO
+    !write(*,*) 'go to this step'
+    soil_totalinfilt(:,ins)=infilt_tot(:)
+    !! 2.3 Resulting infiltration and surface runoff
+    ru_infilt(:,ins) = flux_infilt(:) - infilt_tot(:)
+    qinfilt_ns(:,ins) = infilt_tot(:)
+
+    !! 3. For water conservation check: we calculate the total SM at the beginning of the routine
+    !!    and export the difference with the flux
+    IF (check_cwrr2) THEN
+       tmcf(:) = dz(2) * ( trois*mc(:,1,ins) + mc(:,2,ins) )/huit
+       DO jsl = 2,nslm-1
+          tmcf(:) = tmcf(:) + dz(jsl) * (trois*mc(:,jsl,ins)+mc(:,jsl-1,ins))/huit &
+               + dz(jsl+1) * (trois*mc(:,jsl,ins)+mc(:,jsl+1,ins))/huit
+       ENDDO
+       tmcf(:) = tmcf(:) + dz(nslm) * (trois*mc(:,nslm,ins) + mc(:,nslm-1,ins))/huit
+       ! Normally, tcmf=tmci+infilt_tot
+       check(:,ins) = tmcf(:)-(tmci(:)+infilt_tot(:))
+    ENDIF
+    
+    !! 5. Local verification
+    DO ji = 1, kjpindex
+       IF (infilt_tot(ji) .LT. -min_sechiba .OR. infilt_tot(ji) .GT. flux_infilt(ji) + min_sechiba) THEN
+          WRITE (numout,*) 'Error in the calculation of infilt tot', infilt_tot(ji)
+          WRITE (numout,*) 'k, ji, jst, mc', k(ji,1:2), ji, ins, mc(ji,1,ins)
+          CALL ipslerr_p(3, 'hydrol_soil_infilt', 'We will STOP now.','Error in calculation of infilt tot','')
+       ENDIF
+    ENDDO
+
+  END SUBROUTINE hydrol_soil_infilt
+
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_soil_smooth_under_mcr
+!!
+!>\BRIEF        : Modifies the soil moisture profile to avoid under-residual values, 
+!!                then diagnoses the points where such "excess" values remain. 
+!!
+!! DESCRIPTION  :
+!! The "excesses" under-residual are corrected from top to bottom, by transfer of excesses 
+!! to the lower layers. The reverse transfer is performed to smooth any remaining "excess" in the bottom layer.
+!! If some "excess" remain afterwards, the entire soil profile is at the threshold value (mcs or mcr), 
+!! and the remaining "excess" is necessarily concentrated in the top layer. 
+!! This allowing diagnosing the flag is_under_mcr. 
+!! Eventually, the remaining "excess" is split over the entire profile
+!! 1. We calculate the total SM at the beginning of the routine
+!! 2. Smoothes the profile to avoid negative values of punctual soil moisture
+!! Note that we check that mc > min_sechiba in hydrol_soil 
+!! 3. For water conservation check, We calculate the total SM at the beginning of the routine,
+!!    and export the difference with the flux
+!!
+!! RECENT CHANGE(S) : 2016 by A. Ducharne
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_soil_smooth_under_mcr
+
+  SUBROUTINE hydrol_soil_smooth_under_mcr(kjpindex, ins, njsc, is_under_mcr, check)
+
+    !- arguments
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                         :: kjpindex     !! Domain size
+    INTEGER(i_std), INTENT(in)                         :: ins          !! Soiltile index (1-nstm, unitless)
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)   :: njsc         !! Index of the dominant soil textural class in grid cell 
+                                                                       !! (1-nscm, unitless)    
+    
+    !! 0.2 Output variables
+
+    LOGICAL, DIMENSION(kjpindex,nstm), INTENT(out)     :: is_under_mcr !! Flag diagnosing under residual soil moisture
+    REAL(r_std), DIMENSION(kjpindex,nstm), INTENT(out) :: check        !! delta SM - flux
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                       :: ji,jsl
+    REAL(r_std)                          :: excess
+    REAL(r_std), DIMENSION(kjpindex)     :: excessji
+    REAL(r_std), DIMENSION(kjpindex)     :: tmci      !! total SM at beginning of routine
+    REAL(r_std), DIMENSION(kjpindex)     :: tmcf      !! total SM at end of routine
+
+!_ ================================================================================================================================       
+
+    !! 1. We calculate the total SM at the beginning of the routine
+    IF (check_cwrr2) THEN
+       tmci(:) = dz(2) * ( trois*mc(:,1,ins) + mc(:,2,ins) )/huit
+       DO jsl = 2,nslm-1
+          tmci(:) = tmci(:) + dz(jsl) * (trois*mc(:,jsl,ins)+mc(:,jsl-1,ins))/huit &
+               + dz(jsl+1) * (trois*mc(:,jsl,ins)+mc(:,jsl+1,ins))/huit
+       ENDDO
+       tmci(:) = tmci(:) + dz(nslm) * (trois*mc(:,nslm,ins) + mc(:,nslm-1,ins))/huit
+    ENDIF
+
+    !! 2. Smoothes the profile to avoid negative values of punctual soil moisture
+
+    ! 2.1 smoothing from top to bottom
+    DO jsl = 1,nslm-2
+       DO ji=1, kjpindex
+          excess = MAX(mcr(njsc(ji))-mc(ji,jsl,ins),zero)
+          mc(ji,jsl,ins) = mc(ji,jsl,ins) + excess
+          mc(ji,jsl+1,ins) = mc(ji,jsl+1,ins) - excess * &
+               &  (dz(jsl)+dz(jsl+1))/(dz(jsl+1)+dz(jsl+2))
+       ENDDO
+    ENDDO
+!WRITE(numout,*) 'smooth1', mc(10,:,3)
+
+    jsl = nslm-1
+    DO ji=1, kjpindex
+       excess = MAX(mcr(njsc(ji))-mc(ji,jsl,ins),zero)
+       mc(ji,jsl,ins) = mc(ji,jsl,ins) + excess
+       mc(ji,jsl+1,ins) = mc(ji,jsl+1,ins) - excess * &
+            &  (dz(jsl)+dz(jsl+1))/dz(jsl+1)
+    ENDDO
+!WRITE(numout,*) 'smooth2', mc(10,:,3)
+
+    jsl = nslm
+    DO ji=1, kjpindex
+       excess = MAX(mcr(njsc(ji))-mc(ji,jsl,ins),zero)
+       mc(ji,jsl,ins) = mc(ji,jsl,ins) + excess
+       mc(ji,jsl-1,ins) = mc(ji,jsl-1,ins) - excess * &
+            &  dz(jsl)/(dz(jsl-1)+dz(jsl))
+    ENDDO
+!WRITE(numout,*) 'smooth3',ins,  mc(10,:,ins)
+
+    ! 2.2 smoothing from bottom to top
+    DO jsl = nslm-1,2,-1
+       DO ji=1, kjpindex
+          excess = MAX(mcr(njsc(ji))-mc(ji,jsl,ins),zero)
+          mc(ji,jsl,ins) = mc(ji,jsl,ins) + excess
+          mc(ji,jsl-1,ins) = mc(ji,jsl-1,ins) - excess * &
+               &  (dz(jsl)+dz(jsl+1))/(dz(jsl-1)+dz(jsl))
+       ENDDO
+    ENDDO
+!WRITE(numout,*) 'smooth4', ins, mc(10,:,ins)
+
+    ! 2.3 diagnoses is_under_mcr(ji), and updates the entire profile 
+    ! excess > 0
+    DO ji=1, kjpindex
+       excessji(ji) = mask_soiltile(ji,ins) * MAX(mcr(njsc(ji))-mc(ji,1,ins),zero)
+    ENDDO
+!WRITE(numout,*) 'excess2', excessji(10)
+    DO ji=1, kjpindex
+       mc(ji,1,ins) = mc(ji,1,ins) + excessji(ji) ! then mc(1)=mcr then mc is adjusted to 
+       is_under_mcr(ji,ins) = (excessji(ji) .GT. min_sechiba)
+    ENDDO
+!WRITE(numout,*) 'smooth5', ins, mc(10,:,ins)
+!WRITE(numout,*) 'flagIS', ins,  is_under_mcr(10,ins)
+
+    ! 2.4 The amount of water corresponding to excess in the top soil layer is redistributed in all soil layers
+      ! -excess(ji) * dz(2) / deux donne le deficit total, negatif, en mm
+      ! diviser par la profondeur totale en mm donne des delta_mc identiques en chaque couche, en mm
+      ! retransformes en delta_mm par couche selon les bonnes eqs (eqs_hydrol.pdf, Eqs 13-15), puis sommes
+      ! retourne bien le deficit total en mm
+
+! tzjE check weird Agnes 
+    DO jsl = 1, nslm
+       DO ji=1, kjpindex
+          mc(ji,jsl,ins) = mc(ji,jsl,ins) - excessji(ji) * dz(2) / (deux * zmaxh*mille)
+       ENDDO
+    ENDDO
+!WRITE(numout,*) 'smooth6', ins, mc(10,:,ins)
+    ! This can lead to mc(jsl) < mcr depending on the value of excess,
+    ! but this is no major pb for the diffusion
+    ! Yet, we need to prevent evaporation if is_under_mcr
+    
+    !! Note that we check that mc > min_sechiba in hydrol_soil 
+
+    ! We just make sure that mc remains at 0 where soiltile=0
+    DO jsl = 1, nslm
+       DO ji=1, kjpindex
+          mc(ji,jsl,ins) = mask_soiltile(ji,ins) * mc(ji,jsl,ins)
+       ENDDO
+    ENDDO
+!WRITE(numout,*) 'smooth7', ins, mc(10,:,ins)
+!WRITE(numout,*) 'soiltile', ins, mask_soiltile(10,ins)
+
+    !! 3. For water conservation check, We calculate the total SM at the beginning of the routine,
+    !!    and export the difference with the flux
+    IF (check_cwrr2) THEN
+       tmcf(:) = dz(2) * ( trois*mc(:,1,ins) + mc(:,2,ins) )/huit
+       DO jsl = 2,nslm-1
+          tmcf(:) = tmcf(:) + dz(jsl) * (trois*mc(:,jsl,ins)+mc(:,jsl-1,ins))/huit &
+               + dz(jsl+1) * (trois*mc(:,jsl,ins)+mc(:,jsl+1,ins))/huit
+       ENDDO
+       tmcf(:) = tmcf(:) + dz(nslm) * (trois*mc(:,nslm,ins) + mc(:,nslm-1,ins))/huit
+       ! Normally, tcmf=tmci since we just redistribute the deficit 
+       check(:,ins) = tmcf(:)-tmci(:)
+    ENDIF
+       
+  END SUBROUTINE hydrol_soil_smooth_under_mcr
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_soil_smooth_over_mcs
+!!
+!>\BRIEF        : Modifies the soil moisture profile to avoid over-saturation values, 
+!!                by putting the excess in ru_ns
+!!                Thus, no point remain where such "excess" values remain (is_over_mcs becomes useless) 
+!!
+!! DESCRIPTION  :
+!! The "excesses" over-saturation are corrected from top to bottom, by transfer of excesses 
+!! to the lower layers. The reverse transfer is performed to smooth any remaining "excess" in the bottom layer.
+!! If some "excess" remain afterwards, the entire soil profile is at the threshold value (mcs or mcr), 
+!! and the remaining "excess" is necessarily concentrated in the top layer. 
+!! Eventually, the remaining "excess" creates rudr_corr, to be added to ru_ns or dr_ns
+!! 1. We calculate the total SM at the beginning of the routine
+!! 2. In case of over-saturation we put the water where it is possible by smoothing
+!! 3. The excess is transformed into surface runoff, with conversion from m3/m3 to kg/m2
+!! 4. For water conservation checks, we calculate the total SM at the beginning of the routine,
+!!    and export the difference with the flux
+!!
+!! RECENT CHANGE(S) : 2016 by A. Ducharne
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_soil_smooth_over_mcs
+
+  SUBROUTINE hydrol_soil_smooth_over_mcs(kjpindex, ins, njsc, is_over_mcs, rudr_corr, check)
+
+    !- arguments
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                           :: kjpindex        !! Domain size
+    INTEGER(i_std), INTENT(in)                           :: ins             !! Soiltile index (1-nstm, unitless)
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)     :: njsc            !! Index of the dominant soil textural class in grid cell 
+                                                                            !! (1-nscm, unitless)
+    
+    !! 0.2 Output variables
+
+    LOGICAL, DIMENSION(kjpindex), INTENT(out)            :: is_over_mcs     !! Flag diagnosing over saturated soil moisture  
+    REAL(r_std), DIMENSION(kjpindex,nstm), INTENT(out)   :: check           !! delta SM - flux
+    
+    !! 0.3 Modified variables   
+    REAL(r_std), DIMENSION (kjpindex,nstm), INTENT(inout):: rudr_corr         !! Surface runoff produced to correct excess (mm/dtstep)
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                        :: ji,jsl
+    REAL(r_std)                           :: excess
+    REAL(r_std), DIMENSION(kjpindex)      :: tmci    !! total SM at beginning of routine
+    REAL(r_std), DIMENSION(kjpindex)      :: tmcf    !! total SM at end of routine
+
+    !_ ================================================================================================================================
+
+    !! 1. We calculate the total SM at the beginning of the routine
+    IF (check_cwrr2) THEN
+       tmci(:) = dz(2) * ( trois*mc(:,1,ins) + mc(:,2,ins) )/huit
+       DO jsl = 2,nslm-1
+          tmci(:) = tmci(:) + dz(jsl) * (trois*mc(:,jsl,ins)+mc(:,jsl-1,ins))/huit &
+               + dz(jsl+1) * (trois*mc(:,jsl,ins)+mc(:,jsl+1,ins))/huit
+       ENDDO
+       tmci(:) = tmci(:) + dz(nslm) * (trois*mc(:,nslm,ins) + mc(:,nslm-1,ins))/huit
+    ENDIF
+
+    !! 2. In case of over-saturation we put the water where it is possible by smoothing
+
+    ! 2.1 smoothing from top to bottom
+    DO jsl = 1, nslm-2
+       DO ji=1, kjpindex
+          excess = MAX(mc(ji,jsl,ins)-mcs(njsc(ji)),zero)
+          mc(ji,jsl,ins) = mc(ji,jsl,ins) - excess
+          mc(ji,jsl+1,ins) = mc(ji,jsl+1,ins) + excess * &
+               &  (dz(jsl)+dz(jsl+1))/(dz(jsl+1)+dz(jsl+2))
+       ENDDO
+    ENDDO
+
+    jsl = nslm-1
+    DO ji=1, kjpindex
+       excess = MAX(mc(ji,jsl,ins)-mcs(njsc(ji)),zero)
+       mc(ji,jsl,ins) = mc(ji,jsl,ins) - excess
+       mc(ji,jsl+1,ins) = mc(ji,jsl+1,ins) + excess * &
+            &  (dz(jsl)+dz(jsl+1))/dz(jsl+1)
+    ENDDO
+
+    jsl = nslm
+    DO ji=1, kjpindex
+       excess = MAX(mc(ji,jsl,ins)-mcs(njsc(ji)),zero)
+       mc(ji,jsl,ins) = mc(ji,jsl,ins) - excess
+       mc(ji,jsl-1,ins) = mc(ji,jsl-1,ins) + excess * &
+            &  dz(jsl)/(dz(jsl-1)+dz(jsl))
+    ENDDO
+
+    ! 2.2 smoothing from bottom to top, leading  to keep most of the excess in the soil column
+    DO jsl = nslm-1,2,-1
+       DO ji=1, kjpindex
+          excess = MAX(mc(ji,jsl,ins)-mcs(njsc(ji)),zero)
+          mc(ji,jsl,ins) = mc(ji,jsl,ins) - excess
+          mc(ji,jsl-1,ins) = mc(ji,jsl-1,ins) + excess * &
+               &  (dz(jsl)+dz(jsl+1))/(dz(jsl-1)+dz(jsl))
+       ENDDO
+    ENDDO
+
+    !! 3. The excess is transformed into surface runoff, with conversion from m3/m3 to kg/m2
+
+    DO ji=1, kjpindex
+       excess = mask_soiltile(ji,ins) * MAX(mc(ji,1,ins)-mcs(njsc(ji)),zero)
+       mc(ji,1,ins) = mc(ji,1,ins) - excess ! then mc(1)=mcs
+       rudr_corr(ji,ins) = rudr_corr(ji,ins) + excess * dz(2) / deux 
+       is_over_mcs(ji) = .FALSE.
+    ENDDO
+
+    !! 4. For water conservation checks, we calculate the total SM at the beginning of the routine,
+    !!    and export the difference with the flux
+
+    IF (check_cwrr2) THEN
+       tmcf(:) = dz(2) * ( trois*mc(:,1,ins) + mc(:,2,ins) )/huit
+       DO jsl = 2,nslm-1
+          tmcf(:) = tmcf(:) + dz(jsl) * (trois*mc(:,jsl,ins)+mc(:,jsl-1,ins))/huit &
+               + dz(jsl+1) * (trois*mc(:,jsl,ins)+mc(:,jsl+1,ins))/huit
+       ENDDO
+       tmcf(:) = tmcf(:) + dz(nslm) * (trois*mc(:,nslm,ins) + mc(:,nslm-1,ins))/huit
+       ! Normally, tcmf=tmci-rudr_corr
+       check(:,ins) = tmcf(:)-(tmci(:)-rudr_corr(:,ins))
+    ENDIF
+    
+  END SUBROUTINE hydrol_soil_smooth_over_mcs
+
+ !! ================================================================================================================================
+!! SUBROUTINE   : hydrol_soil_smooth_over_mcs2
+!!
+!>\BRIEF        : Modifies the soil moisture profile to avoid over-saturation values, 
+!!                by putting the excess in ru_ns
+!!                Thus, no point remain where such "excess" values remain (is_over_mcs becomes useless) 
+!!
+!! DESCRIPTION  :
+!! The "excesses" over-saturation are corrected, by directly discarding the excess as rudr_corr,
+!! to be added to ru_ns or dr_nsrunoff (via rudr_corr).
+!! Therefore, there is no more smoothing, and this helps preventing the saturation of too many layers,
+!! which leads to numerical errors with tridiag.
+!! 1. We calculate the total SM at the beginning of the routine
+!! 2. In case of over-saturation, we directly eliminate the excess via rudr_corr
+!!    The calculation of the adjustement flux needs to account for nodes n-1 and n+1.
+!! 3. For water conservation checks, we calculate the total SM at the beginning of the routine,
+!!    and export the difference with the flux   
+!!
+!! RECENT CHANGE(S) : 2016 by A. Ducharne
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_soil_smooth_over_mcs2
+
+  SUBROUTINE hydrol_soil_smooth_over_mcs2(kjpindex, ins, njsc, is_over_mcs, rudr_corr, check)
+
+    !- arguments
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                           :: kjpindex        !! Domain size
+    INTEGER(i_std), INTENT(in)                           :: ins             !! Soiltile index (1-nstm, unitless)
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)     :: njsc            !! Index of the dominant soil textural class in grid cell 
+                                                                            !! (1-nscm, unitless)
+    
+    !! 0.2 Output variables
+
+    LOGICAL, DIMENSION(kjpindex), INTENT(out)            :: is_over_mcs     !! Flag diagnosing over saturated soil moisture  
+    REAL(r_std), DIMENSION(kjpindex,nstm), INTENT(out)   :: check           !! delta SM - flux
+    
+    !! 0.3 Modified variables   
+    REAL(r_std), DIMENSION (kjpindex,nstm), INTENT(inout):: rudr_corr         !! Surface runoff produced to correct excess (mm/dtstep)
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                        :: ji,jsl
+    REAL(r_std), DIMENSION(kjpindex,nslm) :: excess
+    REAL(r_std), DIMENSION(kjpindex)      :: tmci    !! total SM at beginning of routine
+    REAL(r_std), DIMENSION(kjpindex)      :: tmcf    !! total SM at end of routine
+
+!_ ================================================================================================================================       
+    !-
+
+    !! 1. We calculate the total SM at the beginning of the routine
+    IF (check_cwrr2) THEN
+       tmci(:) = dz(2) * ( trois*mc(:,1,ins) + mc(:,2,ins) )/huit
+       DO jsl = 2,nslm-1
+          tmci(:) = tmci(:) + dz(jsl) * (trois*mc(:,jsl,ins)+mc(:,jsl-1,ins))/huit &
+               + dz(jsl+1) * (trois*mc(:,jsl,ins)+mc(:,jsl+1,ins))/huit
+       ENDDO
+       tmci(:) = tmci(:) + dz(nslm) * (trois*mc(:,nslm,ins) + mc(:,nslm-1,ins))/huit
+    ENDIF  
+
+    !! 2. In case of over-saturation, we don't do any smoothing,
+    !! but directly eliminate the excess as runoff (via rudr_corr)
+    !    we correct the calculation of the adjustement flux, which needs to account for nodes n-1 and n+1  
+    !    for the calculation to remain simple and accurate, we directly drain all the oversaturated mc,
+    !    without transfering to lower layers        
+
+    !! 2.1 thresholding from top to bottom, with excess defined along jsl
+    DO jsl = 1, nslm
+       DO ji=1, kjpindex
+          excess(ji,jsl) = MAX(mc(ji,jsl,ins)-mcs(njsc(ji)),zero) ! >=0
+          mc(ji,jsl,ins) = mc(ji,jsl,ins) - excess(ji,jsl) ! here mc either does not change or decreases
+       ENDDO
+    ENDDO
+
+    !! 2.2 To ensure conservation, this needs to be balanced by additional drainage (in kg/m2/dt)                        
+    DO ji = 1, kjpindex
+       rudr_corr(ji,ins) = dz(2) * ( trois*excess(ji,1) + excess(ji,2) )/huit ! top layer = initialisation  
+    ENDDO
+    DO jsl = 2,nslm-1 ! intermediate layers      
+       DO ji = 1, kjpindex
+          rudr_corr(ji,ins) = rudr_corr(ji,ins) + dz(jsl) &
+               & * (trois*excess(ji,jsl)+excess(ji,jsl-1))/huit &
+               & + dz(jsl+1) * (trois*excess(ji,jsl)+excess(ji,jsl+1))/huit
+       ENDDO
+    ENDDO
+    DO ji = 1, kjpindex
+       rudr_corr(ji,ins) = rudr_corr(ji,ins) + dz(nslm) &    ! bottom layer 
+            & * (trois * excess(ji,nslm) + excess(ji,nslm-1))/huit
+       is_over_mcs(ji) = .FALSE. 
+    END DO
+
+    !! 3. For water conservation checks, we calculate the total SM at the beginning of the routine,
+    !!    and export the difference with the flux
+
+    IF (check_cwrr2) THEN
+       tmcf(:) = dz(2) * ( trois*mc(:,1,ins) + mc(:,2,ins) )/huit
+       DO jsl = 2,nslm-1
+          tmcf(:) = tmcf(:) + dz(jsl) * (trois*mc(:,jsl,ins)+mc(:,jsl-1,ins))/huit &
+               + dz(jsl+1) * (trois*mc(:,jsl,ins)+mc(:,jsl+1,ins))/huit
+       ENDDO
+       tmcf(:) = tmcf(:) + dz(nslm) * (trois*mc(:,nslm,ins) + mc(:,nslm-1,ins))/huit
+       ! Normally, tcmf=tmci-rudr_corr
+       check(:,ins) = tmcf(:)-(tmci(:)-rudr_corr(:,ins))
+    ENDIF
+    
+  END SUBROUTINE hydrol_soil_smooth_over_mcs2
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_soil_flux
+!!
+!>\BRIEF        : This subroutine diagnoses the vertical liquid water fluxes between the 
+!!                different soil layers, based on each layer water budget. It also checks the
+!!                corresponding water conservation (during redistribution).
+!!
+!! DESCRIPTION  :
+!! 1. Initialize qflux from the bottom, with dr_ns
+!! 2. Between layer nslm and nslm-1, by means of water budget knowing mc changes and flux at the lowest interface
+!! 3. We go up, and deduct qflux(1:nslm-2), still by means of water budget
+!! 4. Water balance verification: pursuing upward water budget, the flux at the surface should equal -flux_top  
+!!
+!! RECENT CHANGE(S) : 2016 by A. Ducharne to fit hydrol_soil
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_soil_flux
+
+  SUBROUTINE hydrol_soil_flux(kjpindex,ins,mclint,flux_top)
+    !
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                         :: kjpindex        !! Domain size
+    INTEGER(i_std), INTENT(in)                         :: ins             !! index of soil type
+    REAL(r_std), DIMENSION (kjpindex,nslm), INTENT(in) :: mclint          !! mc values at the beginning of the time step
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)      :: flux_top        !! Exfiltration (bare soil evaporation minus infiltration)
+    
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                     :: jsl,ji
+    REAL(r_std), DIMENSION(kjpindex)                   :: temp
+
+    !_ ================================================================================================================================
+
+    !- Compute the diffusion flux at every level from bottom to top (using mcl,mclint, and sink values)
+    DO ji = 1, kjpindex
+
+       !! 1. Initialize qflux from the bottom, with dr_ns
+       jsl = nslm
+       qflux(ji,jsl,ins) = dr_ns(ji,ins)
+       !! 2. Between layer nslm and nslm-1, by means of water budget knowing mc changes and flux at the lowest interface
+       !     qflux is downward
+       jsl = nslm-1
+       qflux(ji,jsl,ins) = qflux(ji,jsl+1,ins) & 
+            &  + (mcl(ji,jsl,ins)-mclint(ji,jsl) &
+            &  + trois*mcl(ji,jsl+1,ins) - trois*mclint(ji,jsl+1)) &
+            &  * (dz(jsl+1)/huit) &
+            &  + rootsink(ji,jsl+1,ins) 
+    ENDDO
+
+    !! 3. We go up, and deduct qflux(1:nslm-2), still by means of water budget
+    ! Here, qflux(ji,1,ins) is the downward flux between the top soil layer and the 2nd one
+    DO jsl = nslm-2,1,-1
+       DO ji = 1, kjpindex
+          qflux(ji,jsl,ins) = qflux(ji,jsl+1,ins) & 
+               &  + (mcl(ji,jsl,ins)-mclint(ji,jsl) &
+               &  + trois*mcl(ji,jsl+1,ins) - trois*mclint(ji,jsl+1)) &
+               &  * (dz(jsl+1)/huit) &
+               &  + rootsink(ji,jsl+1,ins) &
+               &  + (dz(jsl+2)/huit) &
+               &  * (trois*mcl(ji,jsl+1,ins) - trois*mclint(ji,jsl+1) &
+               &  + mcl(ji,jsl+2,ins)-mclint(ji,jsl+2)) 
+       END DO
+    ENDDO
+    
+    !! 4. Water balance verification: pursuing upward water budget, the flux at the surface (temp) should equal -flux_top
+    DO ji = 1, kjpindex
+       temp(ji) =  qflux(ji,1,ins) + (dz(2)/huit) &
+            &  * (trois* (mcl(ji,1,ins)-mclint(ji,1)) + (mcl(ji,2,ins)-mclint(ji,2))) &
+            &  + rootsink(ji,1,ins)
+    ENDDO
+
+    ! flux_top is positive when upward, while temp is positive when downward
+    DO ji = 1, kjpindex
+       IF (ABS(flux_top(ji)+temp(ji)).GT. deux*min_sechiba) THEN
+          WRITE(numout,*) 'Problem in the water balance, qflux computation', flux_top(ji),temp(ji)
+          WRITE(numout,*) 'ji', ji, 'jsl',jsl,'ins',ins
+          WRITE(numout,*) 'mclint', mclint(ji,:)
+          WRITE(numout,*) 'mcl', mcl(ji,:,ins)
+          WRITE (numout,*) 'rootsink', rootsink(ji,1,ins)
+          CALL ipslerr_p(3, 'hydrol_soil_flux', 'We will STOP now.',&
+               & 'Problem in the water balance, qflux computation','')
+       ENDIF
+    ENDDO
+
+  END SUBROUTINE hydrol_soil_flux
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_soil_tridiag
+!!
+!>\BRIEF        This subroutine solves a set of linear equations which has a tridiagonal coefficient matrix. 
+!!
+!! DESCRIPTION  : It is only applied in the grid-cells where resolv(ji)=TRUE
+!! 
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : mcl (global module variable)
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_soil_tridiag 
+
+  SUBROUTINE hydrol_soil_tridiag(kjpindex,ins)
+
+    !- arguments
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                         :: kjpindex        !! Domain size
+    INTEGER(i_std), INTENT(in)                         :: ins             !! number of soil type
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                     :: ji,jsl
+    REAL(r_std), DIMENSION(kjpindex)                   :: bet
+    REAL(r_std), DIMENSION(kjpindex,nslm)              :: gam
+
+!_ ================================================================================================================================
+    DO ji = 1, kjpindex
+
+       IF (resolv(ji)) THEN
+          bet(ji) = tmat(ji,1,2)
+          mcl(ji,1,ins) = rhs(ji,1)/bet(ji)
+       ENDIF
+    ENDDO
+
+    DO jsl = 2,nslm
+       DO ji = 1, kjpindex
+          
+          IF (resolv(ji)) THEN
+
+             gam(ji,jsl) = tmat(ji,jsl-1,3)/bet(ji)
+             bet(ji) = tmat(ji,jsl,2) - tmat(ji,jsl,1)*gam(ji,jsl)
+             mcl(ji,jsl,ins) = (rhs(ji,jsl)-tmat(ji,jsl,1)*mcl(ji,jsl-1,ins))/bet(ji)
+          ENDIF
+
+       ENDDO
+    ENDDO
+
+    DO ji = 1, kjpindex
+       IF (resolv(ji)) THEN
+          DO jsl = nslm-1,1,-1
+             mcl(ji,jsl,ins) = mcl(ji,jsl,ins) - gam(ji,jsl+1)*mcl(ji,jsl+1,ins)
+          ENDDO
+       ENDIF
+    ENDDO
+
+  END SUBROUTINE hydrol_soil_tridiag
+ 
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_soil_coef
+!!
+!>\BRIEF        Computes coef for the linearised hydraulic conductivity 
+!! k_lin=a_lin mc_lin+b_lin and the linearised diffusivity d_lin. 
+!!
+!! DESCRIPTION  :
+!! 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.
+!!
+!! RECENT CHANGE(S) : Addition of the dependence to profil_froz_hydro_ns 
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_soil_coef
+ 
+  SUBROUTINE hydrol_soil_coef(kjpindex,ins,njsc)
+
+    IMPLICIT NONE
+    !
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                        :: kjpindex         !! Domain size
+    INTEGER(i_std), INTENT(in)                        :: ins              !! Index of soil type
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)  :: njsc             !! Index of the dominant soil textural class in the grid cell (1-nscm, unitless)
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                    :: jsl,ji,i
+    REAL(r_std)                                       :: mc_ratio
+    REAL(r_std)                                       :: mc_used    !! Used liquid water content
+    REAL(r_std)                                       :: x,m
+    
+!_ ================================================================================================================================
+
+    IF (ok_freeze_cwrr) THEN
+    
+       ! Calculation of liquid and frozen saturation degrees with respect to residual
+       ! x=liquid saturation degree/residual=(mcl-mcr)/(mcs-mcr)
+       ! 1-x=frozen saturation degree/residual=(mcf-mcr)/(mcs-mcr) (=profil_froz_hydro)
+       
+       DO jsl=1,nslm
+          DO ji=1,kjpindex
+             
+             x = 1._r_std - profil_froz_hydro_ns(ji, jsl,ins)
+             
+             ! mc_used is used in the calculation of hydrological properties
+             ! It corresponds to a liquid mc, but the expression is different from mcl in hydrol_soil,
+             ! to ensure that we get the a, b, d of the first bin when mcl<mcr
+             mc_used = mcr(njsc(ji))+x*MAX((mc(ji,jsl, ins)-mcr(njsc(ji))),zero) 
+             !
+             ! calcul de k based on mc_liq
+             !
+             i= MAX(imin, MIN(imax-1, INT(imin +(imax-imin)*(mc_used-mcr(njsc(ji)))/(mcs(njsc(ji))-mcr(njsc(ji))))))
+             a(ji,jsl) = a_lin(i,jsl,njsc(ji)) * kfact_root(ji,jsl,ins) ! in mm/d
+             b(ji,jsl) = b_lin(i,jsl,njsc(ji)) * kfact_root(ji,jsl,ins) ! in mm/d
+             d(ji,jsl) = d_lin(i,jsl,njsc(ji)) * kfact_root(ji,jsl,ins) ! in mm^2/d
+!             k(ji,jsl) = MAX(k_lin(imin+1,jsl,njsc(ji)), &
+!                  a_lin(i,jsl,njsc(ji)) * mc_used + b_lin(i,jsl,njsc(ji))) ! in mm/d
+
+! tzj bug correction see https://forge.ipsl.jussieu.fr/orchidee/ticket/412
+             k(ji,jsl) = kfact_root(ji,jsl,ins) * MAX(k_lin(imin+1,jsl,njsc(ji)), &
+                  a_lin(i,jsl,njsc(ji)) * mc_used + b_lin(i,jsl,njsc(ji))) 
+
+!WRITE(*,*) "tzjDbugokfreeze k", k 
+
+          ENDDO ! loop on grid
+       ENDDO
+             
+    ELSE
+       ! .NOT. ok_freeze_cwrr
+
+
+! REMOVE BLOCK (just to see the difference between bug corrected or not)
+
+!DO  jsl=1,nslm
+!          DO ji=1,kjpindex
+
+             ! it is impossible to consider a mc<mcr for the binning
+!             mc_ratio = MAX(mc(ji,jsl,ins)-mcr(njsc(ji)),zero)/(mcs(njsc(ji))-mcr(njsc(ji)))
+!             i= MAX(MIN(INT((imax-imin)*mc_ratio)+imin , imax-1), imin)
+!             a(ji,jsl) = a_lin(i,jsl,njsc(ji)) * kfact_root(ji,jsl,ins) ! inmm/d
+!             b(ji,jsl) = b_lin(i,jsl,njsc(ji)) * kfact_root(ji,jsl,ins) ! inmm/d
+!             d(ji,jsl) = d_lin(i,jsl,njsc(ji)) * kfact_root(ji,jsl,ins) ! in mm^2/d
+!
+!            k(ji,jsl) = MAX(k_lin(imin+1,jsl,njsc(ji)), &
+!                     a_lin(i,jsl,njsc(ji)) * mc(ji,jsl,ins) +   b_lin(i,jsl,njsc(ji)))  ! in mm/d
+!          END DO
+!       END DO
+!
+!WRITE(*,*) "tzjOLD k", k
+
+       DO jsl=1,nslm
+          DO ji=1,kjpindex 
+             
+             ! it is impossible to consider a mc<mcr for the binning
+             mc_ratio = MAX(mc(ji,jsl,ins)-mcr(njsc(ji)), zero)/(mcs(njsc(ji))-mcr(njsc(ji)))
+             
+             i= MAX(MIN(INT((imax-imin)*mc_ratio)+imin , imax-1), imin)
+             a(ji,jsl) = a_lin(i,jsl,njsc(ji)) * kfact_root(ji,jsl,ins) ! in mm/d
+             b(ji,jsl) = b_lin(i,jsl,njsc(ji)) * kfact_root(ji,jsl,ins) ! in mm/d
+             d(ji,jsl) = d_lin(i,jsl,njsc(ji)) * kfact_root(ji,jsl,ins) ! in mm^2/d
+
+!            k(ji,jsl) = MAX(k_lin(imin+1,jsl,njsc(ji)), &
+!                     a_lin(i,jsl,njsc(ji)) * mc(ji,jsl,ins) + b_lin(i,jsl,njsc(ji)))  ! in mm/d
+!            WRITE(*,*) "tzjDbug old k", k 
+             k(ji,jsl) = kfact_root(ji,jsl,ins) * MAX(k_lin(imin+1,jsl,njsc(ji)), &
+                  a_lin(i,jsl,njsc(ji)) * mc(ji,jsl,ins) + b_lin(i,jsl,njsc(ji))) 
+!WRITE(*,*) "tzjDbug k", k 
+          END DO 
+       END DO
+
+!WRITE(*,*) "tzjDbug k", k
+
+
+    ENDIF
+    
+  END SUBROUTINE hydrol_soil_coef
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_soil_froz
+!!
+!>\BRIEF        Computes profil_froz_hydro_ns, the fraction of frozen water in the soil layers. 
+!!
+!! DESCRIPTION  :
+!!
+!! RECENT CHANGE(S) : Created by A. Ducharne in 2016.
+!!
+!! MAIN OUTPUT VARIABLE(S) : profil_froz_hydro_ns
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_soil_froz
+ 
+  SUBROUTINE hydrol_soil_froz(kjpindex,ins,njsc)
+
+    IMPLICIT NONE
+    !
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                        :: kjpindex         !! Domain size
+    INTEGER(i_std), INTENT(in)                        :: ins              !! Index of soil type
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)  :: njsc             !! Index of the dominant soil textural class in the grid cell (1-nscm, unitless)
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                    :: jsl,ji,i
+    REAL(r_std)                                       :: x,m
+    
+!_ ================================================================================================================================
+
+!    ONLY FOR THE (ok_freeze_cwrr) CASE
+    
+       ! Calculation of liquid and frozen saturation degrees above residual moisture
+       !   x=liquid saturation degree/residual=(mcl-mcr)/(mcs-mcr)
+       !   1-x=frozen saturation degree/residual=(mcf-mcr)/(mcs-mcr) (=profil_froz_hydro)
+       ! It's important for the good work of the water diffusion scheme (tridiag) that the total
+       ! liquid water also includes mcr, so mcl > 0 even when x=0
+       
+       DO jsl=1,nslm
+          DO ji=1,kjpindex
+             ! Van Genuchten parameter for thermodynamical calculation
+             m = 1. -1./nvan(njsc(ji))
+           
+             IF ((.NOT. ok_thermodynamical_freezing).OR.(mc(ji,jsl, ins).LT.(mcr(njsc(ji))+min_sechiba))) THEN
+                ! Linear soil freezing or soil moisture below residual
+                IF (temp_hydro(ji, jsl).GE.(ZeroCelsius+fr_dT/2.)) THEN
+                   x=1._r_std
+                ELSE IF ( (temp_hydro(ji,jsl) .GE. (ZeroCelsius-fr_dT/2.)) .AND. &
+                     (temp_hydro(ji,jsl) .LT. (ZeroCelsius+fr_dT/2.)) ) THEN 
+                   x=(temp_hydro(ji, jsl)-(ZeroCelsius-fr_dT/2.))/fr_dT
+                ELSE 
+                   x=0._r_std
+                ENDIF
+             ELSE IF (ok_thermodynamical_freezing) THEN
+                ! Thermodynamical soil freezing
+                IF (temp_hydro(ji, jsl).GE.(ZeroCelsius+fr_dT/2.)) THEN
+                   x=1._r_std
+                ELSE IF ( (temp_hydro(ji,jsl) .GE. (ZeroCelsius-fr_dT/2.)) .AND. &
+                     (temp_hydro(ji,jsl) .LT. (ZeroCelsius+fr_dT/2.)) ) THEN
+                   ! Factor 2.2 from the PhD of Isabelle Gouttevin
+                  x=MIN(((mcs(njsc(ji))-mcr(njsc(ji))) &
+                        *((2.2*1000.*avan(njsc(ji))*(ZeroCelsius+fr_dT/2.-temp_hydro(ji, jsl)) &
+                        *lhf/ZeroCelsius/10.)**nvan(njsc(ji))+1.)**(-m)) / &
+                        (mc(ji,jsl, ins)-mcr(njsc(ji))),1._r_std)                
+                ELSE
+                   x=0._r_std 
+                ENDIF
+             ENDIF
+             
+             profil_froz_hydro_ns(ji,jsl,ins) = 1._r_std-x
+             
+          ENDDO ! loop on grid
+       ENDDO
+    
+     END SUBROUTINE hydrol_soil_froz
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_soil_setup
+!!
+!>\BRIEF        This subroutine computes the matrix coef.  
+!!
+!! DESCRIPTION  : None 
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : matrix coef
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE hydrol_soil_setup(kjpindex,ins)
+
+
+    IMPLICIT NONE
+    !
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+    INTEGER(i_std), INTENT(in)                        :: kjpindex          !! Domain size
+    INTEGER(i_std), INTENT(in)                        :: ins               !! index of soil type
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std) :: jsl,ji
+    REAL(r_std)                        :: temp3, temp4
+
+!_ ================================================================================================================================
+    !-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
+
+    ! w_time=1 (in constantes_soil) indicates implicit computation for diffusion 
+    temp3 = w_time*(dt_sechiba/one_day)/deux
+    temp4 = (un-w_time)*(dt_sechiba/one_day)/deux
+
+    ! Passage to arithmetic means for layer averages also in this subroutine : Aurelien 11/05/10
+
+    !- coefficient for first layer
+    DO ji = 1, kjpindex
+       e(ji,1) = zero
+       f(ji,1) = trois * dz(2)/huit  + temp3 &
+            & * ((d(ji,1)+d(ji,2))/(dz(2))+a(ji,1))
+       g1(ji,1) = dz(2)/(huit)       - temp3 &
+            & * ((d(ji,1)+d(ji,2))/(dz(2))-a(ji,2))
+       ep(ji,1) = zero
+       fp(ji,1) = trois * dz(2)/huit - temp4 &
+            & * ((d(ji,1)+d(ji,2))/(dz(2))+a(ji,1))
+       gp(ji,1) = dz(2)/(huit)       + temp4 &
+            & * ((d(ji,1)+d(ji,2))/(dz(2))-a(ji,2))
+    ENDDO
+
+    !- coefficient for medium layers
+
+    DO jsl = 2, nslm-1
+       DO ji = 1, kjpindex
+          e(ji,jsl) = dz(jsl)/(huit)                        - temp3 &
+               & * ((d(ji,jsl)+d(ji,jsl-1))/(dz(jsl))+a(ji,jsl-1))
+
+          f(ji,jsl) = trois * (dz(jsl)+dz(jsl+1))/huit  + temp3 &
+               & * ((d(ji,jsl)+d(ji,jsl-1))/(dz(jsl)) + &
+               & (d(ji,jsl)+d(ji,jsl+1))/(dz(jsl+1)) )
+
+          g1(ji,jsl) = dz(jsl+1)/(huit)                     - temp3 &
+               & * ((d(ji,jsl)+d(ji,jsl+1))/(dz(jsl+1))-a(ji,jsl+1))
+
+          ep(ji,jsl) = dz(jsl)/(huit)                       + temp4 &
+               & * ((d(ji,jsl)+d(ji,jsl-1))/(dz(jsl))+a(ji,jsl-1))
+
+          fp(ji,jsl) = trois * (dz(jsl)+dz(jsl+1))/huit - temp4 &
+               & * ( (d(ji,jsl)+d(ji,jsl-1))/(dz(jsl)) + &
+               & (d(ji,jsl)+d(ji,jsl+1))/(dz(jsl+1)) )
+
+          gp(ji,jsl) = dz(jsl+1)/(huit)                     + temp4 &
+               & *((d(ji,jsl)+d(ji,jsl+1))/(dz(jsl+1))-a(ji,jsl+1))
+       ENDDO
+    ENDDO
+
+    !- coefficient for last layer
+    DO ji = 1, kjpindex
+       e(ji,nslm) = dz(nslm)/(huit)        - temp3 &
+            & * ((d(ji,nslm)+d(ji,nslm-1)) /(dz(nslm))+a(ji,nslm-1))
+       f(ji,nslm) = trois * dz(nslm)/huit  + temp3 &
+            & * ((d(ji,nslm)+d(ji,nslm-1)) / (dz(nslm)) &
+            & -a(ji,nslm)*(un-deux*free_drain_coef(ji,ins)))
+       g1(ji,nslm) = zero
+       ep(ji,nslm) = dz(nslm)/(huit)       + temp4 &
+            & * ((d(ji,nslm)+d(ji,nslm-1)) /(dz(nslm))+a(ji,nslm-1))
+       fp(ji,nslm) = trois * dz(nslm)/huit - temp4 &
+            & * ((d(ji,nslm)+d(ji,nslm-1)) /(dz(nslm)) &
+            & -a(ji,nslm)*(un-deux*free_drain_coef(ji,ins)))
+       gp(ji,nslm) = zero
+    ENDDO
+
+  END SUBROUTINE hydrol_soil_setup
+
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_split_soil
+!!
+!>\BRIEF        Splits 2d variables into 3d variables, per soiltile (_ns suffix), at the beginning of hydrol
+!!
+!! DESCRIPTION  :
+!! 1. Split 2d variables into 3d variables, per soiltile
+!! 1.1 Throughfall
+!! 1.2 Bare soil evaporation
+!! 1.2.1 vevapnu_old
+!! 1.2.2 ae_ns new
+!! 1.3 transpiration
+!! 1.4 root sink
+!! 2. Verification: Check if the deconvolution is correct and conserves the fluxes
+!! 2.1 precisol 
+!! 2.2 ae_ns and evapnu
+!! 2.3 transpiration
+!! 2.4 root sink
+!!
+!! RECENT CHANGE(S) : 2016 by A. Ducharne to match the simplification of hydrol_soil
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_split_soil
+
+  SUBROUTINE hydrol_split_soil (kjpindex, veget_max, soiltile, vevapnu, transpir, humrel, evap_bare_lim, tot_bare_soil,e_frac)
+    ! 
+    ! interface description
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                               :: kjpindex
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(in)       :: veget_max        !! max Vegetation map 
+    REAL(r_std), DIMENSION (kjpindex,nstm), INTENT (in)      :: soiltile         !! Fraction of each soil tile (0-1, unitless)
+    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,nbdl,nstm), INTENT (in)       :: e_frac        !! Relative humidity per layer if rsoilroot is activated
+
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: evap_bare_lim    !!   
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: tot_bare_soil    !! Total evaporating bare soil fraction 
+
+    !! 0.4 Local variables
+
+    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
+    LOGICAL                                       :: error=.FALSE. !! If true, exit in the end of subroutine
+    LOGICAL, SAVE                                 :: rsoilroot = .TRUE.
+    !$OMP THREADPRIVATE(rsoilroot)
+!_ ================================================================================================================================
+   
+ CALL getin_p('rsoilroot',rsoilroot)  !!! CHECK if OK 
+! WRITE(*,*) "test flagtzj hydrolsplitsoil", rsoilroot
+
+
+ 
+    !! 1. Split 2d variables into 3d variables, per soiltile
+    
+    ! Reminders:
+    !  vegetmax_soil(:,nvm,nstm) = PFT fraction per soiltile in each grid-cell
+    !      vegetmax_soil(ji,jv,jst)=veget_max(ji,jv)/soiltile(ji,jst) 
+    !  cvs_over_veg(:,nvm,nstm) = old value of vegetmax_soil/veget_max/vegtot, kept from diag to next split 
+    !  soiltile(:,nstm) = fraction (of vegtot+totfrac_nobio) covered by each soiltile in a grid-cell (0-[1-fracnobio], unitless)  
+    !      soiltile #1 includes nobio 
+    !  vegtot(:) = total fraction of grid-cell covered by PFTs (fraction with bare soil + vegetation)
+    !  veget_max(:,nvm) = PFT fractions of vegtot+frac_nobio 
+    !  veget(:,nvm) =  fractions (of vegtot+frac_nobio) covered by vegetation in each PFT 
+    !       BUT veget(:,1)=veget_max(:,1) 
+    !  frac_bare(:,nvm) = fraction (of veget_max) with bare soil in each PFT
+    !  tot_bare_soil(:) = total evaporating bare soil fraction (=SUM(frac_bare*veget_max))
+    !  frac_bare_ns(:,nstm) = evaporating bare soil fraction (of vegtot) per soiltile (defined in hydrol_vegupd)
+    ! 
+    ! AD16*** isn't there a pb in vegetmax_soil as SUM(soiltiles)=totfrac_nobio + vegtot ???
+    
+    !! 1.1 Throughfall
+    !      We use vegetmax_soil, i.e. the vegetation cover of this timestep, which is normal for interception processes
+    precisol_ns(:,:)=zero
+    DO jv=1,nvm
+       DO jst=1,nstm
+          DO ji=1,kjpindex
+             IF(veget_max(ji,jv).GT.min_sechiba) THEN
+                precisol_ns(ji,jst)=precisol_ns(ji,jst)+precisol(ji,jv)* &
+                     & vegetmax_soil(ji,jv,jst) /vegtot(ji) / veget_max(ji,jv)
+             ENDIF
+          END DO
+       END DO
+    END DO
+    
+    !! 1.2 Bare soil evaporation
+    !! 1.2.1 vevapnu_old
+! AD16*** vevapnu_old ne sert que pour le split suivant de vevapnu (issu de enerbil) en ae_ns pour hydrol_soil
+!           mais il ne semble y avoir aucune bonne raison de contraindre ae_ns en fonction de vevapnu_old
+    vevapnu_old(:)=zero
+    DO jst=1,nstm
+       DO ji=1,kjpindex
+          IF ( vegtot(ji) .GT. min_sechiba) THEN
+             vevapnu_old(ji)=vevapnu_old(ji)+ &
+                  & ae_ns(ji,jst)*soiltile(ji,jst)*vegtot(ji)
+          ENDIF
+       END DO
+    END DO
+    
+    !! 1.2.2 ae_ns new
+! AD16*** les lignes ci-dessous sont excessivement compliquees et ne garantissent pas que ae_ns = 0 si evap_bare_lim=0 
+!           c'est notamment le cas pour les 3emes et 6emes conditions
+    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
+                IF(vevapnu_old(ji).GT.min_sechiba) THEN  
+                   ae_ns(ji,jst)=ae_ns(ji,jst) * vevapnu(ji)/vevapnu_old(ji) ! 3Ãšme condition
+                ELSE
+                   ae_ns(ji,jst)=zero
+                ENDIF
+             ENDIF
+          ELSEIF(frac_bare_ns(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
+                IF(tot_bare_soil(ji).GT.min_sechiba) THEN  
+                   ae_ns(ji,jst) = vevapnu(ji) * frac_bare_ns(ji,jst)/tot_bare_soil(ji) ! 6Ãšme condition
+                ELSE
+                   ae_ns(ji,jst) = zero
+                ENDIF
+             ENDIF
+          ENDIF
+       END DO
+    END DO
+! AD16*** La tentative de simplification ci-dessous ne marche pas 
+!!$    ! given the definition of evap_bare_lim, it leads to sum(ae_ns(ji,jst)*soiltile(ji,jst)*vegtot(ji))=vevapnu(ji)
+!!$    ae_ns(:,:)=zero
+!!$    DO jst=1,nstm
+!!$       DO ji=1,kjpindex
+!!$          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) 
+!!$          ENDIF
+!!$       ENDDO
+!!$    ENDDO
+    
+    !! 1.3 transpiration
+    tr_ns(:,:)=zero
+    DO jv=1,nvm
+       DO jst=1,nstm
+          DO ji=1,kjpindex
+             IF (humrel(ji,jv).GT.min_sechiba) THEN 
+                tr_ns(ji,jst)=tr_ns(ji,jst)+ cvs_over_veg(ji,jv,jst)*humrelv(ji,jv,jst)* & 
+                     & transpir(ji,jv)/humrel(ji,jv)
+             ENDIF
+          END DO
+       END DO
+    END DO
+!WRITE(numout,*) 'tr_nsE per tile', tr_ns(10,:)
+
+    !! 1.4 root sink
+    rootsink(:,:,:)=zero
+
+
+    DO jv=1,nvm
+
+IF ( (rsoilroot) .AND. (jv .EQ. 2)) THEN 
+
+!WRITE(*,*) "rsoilroot ON and PFT=2(hydrol split soil)", jv
+!    DO jv=1,nvm
+       DO jsl=1,nslm
+          DO jst=1,nstm
+             DO ji=1,kjpindex
+                IF (humrel(ji,jv).GT.min_sechiba) THEN
+                   rootsink(ji,jsl,jst) = rootsink(ji,jsl,jst) &
+                        & + cvs_over_veg(ji,jv,jst)* (transpir(ji,jv)*e_frac(ji,jsl,jst))
+                   ! rootsink(ji,1,jst)=0 as us(ji,jv,jst,1)=0
+                END IF
+             END DO
+          END DO
+       END DO
+!    END DO
+
+ELSE
+
+!WRITE(*,*) "rsoilroot OFF (hydrol split soil)", jv
+!    DO jv=1,nvm
+       DO jsl=1,nslm
+          DO jst=1,nstm
+             DO ji=1,kjpindex
+                IF (humrel(ji,jv).GT.min_sechiba) THEN 
+                   rootsink(ji,jsl,jst) = rootsink(ji,jsl,jst) &
+                        & + cvs_over_veg(ji,jv,jst)* (transpir(ji,jv)*us(ji,jv,jst,jsl))/ &
+                        & humrel(ji,jv)
+                   ! rootsink(ji,1,jst)=0 as us(ji,jv,jst,1)=0
+                END IF
+             END DO
+          END DO
+       END DO
+!    END DO
+ENDIF
+
+END DO
+!WRITE(numout,*) 'Eroot_sink  per pft', rootsink(10,:,jst)
+    !! 2. Verification: Check if the deconvolution is correct and conserves the fluxes
+
+    IF (check_cwrr) THEN
+
+       !! 2.1 precisol 
+
+       tmp_check1(:)=zero
+       DO jst=1,nstm
+          DO ji=1,kjpindex
+             tmp_check1(ji)=tmp_check1(ji) + precisol_ns(ji,jst)*soiltile(ji,jst)*vegtot(ji)
+          END DO
+       END DO
+       
+       tmp_check2(:)=zero  
+       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,*) 'err',ABS(tmp_check1(ji)- tmp_check2(ji))
+             WRITE(numout,*) 'vegtot',vegtot(ji)
+             DO jv=1,nvm
+                WRITE(numout,'(a,i2.2,"|",F13.4,"|",F13.4,"|",3(F9.6))') &
+                     'jv,veget_max, precisol, vegetmax_soil ', &
+                     jv,veget_max(ji,jv),precisol(ji,jv),vegetmax_soil(ji,jv,:)
+             END DO
+             DO jst=1,nstm
+                WRITE(numout,*) 'jst,precisol_ns',jst,precisol_ns(ji,jst)
+                WRITE(numout,*) 'soiltile', soiltile(ji,jst)
+             END DO
+             error=.TRUE.
+             CALL ipslerr_p(2, 'hydrol_split_soil', 'We will STOP in the end of this subroutine.',&
+                  & 'check_CWRR','PRECISOL SPLIT FALSE')
+          ENDIF
+       END DO
+       
+       !! 2.2 ae_ns and evapnu
+
+       tmp_check1(:)=zero
+       DO jst=1,nstm
+          DO ji=1,kjpindex
+             tmp_check1(ji)=tmp_check1(ji) + ae_ns(ji,jst)*soiltile(ji,jst)*vegtot(ji)
+          END DO
+       END DO
+
+       DO ji=1,kjpindex   
+!ji=10
+          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,*) 'err',ABS(tmp_check1(ji)- vevapnu(ji))
+             WRITE(numout,*) 'ae_ns',ae_ns(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,*) 'tot_bare_soil,frac_bare_ns',tot_bare_soil(ji),frac_bare_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,*) 'soiltile', soiltile(ji,jst)
+                WRITE(numout,*) 'veget_max/vegtot/soiltile', veget_max(ji,:)/vegtot(ji)/soiltile(ji,jst)
+                WRITE(numout,*) "vegetmax_soil",vegetmax_soil(ji,:,jst)
+             END DO
+             error=.TRUE.
+             CALL ipslerr_p(2, 'hydrol_split_soil', 'We will STOP in the end of this subroutine.',&
+                  & 'check_CWRR','VEVAPNU SPLIT FALSE')
+          ENDIF
+       ENDDO
+
+    !! 2.3 transpiration
+
+       tmp_check1(:)=zero
+       DO jst=1,nstm
+          DO ji=1,kjpindex
+             tmp_check1(ji)=tmp_check1(ji) + tr_ns(ji,jst)*soiltile(ji,jst)*vegtot(ji)
+          END DO
+       END DO
+       
+       tmp_check2(:)=zero  
+       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,*) 'err',ABS(tmp_check1(ji)- tmp_check2(ji))
+             WRITE(numout,*) 'vegtot',vegtot(ji)
+             DO jv=1,nvm
+                WRITE(numout,*) 'jv,veget_max, transpir',jv,veget_max(ji,jv),transpir(ji,jv)
+                DO jst=1,nstm
+                   WRITE(numout,*) 'vegetmax_soil:ji,jv,jst',ji,jv,jst,vegetmax_soil(ji,jv,jst)
+                END DO
+             END DO
+             DO jst=1,nstm
+                WRITE(numout,*) 'jst,tr_ns',jst,tr_ns(ji,jst)
+                WRITE(numout,*) 'soiltile', soiltile(ji,jst)
+             END DO
+             error=.TRUE.
+             CALL ipslerr_p(2, 'hydrol_split_soil', 'We will STOP in the end of this subroutine.',&
+                  & 'check_CWRR','TRANSPIR SPLIT FALSE')
+          ENDIF
+
+       END DO
+
+    !! 2.4 root sink
+
+       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,*) 'err',ABS(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
+                error=.TRUE.
+                CALL ipslerr_p(2, 'hydrol_split_soil', 'We will STOP in the end of this subroutine.',&
+                  & 'check_CWRR','ROOTSINK SPLIT FALSE')
+             ENDIF
+          END DO
+       END DO
+
+    ENDIF ! end of check_cwrr
+
+!! Exit if error was found previously in this subroutine
+    IF ( error ) THEN
+       WRITE(numout,*) 'One or more errors have been detected in hydrol_split_soil. Model stops.'
+       CALL ipslerr_p(3, 'hydrol_split_soil', 'We will STOP now.',&
+                  & 'One or several fatal errors were found previously.','')
+    END IF
+
+  END SUBROUTINE hydrol_split_soil
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_diag_soil
+!!
+!>\BRIEF        Calculates diagnostic variables at the grid-cell scale
+!!
+!! DESCRIPTION  :
+!! - 1. Apply mask_soiltile
+!! - 2. Sum 3d variables in 2d variables with fraction of vegetation per soil type
+!!
+!! RECENT CHANGE(S) : 2016 by A. Ducharne for the claculation of shumdiag_perma
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_diag_soil
+
+  SUBROUTINE hydrol_diag_soil (kjpindex, veget_max, soiltile, njsc, runoff, drainage, &
+       & evapot, vevapnu, returnflow, reinfiltration, irrigation, &
+       & shumdiag,shumdiag_perma, k_litt, litterhumdiag, humrel, vegstress, drysoil_frac, tot_melt)
+    ! 
+    ! interface description
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: veget_max       !! Max. vegetation type
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)         :: njsc            !! Index of the dominant soil textural class in the grid cell (1-nscm, unitless)
+    REAL(r_std), DIMENSION (kjpindex,nstm), INTENT (in)      :: soiltile        !! Fraction of each soil tile (0-1, unitless)
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: evapot          !! 
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: returnflow      !! Water returning to the deep reservoir
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: reinfiltration  !! Water returning to the top of the soil
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: irrigation      !! Water from irrigation
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: tot_melt        !!
+
+    !! 0.2 Output variables
+
+    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,nbdl), INTENT (out)      :: shumdiag        !! relative soil moisture
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out)      :: shumdiag_perma  !! Percent of porosity filled with water (mc/mcs) used for the thermal computations
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: k_litt          !! litter cond.
+    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)
+ 
+    !! 0.3 Modified variables 
+
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: vevapnu         !!
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                           :: ji, jv, jsl, jst, i, jd
+    REAL(r_std), DIMENSION (kjpindex)                        :: mask_vegtot
+    REAL(r_std)                                              :: k_tmp, tmc_litter_ratio
+
+!_ ================================================================================================================================
+    !
+    ! Put the prognostics variables of soil to zero if soiltype is zero
+
+    !! 1. Apply mask_soiltile
+    
+    DO jst=1,nstm 
+       DO ji=1,kjpindex
+
+             ae_ns(ji,jst) = ae_ns(ji,jst) * mask_soiltile(ji,jst)
+             dr_ns(ji,jst) = dr_ns(ji,jst) * mask_soiltile(ji,jst)
+             ru_ns(ji,jst) = ru_ns(ji,jst) * mask_soiltile(ji,jst)
+             tmc(ji,jst) =  tmc(ji,jst) * mask_soiltile(ji,jst)
+
+             DO jv=1,nvm
+                humrelv(ji,jv,jst) = humrelv(ji,jv,jst) * mask_soiltile(ji,jst)
+                DO jsl=1,nslm
+                   us(ji,jv,jst,jsl) = us(ji,jv,jst,jsl)  * mask_soiltile(ji,jst)
+                END DO
+             END DO
+
+             DO jsl=1,nslm          
+                mc(ji,jsl,jst) = mc(ji,jsl,jst)  * mask_soiltile(ji,jst)
+             END DO
+
+       END DO
+    END DO
+!WRITE(numout,*),'humrelE',humrelv(10,:,3)
+!WRITE(numout,*),'usE-L1', us(10,:,3,1)
+!WRITE(numout,*),'usE-L12', us(10,:,3,12)
+!WRITE(numout,*),'usE soiltile2', us(10,:,2,:)
+!WRITE(numout,*),'tmc', tmc(10,3)
+!WRITE(numout,*),'masksoil 10', mask_soiltile(10,:)=1 1 1 
+!WRITE(numout,*),'masksoil 20', mask_soiltile(20,:)
+
+    runoff(:) = zero
+    drainage(:) = zero
+    humtot(:) = zero
+    shumdiag(:,:)= zero
+    shumdiag_perma(:,:)=zero
+    k_litt(:) = zero
+    litterhumdiag(:) = zero
+    tmc_litt_dry_mea(:) = zero
+    tmc_litt_wet_mea(:) = zero
+    tmc_litt_mea(:) = zero
+    humrel(:,:) = zero
+    vegstress(:,:) = zero
+    swi(:) = zero! tzjswi 
+    IF (ok_freeze_cwrr) THEN
+       profil_froz_hydro(:,:)=zero ! initialisation for the mean of profil_froz_hydro_ns
+    ENDIF
+    
+    !! 2. Sum 3d variables in 2d variables with fraction of vegetation per soil type
+
+    DO ji = 1, kjpindex
+       mask_vegtot(ji) = 0
+       IF(vegtot(ji) .GT. min_sechiba) THEN
+          mask_vegtot(ji) = 1
+       ENDIF
+    END DO
+    
+    DO ji = 1, kjpindex 
+       ! Here we weight ae_ns by the fraction of bare evaporating soil. 
+       ! This is given by frac_bare_ns, taking into account bare soil under vegetation
+       ae_ns(ji,:) = mask_vegtot(ji) * ae_ns(ji,:) * frac_bare_ns(ji,:)
+    END DO
+
+    DO jst = 1, nstm
+       DO ji = 1, kjpindex 
+          drainage(ji) = mask_vegtot(ji) * (drainage(ji) + vegtot(ji)*soiltile(ji,jst) * dr_ns(ji,jst))
+          runoff(ji) = mask_vegtot(ji) *  (runoff(ji) +   vegtot(ji)*soiltile(ji,jst) * ru_ns(ji,jst)) &
+               & + (1 - mask_vegtot(ji)) * (tot_melt(ji) + irrigation(ji) + returnflow(ji) + reinfiltration(ji))
+          humtot(ji) = mask_vegtot(ji) * (humtot(ji) + soiltile(ji,jst) * tmc(ji,jst)) 
+          IF (ok_freeze_cwrr) THEN 
+             !  profil_froz_hydro_ns comes from hydrol_soil, to remain the same as in the prognotic loop
+             profil_froz_hydro(ji,:)=mask_vegtot(ji) * &
+                  (profil_froz_hydro(ji,:) + soiltile(ji,jst) * profil_froz_hydro_ns(ji,:, jst))
+          ENDIF
+       END DO
+    END DO
+!WRITE(numout,*) 'drainagehydrol', drainage(10)
+    ! we add the excess of snow sublimation to vevapnu
+    ! - because vevapsno is modified in hydrol_snow if subsinksoil
+    ! - it is multiplied by vegtot because it is devided by 1-tot_frac_nobio at creation in hydrol_snow
+
+    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)
+                vegstress(ji,jv)= MAX(vegstress(ji,jv),zero)
+             ENDIF
+          END DO
+       END DO
+    END DO
+
+    cvs_over_veg(:,:,:) = zero
+    DO jv=1,nvm
+       DO ji=1,kjpindex
+          IF(veget_max(ji,jv).GT.min_sechiba) THEN
+             DO jst=1,nstm
+                cvs_over_veg(ji,jv,jst) = vegetmax_soil(ji,jv,jst)/vegtot(ji) / veget_max(ji,jv)
+             ENDDO
+          ENDIF
+       END DO
+    END DO
+
+    DO jst=1,nstm
+       DO jv=1,nvm
+          DO ji=1,kjpindex
+             humrel(ji,jv)=humrel(ji,jv)+humrelv(ji,jv,jst)
+             humrel(ji,jv)=MAX(humrel(ji,jv),zero)
+          END DO
+       END DO
+    END DO
+
+    ! Litter
+    DO jst=1,nstm       
+       DO ji=1,kjpindex
+          ! We compute here a mean k for the 'litter' used for reinfiltration from floodplains of ponds        
+          IF ( tmc_litter(ji,jst) < tmc_litter_res(ji,jst)) THEN
+             i = imin
+          ELSE
+             tmc_litter_ratio = (tmc_litter(ji,jst)-tmc_litter_res(ji,jst)) / &
+                  & (tmc_litter_sat(ji,jst)-tmc_litter_res(ji,jst))
+             i= MAX(MIN(INT((imax-imin)*tmc_litter_ratio)+imin, imax-1), imin)
+          ENDIF       
+          k_tmp = MAX(k_lin(i,1,njsc(ji))*ks(njsc(ji)), zero)
+          k_litt(ji) = k_litt(ji) + soiltile(ji,jst) * SQRT(k_tmp)
+       ENDDO      
+       DO ji=1,kjpindex
+          litterhumdiag(ji) = litterhumdiag(ji) + &
+               & soil_wet_litter(ji,jst) * soiltile(ji,jst)
+
+          tmc_litt_wet_mea(ji) =  tmc_litt_wet_mea(ji) + & 
+               & tmc_litter_awet(ji,jst)* soiltile(ji,jst)
+
+          tmc_litt_dry_mea(ji) = tmc_litt_dry_mea(ji) + &
+               & tmc_litter_adry(ji,jst) * soiltile(ji,jst) 
+
+          tmc_litt_mea(ji) = tmc_litt_mea(ji) + &
+               & tmc_litter(ji,jst) * soiltile(ji,jst) 
+       ENDDO
+    ENDDO
+    
+    DO ji=1,kjpindex
+       IF ( tmc_litt_wet_mea(ji) - tmc_litt_dry_mea(ji) > zero ) THEN
+          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)
+       ELSE
+          drysoil_frac(ji) = zero
+       ENDIF
+    END DO
+    
+    ! Calculate soilmoist, as a function of total water content (mc)
+    soilmoist(:,:) = zero
+    DO jst=1,nstm
+       DO ji=1,kjpindex
+             soilmoist(ji,1) = soilmoist(ji,1) + soiltile(ji,jst) * &
+                  dz(2) * ( trois*mc(ji,1,jst) + mc(ji,2,jst) )/huit
+             DO jsl = 2,nslm-1
+                soilmoist(ji,jsl) = soilmoist(ji,jsl) + soiltile(ji,jst) * &
+                     ( dz(jsl) * (trois*mc(ji,jsl,jst)+mc(ji,jsl-1,jst))/huit &
+                     + dz(jsl+1) * (trois*mc(ji,jsl,jst)+mc(ji,jsl+1,jst))/huit )
+             END DO
+             soilmoist(ji,nslm) = soilmoist(ji,nslm) + soiltile(ji,jst) * &
+                  dz(nslm) * (trois*mc(ji,nslm,jst) + mc(ji,nslm-1,jst))/huit
+       END DO
+    END DO
+
+    DO jst=1,nstm      
+       DO jd=1,nbdl
+          DO ji=1,kjpindex
+             DO jsl=1,nslm   
+                shumdiag(ji,jd) = shumdiag(ji,jd) + soil_wet(ji,jsl,jst) * &
+                     soiltile(ji,jst) * frac_hydro_diag(jsl,jd) * &
+                     ((mcs(njsc(ji))-mcw(njsc(ji)))/(mcf(njsc(ji))-mcw(njsc(ji))))
+               ENDDO
+! tzjswi
+!             shumdiag(ji,jd) = MAX(MIN(shumdiag(ji,jd), un), zero) 
+          ENDDO
+       ENDDO
+    ENDDO
+
+
+! tzjswi
+    ! First we compute swi (ALMIP requirement) - we assume here that dz is
+    ! independant of jst (jst=1)
+    jst=1
+    DO ji=1,kjpindex
+       swi(ji) = swi(ji) + shumdiag(ji,1) * (dz(2))/(deux*zmaxh*mille)
+       DO jsl=2,nslm-1
+          swi(ji) = swi(ji) + shumdiag(ji,jsl) *(dz(jsl)+dz(jsl+1))/(deux*zmaxh*mille)
+       ENDDO
+       jsl = nslm
+       swi(ji) = swi(ji) + shumdiag(ji,jsl) * (dz(jsl))/(deux*zmaxh*mille)
+    END DO
+
+
+    ! For stomate we need shumdiag to be bounded by 0 and 1
+    shumdiag(:,:) = MIN(shumdiag(:,:), un)
+    shumdiag(:,:) = MAX(shumdiag(:,:), zero)
+
+
+    
+    ! Shumdiag_perma is based on soilmoist / moisture at saturation in the layer  
+    DO jd=1,nbdl
+       DO ji=1,kjpindex
+          DO jsl=1,nslm              
+             shumdiag_perma(ji,jd) = soilmoist(ji,jsl)*frac_hydro_diag(jsl,jd) &
+                  /(dh(jsl)*mcs(njsc(ji)))
+          ENDDO
+          shumdiag_perma(ji,jd) = MAX(MIN(shumdiag_perma(ji,jd), un), zero) 
+       ENDDO
+ENDDO
+  END SUBROUTINE hydrol_diag_soil
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_waterbal_init
+!!
+!>\BRIEF        Initialize variables needed for hydrol_waterbal
+!!
+!! DESCRIPTION  : Initialize variables needed for hydrol_waterbal
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+  SUBROUTINE hydrol_waterbal_init(kjpindex, qsintveg, snow, snow_nobio)
+    
+    !! 0. Variable and parameter declaration
+    !! 0.1 Input variables
+    INTEGER(i_std), INTENT (in)                          :: kjpindex     !! Domain size
+    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
+    
+    !! 0.2 Local variables
+    INTEGER(i_std) :: ji
+    REAL(r_std) :: watveg
+
+!_ ================================================================================================================================
+    !
+    !
+    !
+    IF ( ALL( tot_water_beg(:) == val_exp ) ) THEN
+       ! tot_water_beg was not found in restart file
+       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(:)
+       tot_flux(:) = zero
+    ELSE 
+       tot_water_end(:) = tot_water_beg(:)
+       tot_flux(:) = zero
+    ENDIF
+
+  END SUBROUTINE hydrol_waterbal_init
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_waterbal 
+!!
+!>\BRIEF        Checks the water balance.
+!!
+!! DESCRIPTION  :
+!! This routine 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
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_waterbal
+
+  SUBROUTINE hydrol_waterbal (kjpindex, index, veget_max, totfrac_nobio, &
+       & qsintveg, snow,snow_nobio, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, tot_melt, &
+       & vevapwet, transpir, vevapnu, vevapsno, vevapflo, floodout, runoff, drainage)
+    !
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    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_max    !! Max 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 to the bottom
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: reinfiltration !! Water to the top
+    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)      :: vevapflo     !! Floodplains evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: floodout     !! flow out of floodplains
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: runoff       !! complete runoff
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: drainage     !! Drainage
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std) :: ji
+    REAL(r_std) :: watveg, delta_water
+    LOGICAL     :: error=.FALSE.  !! If true, exit in the end of subroutine
+
+!_ ================================================================================================================================
+
+    tot_water_end(:) = zero
+    tot_flux(:) = 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)
+
+          error=.TRUE.
+          CALL ipslerr_p(2, 'hydrol_waterbal', 'We will STOP in the end of hydrol_waterbal.','','')
+       ENDIF
+    ENDDO
+
+    DO ji = 1, kjpindex
+       !
+       watveg = SUM(qsintveg(ji,:))
+       tot_water_end(ji) = humtot(ji)*vegtot(ji) + watveg + &
+            & snow(ji) + SUM(snow_nobio(ji,:))
+       !
+       tot_flux(ji) =  precip_rain(ji) + precip_snow(ji) + irrigation (ji) - &
+            & SUM(vevapwet(ji,:)) - SUM(transpir(ji,:)) - vevapnu(ji) - vevapsno(ji) - vevapflo(ji) + &
+            & floodout(ji) - runoff(ji) - drainage(ji) + returnflow(ji) + reinfiltration(ji)
+    ENDDO
+    
+    DO ji = 1, kjpindex
+       !
+       delta_water = tot_water_end(ji) - tot_water_beg(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(ji)) .GT. deux*allowed_err ) THEN
+          WRITE(numout,*) '------------------------------------------------------------------------- '
+          WRITE(numout,*) 'HYDROL does not conserve water. The erroneous point is : ', ji
+          WRITE(numout,*) 'Coord erroneous point', lalo(ji,:)
+          WRITE(numout,*) 'The error in mm/s is :', (delta_water-tot_flux(ji))/dt_sechiba, ' and in mm/dt : ', &
+               & delta_water-tot_flux(ji)
+          WRITE(numout,*) 'delta_water : ', delta_water, ' tot_flux : ', tot_flux(ji)
+          WRITE(numout,*) 'Actual and allowed error : ', ABS(delta_water-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 routing. Reinfiltration/returnflow/irrigation : ', reinfiltration(ji), &
+               & returnflow(ji),irrigation(ji)
+          WRITE(numout,*) 'Total water in soil humtot:',  humtot(ji)
+          WRITE(numout,*) 'mc:' , mc(ji,:,:)
+          WRITE(numout,*) 'Water on vegetation watveg:', watveg
+          WRITE(numout,*) 'Snow mass snow:', snow(ji)
+          WRITE(numout,*) 'Snow mass on ice snow_nobio:', SUM(snow_nobio(ji,:))
+          WRITE(numout,*) 'Melt water tot_melt:', tot_melt(ji)
+          WRITE(numout,*) 'evapwet : ', vevapwet(ji,:)
+          WRITE(numout,*) 'transpir : ', transpir(ji,:)
+          WRITE(numout,*) 'evapnu, evapsno, evapflo: ', vevapnu(ji), vevapsno(ji), vevapflo(ji)
+          WRITE(numout,*) 'drainage,runoff,floodout : ', drainage(ji),runoff(ji),floodout(ji)
+          
+          error=.TRUE.
+          CALL ipslerr_p(2, 'hydrol_waterbal', 'We will STOP in the end of 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
+    !
+    
+    ! Exit if one or more errors were found
+    IF ( error ) THEN
+       WRITE(numout,*) 'One or more errors have been detected in hydrol_waterbal. Model stops.'
+       CALL ipslerr_p(3, 'hydrol_waterbal', 'We will STOP now.',&
+            'One or several fatal errors were found previously.','')
+    END IF
+    
+  END SUBROUTINE hydrol_waterbal
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_alma 
+!!
+!>\BRIEF        This routine computes the changes in soil moisture and interception storage for the ALMA outputs.  
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!_ hydrol_alma
+
+  SUBROUTINE hydrol_alma (kjpindex, index, lstep_init, qsintveg, snow, snow_nobio, soilwet)
+    !
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    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)                               :: lstep_init   !! 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,nnobio), INTENT (in) :: snow_nobio !! Water balance on ice, lakes, .. [Kg/m^2]
+
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: soilwet     !! Soil wetness
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std) :: ji
+    REAL(r_std) :: watveg
+
+!_ ================================================================================================================================
+    !
+    !
+    IF ( lstep_init ) THEN
+       ! Initialize variables if they were not found in the restart file
+
+       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
+
+       RETURN
+
+    ENDIF
+    !
+    ! Calculate the values for the end of the time step
+    !
+    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
+       IF ( mx_eau_var(ji) > 0 ) THEN
+          soilwet(ji) = tot_watsoil_end(ji) / mx_eau_var(ji)
+       ELSE
+          soilwet(ji) = zero
+       ENDIF
+    ENDDO
+    !
+  END SUBROUTINE hydrol_alma
+  !
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_calculate_temp_hydro
+!!
+!>\BRIEF         Calculate the temperature at hydrological levels  
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+
+ ! SUBROUTINE hydrol_calculate_temp_hydro(kjpindex, stempdiag, snow,snowdz)
+  SUBROUTINE hydrol_calculate_temp_hydro(kjpindex, stempdiag, snow)
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                             :: kjpindex 
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in)     :: stempdiag
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)          :: snow
+!    REAL(r_std),DIMENSION (kjpindex,nsnow), INTENT (in)    :: snowdz
+
+
+    !! 0.2 Local variables
+    
+    INTEGER jh, jd, ji
+    REAL(r_std) :: snow_h
+    REAL(r_std)  :: lev_diag, prev_diag, lev_prog, prev_prog
+    REAL(r_std), DIMENSION(nslm,nbdl) :: intfactt
+    
+    
+    DO ji=1,kjpindex
+! tzjwb
+!       IF (ok_explicitsnow) THEN 
+          !The snow pack is above the surface soil in the new snow model.
+!          snow_h=0
+!       ELSE  
+          snow_h=snow(ji)/sn_dens
+!       ENDIF
+       
+       intfactt(:,:)=0.
+       prev_diag = snow_h
+       DO jh = 1, nslm
+          IF (jh.EQ.1) THEN
+             lev_diag = zz(2)/1000./2.+snow_h
+          ELSEIF (jh.EQ.nslm) THEN
+             lev_diag = zz(nslm)/1000.+snow_h
+             
+          ELSE
+             lev_diag = zz(jh)/1000. &
+                  & +(zz(jh+1)-zz(jh))/1000./2.+snow_h
+             
+          ENDIF
+          prev_prog = 0.0
+          DO jd = 1, nbdl
+             lev_prog = diaglev(jd)
+             IF ((lev_diag.GT.diaglev(nbdl).AND. &
+                  & prev_diag.LT.diaglev(nbdl)-min_sechiba)) THEN
+                lev_diag=diaglev(nbdl)          
+             ENDIF
+             intfactt(jh,jd) = MAX(MIN(lev_diag,lev_prog)-MAX(prev_diag, prev_prog),&
+                  & 0.0)/(lev_diag-prev_diag)
+             prev_prog = lev_prog
+          ENDDO
+          IF (lev_diag.GT.diaglev(nbdl).AND. &
+               & prev_diag.GE.diaglev(nbdl)-min_sechiba) intfactt(jh,nbdl)=1.
+          prev_diag = lev_diag
+       ENDDO
+    ENDDO
+    
+    temp_hydro(:,:)=0.
+    DO jd= 1, nbdl
+       DO jh= 1, nslm
+          DO ji = 1, kjpindex
+             temp_hydro(ji,jh) = temp_hydro(ji,jh) + stempdiag(ji,jd)*intfactt(jh,jd)
+          ENDDO
+       ENDDO
+    ENDDO
+    
+  END SUBROUTINE hydrol_calculate_temp_hydro
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrol_calculate_frac_hydro_diag
+!!
+!>\BRIEF         Caluculate frac_hydro_diag for interpolation between hydrological and diagnostic axes
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE hydrol_calculate_frac_hydro_diag
+
+    !! 0.1 Local variables
+
+    INTEGER(i_std) :: jd, jh
+    REAL(r_std)    :: prev_hydro, next_hydro, prev_diag, next_diag
+    
+
+    frac_hydro_diag(:,:)=0.
+    prev_diag = 0.0
+    
+    DO jd = 1, nbdl 
+       
+       next_diag = diaglev(jd)
+       prev_hydro = 0.0
+       DO jh = 1, nslm
+          IF (jh.EQ.1) THEN
+             next_hydro = zz(2)/1000./2.
+          ELSEIF (jh.EQ.nslm) THEN
+             next_hydro = zz(nslm)/1000.
+          ELSE
+             next_hydro = zz(jh)/1000.+(zz(jh+1)-zz(jh))/1000./2.
+          ENDIF
+          frac_hydro_diag(jh,jd) = MAX(MIN(next_hydro, next_diag)-MAX(prev_hydro, prev_diag), 0.)/(next_diag - prev_diag)
+          prev_hydro=next_hydro
+       ENDDO
+       
+       prev_diag = next_diag
+    ENDDO
+
+  END SUBROUTINE hydrol_calculate_frac_hydro_diag
+
+  
+END MODULE hydrol
Index: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/hydrolc.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/hydrolc.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/hydrolc.f90	(revision 7236)
@@ -0,0 +1,3641 @@
+! =================================================================================================================================
+! MODULE          : hydrolc
+!
+! CONTACT         : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE         : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF          This module computes the water budget of 
+!! land surfaces. It distinguishes three main reservoirs with separate water budgets : 
+!! the canopy interception reservoir, the snow pack, and the soil, described here using two
+!! soil layers, following the so-called Choisnel scheme. The module contains the  
+!! following subroutines: hydrolc_main, hydrolc_init, hydrolc_clear, hydrolc_var_init, 
+!! hydrolc_snow, hydrolc_vegupd, hydrolc_canop, hydrolc_soil, hydrolc_waterbal, hydrolc_alma, 
+!! hydrolc_hdiff.  
+!!
+!! \n DESCRIPTION : The aim of this module is to update the different water prognostic variables 
+!! (within canopy, snow and soil) and to compute the related liquid water fluxes (e.g. 
+!! throughfall, runoff, snow melt) and diagnostic variables used in other modules (e.g. 
+!! humrel and rsol to compute latent heat fluxes ; shumdiag for soil thermodynamics; snow mass 
+!! and snow age for snow albedo). 
+!! 
+!! The main input variables are precipitation (liquid and solid) and the different terms of 
+!! evapotranspiration (transpiration, bare soil evaporation, interception loss, sublimation). 
+!! The module organizes the required initialisation of water prognostic variables, their
+!! integration at each timestep given the above forcings, and the required output (writing 
+!! of restart file, updated prognostic variables, diagnostic variables). 
+!! 
+!! The specificity of hydrolc in ORCHIDEE is to describe the soil using two soil layers, 
+!! following the so-called Choisnel scheme. The upper layer has a variable depth
+!! and can disappear after dry spells (DucoudrÃ© et al., 1993). Soil moisture stress on 
+!! transpiration and bare soil evaporation acts via the height of dry soil at the top of soil.
+!!
+!! Runoff is produced when the entire soil column is saturated, as in the bucket scheme 
+!! of Manabe (1969). Drainage and surface runoff are only diagnosed,  mostly for use in 
+!! the routing module, using a constant 95% - 5% redistribution (Ngo-Duc et al., 2005).
+!! Irrigation can interact with the soil columns (de Rosnay et al., 2003), as well as 
+!! river discharge in floodplains (Ngo-Duc et al., 2005).
+!!
+!! The dynamic of the one-layer snow pack results from accumulation, sublimation and 
+!! snowmelt. Snow ageing is accounted for but it does not influence snow density.  
+!!
+!! The subgrid variability of soil follows the one of vegetation, by introducing as many 
+!! soil columns as PFTs (de Rosnay & Polcher, 1998). The water budget is performed 
+!! independently in each PFT/soil column, but water can be exchanged laterally. 
+!! The soil moisture of the bottom layer is homogenized between the soil columns at 
+!! each timestep, and a diffusion between the top soil layers can be allowed if the
+!! flag ok_hdiff is true (the default value is false).
+!!
+!! RECENT CHANGE(S) : None 
+!!
+!! REFERENCE(S)     : 
+!!  - DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+!! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+!! Circulation Model. Journal of Climate, 6, pp. 248-273. 
+!!  - Ducharne, A. Laval, K. and Polcher, J. (1998) Sensitivity of the hydrological cycle to the 
+!! parameterization of soil hydrology in a GCM. Climate Dynamics, 14:307-327. 
+!!  - de Rosnay, P. and Polcher J. (1998) Modeling root water uptake in a complex land surface scheme
+!!  coupled to a GCM. Hydrology and Earth System Sciences, 2(2-3):239-256. 
+!!  - de Rosnay, P., Polcher, J., Laval, K. et Sabre, M. (2003). Integrated parameterization of 
+!! irrigation in the land surface model ORCHIDEE. Validation over Indian Peninsula. Geophys. Res.
+!! Lett, 30(19):HLS2-1 -
+!! HLS2-4. 
+!!  - Krinner, G., Viovy, N., de Noblet-DucoudrÃ©, N., Ogee, J., Polcher, J., Friedlingstein, P., 
+!! Ciais, P., Sitch, S. et Prentice, I. (2005). A dynamic global vegetation model for studies of the 
+!! coupled atmosphere-biosphere system. Global Biogeochem. Cycles, 19(1).
+!!  - Ngo-Duc, T., Laval, K., Ramillien, G., Polcher, J. et Cazenave, A. (2007). Validation of the land
+!!  water storage simulated by Organising Carbon and Hydrology in Dynamic Ecosystems (ORCHIDEE) with 
+!! Gravity Recovery and Climate Experiment (GRACE) data. Water Resour. Res, 43:W04427. 
+!!  - ALMA : http://www.lmd.jussieu.fr/~polcher/ALMA/
+!!  - DucoudrÃ©, N. (1990). Sensibilite du climat simule a la parametrisation des echanges de vapeur 
+!! d'eau entre la biosphere et l'atmosphere. These de Doctorat, UniversitÃ© Paris 6. 
+!!  - Ducharne A (1997). Le cycle de l'eau : modelisation de l'hydrologie continentale, etude de ses 
+!! interactions avec le climat, These de Doctorat, UniversitÃ© Paris 6. 
+!!  - de Rosnay, P. (1999). Representation des interactions sol-plante-atmosphere dans le modele de 
+!! circulation generale du LMD. These de doctorat, UniversitÃ© Paris 6. 
+!!  - Guimberteau, M. (2010). Modelisation de l'hydrologie continentale et influences de l'irrigation 
+!! sur le cycle de l'eau, these de doctorat, UniversitÃ© Paris 6. 
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+ 
+MODULE hydrolc
+  
+  ! modules used
+  USE ioipsl
+  USE xios_orchidee
+  USE ioipsl_para 
+  USE constantes        ! contains technical constants
+  USE constantes_soil   ! soil properties and geometry (underground)
+  USE pft_parameters    ! surface and vegetation properties
+  USE sechiba_io        ! for inpout/output
+  USE grid              ! for grid, masks and calendar
+  USE mod_orchidee_para ! for variable and subroutines realted to the parallelism of orchidee
+  USE slowproc 
+
+  IMPLICIT NONE
+
+  ! public routines :
+  ! hydrol
+  PRIVATE
+  PUBLIC :: hydrolc_main,hydrolc_clear 
+
+  
+  LOGICAL, SAVE                             :: l_first_hydrol=.TRUE. !! Initialisation has to be done one time (true/false)
+!$OMP THREADPRIVATE(l_first_hydrol)
+  !
+  LOGICAL, SAVE                                   :: ok_hdiff        !! To do horizontal diffusion between soil columns
+!$OMP THREADPRIVATE(ok_hdiff)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: bqsb            !! Water content in the bottom layer  
+                                                                     !! @tex ($kg m^{-2}$) @endtex 
+!$OMP THREADPRIVATE(bqsb)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: gqsb            !! Water content in the top layer @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(gqsb)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: dsg             !! Depth of the top layer (m) 
+!$OMP THREADPRIVATE(dsg)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: dsp             !! Depth of dry soil in the bottom layer plus depth of top 
+                                                                     !! layer (m)
+!$OMP THREADPRIVATE(dsp)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: mean_bqsb       !! Mean water content in the bottom layer, averaged over the 
+                                                                     !! soil columns @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(mean_bqsb)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: mean_gqsb       !! Mean water content in the top layer, averaged over the   
+                                                                     !! soil columns @tex ($kg m^{-2}$) @endtex 
+!$OMP THREADPRIVATE(mean_gqsb)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: tot_flux        !! Total water flux
+!$OMP THREADPRIVATE(tot_flux)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: tot_water_beg   !! Total amount of water at start of time step 
+                                                                     !! @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(tot_water_beg)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: tot_water_end   !! Total amount of water at end of time step  
+                                                                     !! @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(tot_water_end)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: tot_watveg_beg  !! Total amount of intercepted water on vegetation at start of
+                                                                     !! time step  @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(tot_watveg_beg)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: tot_watveg_end  !! Total amount of intercepted water on vegetation at end of 
+                                                                     !! time step  @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(tot_watveg_end)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: tot_watsoil_beg !! Total amount of water in the soil at start of time step  
+                                                                     !! @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(tot_watsoil_beg)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: tot_watsoil_end !! Total amount of water in the soil at end of time step  
+                                                                     !! @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(tot_watsoil_end)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: snow_beg        !! Total snow water equivalent at start of time step  
+                                                                     !! @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(snow_beg)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: snow_end        !! Total snow water equivalent at end of time step 
+                                                                     !! @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(snow_end)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: delsoilmoist    !! Change in soil moisture during time step 
+                                                                     !! @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(delsoilmoist)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: delintercept    !! Change in interception storage during time step 
+                                                                     !! @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(delintercept)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: delswe          !! Change in snow water equivalent during time step 
+                                                                     !! @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(delswe)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: dss             !! Depth of dry soil at the top, whether in the top or bottom 
+                                                                     !! layer (m) 
+!$OMP THREADPRIVATE(dss)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: hdry            !! Mean top dry soil height (m) version beton
+!$OMP THREADPRIVATE(hdry)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: precisol        !! Throughfall @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(precisol)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: subsnowveg      !! Sublimation of snow on vegetation 
+                                                                     !! @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(subsnowveg)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: subsnownobio    !! Sublimation of snow on other surface types (ice, lakes,...)
+                                                                     !! @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(subsnownobio)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: snowmelt        !! Snow melt @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(snowmelt)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: icemelt         !! Ice melt @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(icemelt)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: gdrainage       !! Drainage between the two soil layers 
+                                                                     !! @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(gdrainage)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: vegtot          !! Total fraction of grid-cell covered by PFTs (bare soil + 
+                                                                     !! vegetation) (0-1, unitless)
+!$OMP THREADPRIVATE(vegtot)  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: resdist         !! Previous values of "veget" (0-1, unitless) ! Last map of 
+                                                                     !! PFT fractions used to define the soil columns 
+!$OMP THREADPRIVATE(resdist)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: mx_eau_var      !! Maximum water content of the soil 
+                                                                     !! @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(mx_eau_var)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: ruu_ch          !! Volumetric soil water capacity @tex ($kg m^{-3}$) @endtex
+!$OMP THREADPRIVATE(ruu_ch)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: runoff          !! Total runoff @tex ($kg m^{-2}$) @endtex
+!$OMP THREADPRIVATE(runoff)
+  REAL(r_std), PARAMETER                          :: dsg_min = 0.001 !! Reference depth to define subgrid variability of saturated
+                                                                     !! top soil layer (m) 
+!_ ================================================================================================================================      
+                                                               
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE            : hydrolc_main 
+!!
+!>\BRIEF                 Main routine for water budget calculation on land surfaces. 
+!!
+!! DESCRIPTION           : This routine drives all the calls pertaining 
+!! to the land-surface water budget. It is called once during the initialisation of 
+!! ORCHIDEE, and then once for each time step, to drive the water budget calculations, 
+!! and the link to history files processing (histwrite). It is called one more time 
+!! at the last time step, for the writing of the restart file. 
+!!
+!! The initialisation step calls hydrolc_init and hydrolc_var_init, plus hydrolc_waterbal 
+!! if we choose to check the water balance. Writing is performed to the restart file, 
+!! before the water budget calculations, at a timestep that is controlled by the flag
+!! "ldrestart_write".
+!!
+!! The water budget calculations are separated into four subroutines related to the 
+!! main three water reservoirs over land grid-cells, and called at each time step : \n
+!!  - hydrolc_snow for snow process (including age of snow)
+!!  - hydrolc_vegupd to manage the required redistribution of water between reservoirs 
+!! when the vegetation fraction of PFTs has changed
+!!  - hydrolc_canop for canopy process (interception)
+!!  - hydrolc_soil for soil hydrological process (soil moisture and runoff), followed by 
+!! hydrolc_hdiff if we choose to account for horizontal diffusion between the soil columns.
+!! If we choose to check the water balance, this is done over each timestep dtradia, 
+!! by hydrolc_waterbal. 
+!!
+!! The link to "hist" files processing has two kinds of controls: 
+!! - the standard output ncdf file corresponds to hist_id ; if hist2_id positive, a second  
+!! ncdf file is output, with a different frequency
+!! - almaoutput defines the nature/name of the written variables, whether following the 
+!! ALMA norm or not
+!! Note that histwrite does different actions depending on the current time step : 
+!! writing on "hist" files at a selected frequency ; summing of the output variables 
+!! in between in view of averaging.
+!! The subroutine also handles some "CMIP5" output (mrro, mrros and prveg).
+!!
+!! We consider that any water on ice (nobio) is snow and we only peform a water balance to have consistency. 
+!! The water balance is limited to + or - \f$10^6\f$ so that accumulation is not endless
+!!
+!! IMPORTANT NOTE : The water fluxes are used in their integrated form, over the time step 
+!! dtradia, with a unit of \f$kg.m^{-2}\f$.
+!!
+!! RECENT CHANGE(S) : None
+!! 
+!! MAIN OUTPUT VARIABLE(S) : snow, snow_age, snow_nobio, snow_nobio_age, tot_melt, 
+!! returnflow, irrigation, humrel, vegstress, rsol, drysoil_frac, shumdiag, litterhumdiag 
+!! + variables declared in the module
+!! + variables sent for ouput by histwrite
+!!
+!! REFERENCE(S) : Same as for module hydrolc
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE hydrolc_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, control_in,&
+     & temp_sol_new, floodout, run_off_tot, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max,&
+     & qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age, tot_melt, transpir, &
+     & precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, vegstress, rsol, drysoil_frac, &
+     & evapot, evapot_corr, flood_frac, flood_res, shumdiag, litterhumdiag, soilcap, rest_id, hist_id, hist2_id)   
+
+  !! 0. Variable and parameter declaration
+
+    !! 0.1  Input variables
+ 
+    INTEGER(i_std), INTENT(in)                              :: kjit             !! Current time step number (unitless)
+    INTEGER(i_std), INTENT(in)                              :: kjpindex         !! Domain size (number of grid cells) (unitless)
+    INTEGER(i_std),INTENT (in)                              :: rest_id,hist_id  !! _Restart_ file and _history_ file identifier 
+                                                                                !! (unitless)
+    INTEGER(i_std),INTENT (in)                              :: hist2_id         !! Second _history_ file identifier (unitless)
+    REAL(r_std), INTENT (in)                                :: dtradia          !! Time step duration (s)  
+    LOGICAL, INTENT(in)                                     :: ldrestart_read   !! Logical to read  _restart_ file (true/false)
+    LOGICAL, INTENT(in)                                     :: ldrestart_write  !! Logical to write  _restart_ file  (true/false)
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)        :: index            !! Indices of the land grid points on the map 
+                                                                                !! (unitless)
+    INTEGER(i_std),DIMENSION (kjpindex*nvm), INTENT (in)    :: indexveg         !! Indices of the PFT tiles / soil columns on 
+                                                                                !! the 3D map (unitless)
+    TYPE(control_type), INTENT (in)                         :: control_in       !! Flags that (de)activate parts of the model
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)           :: precip_rain      !! Rainfall @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)           :: precip_snow      !! Snowfall  @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)           :: returnflow       !! Routed water which comes back into the soil 
+                                                                                !! @tex ($kg m^{-2}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)           :: reinfiltration   !! Routed water which comes back into the soil
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)           :: irrigation       !! Irrigation water applied to soils 
+                                                                                !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)           :: temp_sol_new     !! New soil temperature (K)
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in)    :: frac_nobio       !! Fraction of terrestrial ice, lakes, ... 
+                                                                                !! (0-1, unitless) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)           :: totfrac_nobio    !! Total fraction of terrestrial ice+lakes+...
+                                                                                !! (0-1, unitless) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)           :: soilcap          !! Soil heat capacity @tex ($J K^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)       :: vevapwet         !! Interception loss over each PFT 
+                                                                                !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)       :: veget            !! Grid-cell fraction effectively covered by 
+                                                                                !! vegetation for each PFT, except for soil 
+                                                                                !! (0-1, unitless)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)       :: veget_max        !! PFT fractions within grid-cells: max value of 
+                                                                                !! veget for vegetation PFTs and min value for bare soil (0-1, unitless)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)       :: qsintmax         !! Maximum amount of water in the canopy 
+                                                                                !! interception reservoir 
+                                                                                !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)       :: transpir         !! Transpiration over each PFT 
+                                                                                !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)           :: evapot           !! [DISPENSABLE] Soil Potential Evaporation  
+                                                                                !! @tex ($kg m^{-2}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)           :: evapot_corr      !! [DISPENSABLE] Soil Potential Evaporation 
+                                                                                !! Correction
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)           :: flood_frac       !! Flooded fraction 
+    
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)        :: run_off_tot      !! Diagnosed surface runoff  
+                                                                                !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)        :: flood_res        !! Flood reservoir estimate 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)        :: drainage         !! Diagnosed rainage at the bottom of soil
+                                                                                !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)          :: rsol             !! Resistance to bare soil evaporation 
+                                                                                !! @tex ($s m^{-1}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)          :: drysoil_frac     !! Fraction of visibly dry soil, for bare soil 
+                                                                                !! albedo calculation in condveg.f90 
+                                                                                !! (0-1, unitless) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)          :: litterhumdiag    !! Litter humidity factor (0-1, unitless), used
+                                                                                !! in stomate
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)          :: tot_melt         !! Total melt @tex ($kg m^{-2}$) @endtex
+
+    !! 0.3  Modified variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)        :: vevapnu          !! Bare soil evaporation @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)        :: vevapsno         !! Snow evaporation  @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)        :: vevapflo         !! Floodplains evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)        :: snow             !! Snow water equivalent @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)        :: snow_age         !! Snow age (days)
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (inout) :: snow_nobio       !! Snow water equivalent on nobio areas  
+                                                                                !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (inout) :: snow_nobio_age   !! Snow age on ice, lakes, ...  (days)
+    
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)    :: humrel           !! Soil moisture stress factor on transpiration and
+                                                                                !! bare soil evaporation (0-1, unitless)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)    :: vegstress        !! Vegetation moisture stress (only for vegetation 
+                                                                                !! growth) (0-1, unitless)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)    :: qsintveg         !! Amount of water in the canopy interception 
+                                                                                !! reservoir @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)        :: floodout         !! flux out of floodplains
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (inout)   :: shumdiag         !! Mean relative soil moisture in the different
+                                                                                !! levels used by thermosoil.f90 (0-1, unitless)
+
+    !! 0.4 Local variables
+    
+    REAL(r_std),DIMENSION (kjpindex)                        :: soilwet          !! Temporary diagnostic of relative humidity of 
+                                                                                !! total soil (0-1, unitless)
+    REAL(r_std),DIMENSION (kjpindex)                        :: snowdepth        !! Snow Depth (m)
+    INTEGER(i_std)                                          :: ji,jv            !! Grid-cell and PFT indices (unitless)
+    REAL(r_std), DIMENSION(kjpindex)                        :: histvar          !! Ancillary variable when computations are needed
+                                                                                !! before writing to history files
+    CHARACTER(LEN=80)                                       :: var_name         !! To store variables names for I/O
+
+!_ ================================================================================================================================
+    
+  !! 1.  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, reinfiltration, irrigation, tot_melt, vevapwet, transpir, &
+                & vevapnu, vevapsno, vevapflo, floodout, 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 !  initialisation
+    
+  !! 2. Preparing 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 ! writing restart
+     
+  !! 3. Water budget calculations:
+    
+    !! 3.a snow processes
+    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)
+   
+    !! 3.b canopy processes
+    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 surface reservoir
+    !
+    CALL hydrolc_flood(kjpindex, dtradia, vevapnu, vevapflo, flood_frac, flood_res, floodout)
+   
+    !! 3.c soil hydrology processes
+    CALL hydrolc_soil(kjpindex, vevapnu, precisol, returnflow, reinfiltration, 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, reinfiltration, irrigation, tot_melt, vevapwet, transpir, vevapnu, vevapsno,&
+            & vevapflo, floodout, run_off_tot, drainage )
+    ENDIF
+    
+  !! 4. Output
+    
+    ! If we use the ALMA standards (then 'humrel' is not written)
+    IF (almaoutput) THEN
+       CALL hydrolc_alma(kjpindex, index, .FALSE., qsintveg, snow, snow_nobio, soilwet)
+    ENDIF
+
+    CALL xios_orchidee_send_field("runoff",run_off_tot*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("drainage",drainage*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("rainf",precip_rain*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("snowf",precip_snow*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("rainf_alma",precip_rain/dt_sechiba)
+    CALL xios_orchidee_send_field("snowf_alma",precip_snow/dt_sechiba)
+    CALL xios_orchidee_send_field("dss",dss)
+    CALL xios_orchidee_send_field("bqsb",mean_bqsb)
+    CALL xios_orchidee_send_field("gqsb",mean_gqsb)
+    CALL xios_orchidee_send_field("qsintveg",qsintveg)
+    CALL xios_orchidee_send_field("precisol",precisol*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("floodout",floodout*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("humrel",humrel)     
+    CALL xios_orchidee_send_field("qsintmax",qsintmax)
+    CALL xios_orchidee_send_field("mrros",run_off_tot/dt_sechiba)
+    
+    histvar(:)=run_off_tot(:)+drainage(:)
+    CALL xios_orchidee_send_field("mrro",histvar/dt_sechiba)
+    
+    histvar(:)=(precip_rain(:)-SUM(precisol(:,:),dim=2))
+    CALL xios_orchidee_send_field("prveg",histvar/dt_sechiba)
+    
+    histvar(:)=zero
+    DO jv = 1, nvm
+       DO ji = 1, kjpindex
+          IF ( vegtot(ji) .GT. zero ) THEN
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+             IF (jv .EQ. 1) THEN
+                histvar(ji)=histvar(ji)+tot_bare_soil(ji)/vegtot(ji)*MAX((0.1-dss(ji,jv))*wmax_veg(jv), zero)
+             ELSE
+                histvar(ji)=histvar(ji)+veget(ji,jv)/vegtot(ji)*MAX((0.1-dss(ji,jv))*wmax_veg(jv), zero)
+             ENDIF
+          ENDIF
+       ENDDO
+    ENDDO
+    CALL xios_orchidee_send_field("mrsos",histvar)
+
+    ! Total soil moisture
+    histvar(:)=mean_bqsb(:)+mean_gqsb(:)
+    CALL xios_orchidee_send_field("mrso",histvar)
+    CALL xios_orchidee_send_field("SubSnow",vevapsno/dt_sechiba)
+    CALL xios_orchidee_send_field("SnowDepth",snowdepth)
+    CALL xios_orchidee_send_field("Qs",run_off_tot*0.0005555556)
+    CALL xios_orchidee_send_field("Qsb",drainage*0.0005555556)
+    CALL xios_orchidee_send_field("Qsm",tot_melt/dt_sechiba)
+
+    IF (almaoutput) THEN
+       CALL xios_orchidee_send_field("SoilWet",soilwet)
+       CALL xios_orchidee_send_field("DelSoilMoist",delsoilmoist)
+       CALL xios_orchidee_send_field("DelSWE",delswe)
+       CALL xios_orchidee_send_field("DelIntercept",delintercept)
+       CALL xios_orchidee_send_field("RootMoist",tot_watsoil_end)
+    END IF
+
+
+    IF ( .NOT. almaoutput ) THEN
+       CALL histwrite_p(hist_id, 'dss', kjit, dss, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'bqsb', kjit, mean_bqsb, kjpindex, index)
+       CALL histwrite_p(hist_id, 'gqsb', kjit, mean_gqsb, kjpindex, index)
+       CALL histwrite_p(hist_id, 'runoff', kjit, run_off_tot, kjpindex, index) ! this is surface runoff = 5% of total runoff
+       CALL histwrite_p(hist_id, 'drainage', kjit, drainage, kjpindex, index) ! this 95% of total runoff
+       IF ( control_in%do_floodplains ) THEN
+          CALL histwrite_p(hist_id, 'floodout', kjit, floodout, kjpindex, index)
+       ENDIF
+       CALL histwrite_p(hist_id, 'precisol', kjit, precisol, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'rainf', kjit, precip_rain, kjpindex, index)
+       CALL histwrite_p(hist_id, 'snowf', kjit, precip_snow, kjpindex, index)
+       CALL histwrite_p(hist_id, 'qsintmax', kjit, qsintmax, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'qsintveg', kjit, qsintveg, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'humrel',   kjit, humrel,   kjpindex*nvm, indexveg) ! this the transpiration stress factor
+
+       ! This was originally in the ALMA output but not here.
+       CALL histwrite_p(hist_id, 'snowdepth', kjit, snowdepth, kjpindex, index)
+
+    !! The output for "CMIP5" is handled here, assuming that fluxes in kg m^{-2} s^{-1}
+    !!  But the transformation below on mrro, mrros and prveg lead to fluxes that are 48 times too small !***
+
+       histvar(:)=zero
+       DO jv = 1, nvm
+          DO ji = 1, kjpindex
+
+             IF(veget_max(ji,jv) == zero)THEN
+                ! this vegetation type is not present, so no reason to do the 
+                ! calculation
+                CYCLE
+             ENDIF
+
+             IF ( vegtot(ji) .GT. zero ) THEN
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+                IF (jv .EQ. 1) THEN
+                   histvar(ji)=histvar(ji)+tot_bare_soil(ji)/vegtot(ji)*MAX((0.1-dss(ji,jv))*wmax_veg(jv), zero)
+                ELSE
+                   histvar(ji)=histvar(ji)+veget(ji,jv)/vegtot(ji)*MAX((0.1-dss(ji,jv))*wmax_veg(jv), zero)
+                ENDIF
+             ENDIF
+          ENDDO
+       ENDDO
+       ! this is soil moisture in the top 10 cms
+       CALL histwrite_p(hist_id, 'mrsos', kjit, histvar, kjpindex, index) 
+
+       ! this is total soil moisture
+       histvar(:)=mean_bqsb(:)+mean_gqsb(:)
+       CALL histwrite_p(hist_id, 'mrso', kjit, histvar, kjpindex, index) 
+
+       CALL histwrite_p(hist_id, 'mrros', kjit, run_off_tot, kjpindex, index)
+
+       histvar(:)=run_off_tot(:)+drainage(:)
+       CALL histwrite_p(hist_id, 'mrro', kjit, histvar, kjpindex, index)
+
+       histvar(:)=(precip_rain(:)-SUM(precisol(:,:),dim=2))
+       CALL histwrite_p(hist_id, 'prveg', kjit, histvar, kjpindex, index)
+
+    ELSE 
+       
+       ! almaoutput=true
+       CALL histwrite_p(hist_id, 'Snowf', kjit, precip_snow, kjpindex, index)
+       CALL histwrite_p(hist_id, 'Rainf', kjit, precip_rain, kjpindex, index)
+   
+       ! surface runoff = 5% of total runoff
+       CALL histwrite_p(hist_id, 'Qs', kjit, run_off_tot, kjpindex, index)
+
+       ! drainage = 95% of total runoff
+       CALL histwrite_p(hist_id, 'Qsb', kjit, drainage, kjpindex, index) 
+       CALL histwrite_p(hist_id, 'Qsm', kjit, tot_melt, kjpindex, index)
+       CALL histwrite_p(hist_id, 'DelSoilMoist', kjit, delsoilmoist, kjpindex, index)
+       CALL histwrite_p(hist_id, 'DelSWE', kjit, delswe, kjpindex, index)
+       CALL histwrite_p(hist_id, 'DelIntercept', kjit, delintercept, kjpindex, index)      
+       CALL histwrite_p(hist_id, 'SoilMoist', kjit, tot_watsoil_end, kjpindex, index)
+       CALL histwrite_p(hist_id, 'SoilWet', kjit, soilwet, kjpindex, index)
+       
+       ! this the transpiration stress factor
+       CALL histwrite_p(hist_id, 'humrel',   kjit, humrel,   kjpindex*nvm, indexveg) 
+       
+       CALL histwrite_p(hist_id, 'RootMoist', kjit, tot_watsoil_end, kjpindex, index)
+       CALL histwrite_p(hist_id, 'SubSnow', kjit, vevapsno, kjpindex, index)
+       CALL histwrite_p(hist_id, 'SnowDepth', kjit, snowdepth, kjpindex, index)
+       
+    ENDIF
+    IF ( hist2_id > 0 ) THEN
+       IF ( .NOT. almaoutput ) THEN
+          CALL histwrite_p(hist2_id, 'dss', kjit, dss, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'bqsb', kjit, mean_bqsb, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'gqsb', kjit, mean_gqsb, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'runoff', kjit, run_off_tot, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'drainage', kjit, drainage, kjpindex, index)
+          IF ( control_in%do_floodplains ) THEN
+             CALL histwrite_p(hist2_id, 'floodout', kjit, floodout, kjpindex, index)
+          ENDIF
+          CALL histwrite_p(hist2_id, 'precisol', kjit, precisol, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'rainf', kjit, precip_rain/dt_sechiba, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'snowf', kjit, precip_snow/dt_sechiba, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'qsintmax', kjit, qsintmax, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'qsintveg', kjit, qsintveg, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'humrel',   kjit, humrel,   kjpindex*nvm, indexveg)
+
+          !
+          IF (check_waterbal) THEN
+             CALL histwrite_p(hist2_id, 'TotWater', kjit, tot_water_end, kjpindex, index)
+             CALL histwrite_p(hist2_id, 'TotWaterFlux', kjit, tot_flux, kjpindex, index)
+          ENDIF
+
+          histvar(:)=zero
+          DO jv = 1, nvm
+             DO ji = 1, kjpindex
+
+                IF(veget_max(ji,jv) == zero)THEN
+                   ! this vegetation type is not present, so no reason to do the 
+                   ! calculation
+                   CYCLE
+                ENDIF
+
+                IF ( vegtot(ji) .GT. zero ) THEN
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+                   IF (jv .EQ. 1) THEN
+                      histvar(ji)=histvar(ji)+tot_bare_soil(ji)/vegtot(ji)*MAX((0.1-dss(ji,jv))*wmax_veg(jv), zero)
+                   ELSE
+                      histvar(ji)=histvar(ji)+veget(ji,jv)/vegtot(ji)*MAX((0.1-dss(ji,jv))*wmax_veg(jv), zero)
+                   ENDIF
+                ENDIF
+             ENDDO
+          ENDDO
+          CALL histwrite_p(hist2_id, 'mrsos', kjit, histvar, kjpindex, index)
+
+          histvar(:)=run_off_tot(:)+drainage(:)
+          CALL histwrite_p(hist2_id, 'mrro', kjit, histvar, kjpindex, index)
+
+       ELSE
+          CALL histwrite_p(hist2_id, 'Snowf', kjit, precip_snow, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'Rainf', kjit, precip_rain, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'Qs', kjit, run_off_tot, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'Qsb', kjit, drainage, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'Qsm', kjit, tot_melt, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'DelSoilMoist', kjit, delsoilmoist, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'DelSWE', kjit, delswe, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'DelIntercept', kjit, delintercept, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'SoilMoist', kjit, tot_watsoil_end, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'SoilWet', kjit, soilwet, kjpindex, index)
+          
+          CALL histwrite_p(hist2_id, 'RootMoist', kjit, tot_watsoil_end, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'SubSnow', kjit, vevapsno, kjpindex, index)
+          
+          CALL histwrite_p(hist2_id, 'SnowDepth', kjit, snowdepth, kjpindex, index)
+          
+       ENDIF
+    ENDIF
+
+    IF (long_print) WRITE (numout,*) ' hydrolc_main Done '
+
+  END SUBROUTINE hydrolc_main
+ 
+ 
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrolc_init
+!!
+!>\BRIEF        This routine drives the initialisation of the water budget calculations. 
+!!
+!! DESCRIPTION : The following sequences are performed :
+!!  - Updating flag l_first_hydrol
+!!  - Setting ok_hdiff (default is false) for horizontal diffusion between soil columns
+!!  - Dynamic allocation of arrays that are local to module hydrolc
+!!  - Initializing prognostic variables from input restart file
+!!  - Default attribution is performed in case the model is started without a restart file
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : humrel, vegstress,snow, snow_age, snow_nobio, snow_nobio_age, qsintveg
+!! 
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART11    : None
+!! \n
+!_ ================================================================================================================================  
+  
+  SUBROUTINE hydrolc_init(kjit, ldrestart_read, kjpindex, index, rest_id, veget, humrel, vegstress, &
+       & snow, snow_age, snow_nobio, snow_nobio_age, qsintveg)
+
+  !! 0. Variable and parameter declaration
+
+    !! 0.1  Input variables
+ 
+    INTEGER(i_std), INTENT (in)                          :: kjit                !! Current time step number (unitless)
+    LOGICAL,INTENT (in)                                  :: ldrestart_read      !! Logical to read  _restart_ file (true/false)
+    INTEGER(i_std), INTENT (in)                          :: kjpindex            !! Domain size (number of grid cells) (unitless)
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)     :: index               !! Indices of the land grid points on the map 
+                                                                                !! (unitless)
+    INTEGER(i_std), INTENT (in)                          :: rest_id             !! _Restart_ file identifier (unitless)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: veget               !! Grid-cell fraction effectively covered by 
+                                                                                !! vegetation for each PFT, except for soil 
+                                                                                !! (0-1, unitless) 
+    
+    !! 0.2 Output variables
+    
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)   :: humrel              !! Soil moisture stress factor on transpiration
+                                                                                !! and bare soil evaporation (0-1, unitless)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)   :: vegstress           !! Vegetation moisture stress (only for 
+                                                                                !! vegetation growth) (0-1, unitless)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)       :: snow                !! Snow water equivalent @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)       :: snow_age            !! Snow age (days)
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (out):: snow_nobio          !! Snow water equivalent on nobio areas 
+                                                                                !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (out):: snow_nobio_age      !! Snow age on ice, lakes, ...  (days)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)   :: qsintveg            !! Amount of water in the canopy interception 
+                                                                                !! reservoir @tex ($kg m^{-2}$) @endtex 
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    
+    INTEGER(i_std)                                       :: ier                 !! To receive error flag during allocation
+    INTEGER(i_std)                                       :: ji,jv,ik            !! Indices for grid-cells, PFTs, and grid-cells 
+                                                                                !! (unitless)
+    REAL(r_std), DIMENSION (kjpindex,nvm)                :: zdsp, tmpdss        !! Ancillary variables for initializing dsp 
+                                                                                !! and dss (m)
+    REAL(r_std), ALLOCATABLE, DIMENSION (:,:)            :: dsp_g               !! Ancillary variable for initializing dsp (m)
+                                                                                !! dss (m)   
+    REAL(r_std), DIMENSION(kjpindex)                     :: a_subgrd            !! Diagnosed subgrid fraction of saturated soil in
+                                                                                !! the top layer, to calculate hdry (0-1, unitless)
+    CHARACTER(LEN=80)                                    :: var_name            !! To store variables names for I/O
+!_ ================================================================================================================================
+
+  !! 1. Make sure initialization happens only once (l_first_hydrol becomes false)
+    
+    IF (l_first_hydrol) THEN 
+        l_first_hydrol=.FALSE.
+    ELSE 
+        WRITE (numout,*) ' l_first_hydrol false . we stop '
+        STOP 'hydrolc_init'
+    ENDIF
+    
+  !! 2. Setting ok_hdiff for horizontal diffusion between soil columns
+
+    !Config Key   = HYDROL_OK_HDIFF
+    !Config Desc  = do horizontal diffusion?
+    !Config If    = OK_SECHIBA and .NOT.(HYDROL_CWRR)  
+    !Config Def   = n
+    !Config Help  = If TRUE, then water can diffuse horizontally between
+    !Config         the PFTs' water reservoirs.
+    !Config Units = [FLAG]
+    ok_hdiff = .FALSE.
+    CALL getin_p('HYDROL_OK_HDIFF',ok_hdiff) 
+
+  !! 3. Make dynamic allocation with the good dimensions
+
+    ! 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
+
+       ALLOCATE (tot_flux(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in tot_flux 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 '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
+
+  !!  4. Initialization of hydrologic variables:
+
+    !! 4.a Read data from restart input file (opened by sechiba_init)
+    !! for HYDROLOGIC processes
+    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_p('UNITS', 'kg/m^2')
+        CALL ioconf_setatt_p('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_p('UNITS', 'd')
+        CALL ioconf_setatt_p('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_p('UNITS', 'kg/m^2')
+        CALL ioconf_setatt_p('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_p('UNITS', 'd')
+        CALL ioconf_setatt_p('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_p('UNITS', '-')
+        CALL ioconf_setatt_p('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_p('UNITS', '-')
+        CALL ioconf_setatt_p('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_p('UNITS', 'kg/m^2')
+        CALL ioconf_setatt_p('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_p('UNITS', 'kg/m^2')
+        CALL ioconf_setatt_p('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_p('UNITS', 'm')
+        CALL ioconf_setatt_p('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_p('UNITS', 'm')
+        CALL ioconf_setatt_p('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_p('UNITS', 'm')
+        CALL ioconf_setatt_p('LONG_NAME','Hauteur au dessus du reservoir de surface')
+        CALL restget_p (rest_id, var_name, nbp_glo, nvm  , 1, kjit, .TRUE., dss, "gather", nbp_glo, index_g)
+                
+        var_name= 'hdry'
+        CALL ioconf_setatt_p('UNITS', 'm')
+        CALL ioconf_setatt_p('LONG_NAME','Dry soil heigth in meters')
+        CALL restget_p (rest_id, var_name, nbp_glo, 1 , 1, kjit, .TRUE., hdry, "gather", nbp_glo, index_g)
+                
+        var_name= 'qsintveg'
+        CALL ioconf_setatt_p('UNITS', 'kg/m^2')
+        CALL ioconf_setatt_p('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_p('UNITS', '-')
+        CALL ioconf_setatt_p('LONG_NAME','Distribution of reservoirs')
+        CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., resdist, "gather", nbp_glo, index_g)
+        
+        !! 4.b Assign default values if non were found in the restart file
+        !Config Key   = HYDROL_SNOW
+        !Config Desc  = Initial snow mass if not found in restart
+        !Config If    = OK_SECHIBA
+        !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.
+        !Config Units = [kg/m^2]
+        CALL setvar_p (snow, val_exp, 'HYDROL_SNOW', zero)
+        
+        !Config Key   = HYDROL_SNOWAGE
+        !Config Desc  = Initial snow age if not found in restart
+        !Config If    = OK_SECHIBA 
+        !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.
+        !Config Units = [days]
+        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 If    = OK_SECHIBA 
+        !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.
+        !Config Units = [m]
+        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 If    = OK_SECHIBA 
+        !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.
+        !Config Units = [days]
+        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 If    = OK_SECHIBA 
+        !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.
+        !Config Units = [-]
+        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 If    = OK_SECHIBA 
+        !Config Def   = 999999. 
+        !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.
+        !Config Units = [kg/m^2]
+        CALL setvar_p (bqsb, val_exp, 'HYDROL_BQSB', wmax_veg*dpu_max)
+        
+        !Config Key   = HYDROL_GQSB
+        !Config Desc  = Initial upper soil moisture if not found in restart
+        !Config If    = OK_SECHIBA 
+        !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.
+        !Config Units = [kg/m^2]
+        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 If    = OK_SECHIBA 
+        !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.
+        !Config Units = [m]
+        CALL setvar_p (dsg, val_exp, 'HYDROL_DSG', zero)
+        
+        !Config Key   = HYDROL_QSV
+        !Config Desc  = Initial water on canopy if not found in restart
+        !Config If    = OK_SECHIBA 
+        !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. 
+        !Config Units = [kg/m^2]
+        CALL setvar_p (qsintveg, val_exp, 'HYDROL_QSV', zero)
+        
+        !! 4.c Specific calculations to define default values for dry soil depths : dsp, dss, and hdry
+        ! 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 If    = OK_SECHIBA 
+        !Config Def   = 999999.
+        !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.
+        !Config Units = [m]
+        !
+        ! Calculate temporary variable to use for initialiaion of dsp.
+        ! This variable will only be used if no value is set in run.def
+	DO jv = 1,nvm
+           zdsp(:,jv) = dpu_max - bqsb(:,jv) / wmax_veg(jv)
+        END DO
+
+        CALL setvar_p(dsp, val_exp, 'HYDROL_DSP', zdsp) 
+
+        ! set inital value for dss 
+        DO jv = 1,nvm
+           tmpdss(:,jv) = dsg(:,jv) - gqsb(:,jv) / wmax_veg(jv)
+        END DO
+        
+        ! Initialize dss if it is not found in restart file
+        IF ( ALL( dss(:,:) == val_exp ) ) THEN
+           dss(:,:)=tmpdss(:,:)
+        END IF
+                
+        ! set inital value for hdry if not found in restart file
+        ! see hydrolc_soil, step 8.4
+        IF ( ALL( hdry(:) == 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) + (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
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+            resdist(:,1) = tot_bare_soil(:)
+            resdist(:,2:nvm) = veget(:,2:nvm)
+        ENDIF
+        
+        !! 4.d Compute vegtot (remember that it is only frac_nobio + SUM(veget(,:)) that is equal to 1)
+        DO ji = 1, kjpindex
+           vegtot(ji) = SUM(veget(ji,2:nvm)) + tot_bare_soil(ji)
+        ENDDO
+        
+    ENDIF ! IF (ldrestart_read)
+    
+  !! 5. Where vegetation fraction is zero, set moisture variables to those 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
+    
+  !! 6. We limit the initial value of snow water equivalent 
+    
+    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
+!!
+!>\BRIEF        Deallocates arrays that were allocated in hydrolc_init and hydrolc_var_init. 
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGES : None
+!! 
+!! MAIN OUTPUT VARIABLE(S) : None
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!!\n
+!_ ================================================================================================================================
+  
+  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_flux)) DEALLOCATE (tot_flux)
+    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
+ 
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrolc_var_init
+!!
+!>\BRIEF        This routine initializes diagnostic hydrologic variables.
+!!
+!! DESCRIPTION  : The following variables are assigned :
+!!  - Soil characteristics : soil water capacities mx_eau_var and ruu_ch \f$(kg m^{-2})\f$ and \f$(kg m^{-3})\f$
+!!  - Initial values for diagnostic variables : mean_bqsb, mean_gqsb, mean_dsg, shumdiag, drysoil_frac, rsol, litterhumdiag
+!! 
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : rsol, drysoil_frac, mx_eau_var, ruu_ch, shumdiag, litterhumdiag
+!! 
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================  
+
+  SUBROUTINE hydrolc_var_init (kjpindex, veget, veget_max, rsol, drysoil_frac, mx_eau_var, ruu_ch, shumdiag, litterhumdiag)
+
+  !! 0. Variable and parameter declaration
+
+    !! 0.1  Input variables 
+
+    INTEGER(i_std), INTENT(in)                         :: kjpindex      !! Domain size (number of grid cells) (unitless)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget         !! Grid-cell fraction effectively covered by vegetation for
+                                                                        !! each PFT, except for soil (0-1, unitless) 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget_max     !! PFT fractions within grid-cells: max value of veget for 
+                                                                        !! vegetation PFTs and min value for bare soil (0-1, 
+                                                                        !! unitless) 
+    
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: rsol          !! Resistance to bare soil evaporation 
+                                                                        !! @tex ($s m^{-1}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: drysoil_frac  !! Fraction of visible dry soil  (0-1, unitless) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: mx_eau_var    !! Maximum water content of the soil 
+                                                                        !! @tex ($kg m^{-2}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: ruu_ch        !! Volumetric soil water capacity 
+                                                                        !! @tex ($kg m^{-3}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out):: shumdiag      !! Mean relative soil moisture, diagnosed for 
+                                                                        !! thermosoil.f90 (0-1, unitless) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: litterhumdiag !! Litter humidity factor (0-1, unitless), used in stomate
+    
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                     :: ji,jv, jd     !! Indices for grid-cells, PFTs and diagnostic levels in 
+                                                                        !! the soil (unitless)
+    REAL(r_std), DIMENSION(kjpindex)                   :: mean_dsg      !! Mean Depth of the top layer, averaged over the soil 
+                                                                        !! columns (m)
+    REAL(r_std)                                        :: gtr, btr      !! Ancillary variables to compute shumdiag (0-1, unitless) 
+    REAL(r_std), DIMENSION(nbdl+1)                     :: tmp_dl        !! Temporary diagnostic levels in the soil (m)
+!_ ================================================================================================================================
+
+  !! 1. Vertical diagnostic levels to compute shumdiag (relative moisture for thermosoil)
+    
+    tmp_dl(1) = 0
+    tmp_dl(2:nbdl+1) = diaglev(1:nbdl)
+    
+  !! 2. Calculation of mx_eau_var and ruu_ch (soil water capacities)
+     
+    mx_eau_var(:) = zero
+    
+    DO ji = 1,kjpindex
+      DO jv = 1,nvm
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+         IF (jv .EQ. 1) THEN
+            mx_eau_var(ji) = mx_eau_var(ji) + tot_bare_soil(ji)*wmax_veg(jv)*dpu_max
+         ELSE
+            mx_eau_var(ji) = mx_eau_var(ji) + veget(ji,jv)*wmax_veg(jv)*dpu_max
+         ENDIF
+      END DO
+      IF (vegtot(ji) .GT. zero) THEN
+         mx_eau_var(ji) = mx_eau_var(ji)/vegtot(ji)
+      ELSE
+         ! lakes, ice, cities...
+         mx_eau_var(ji) = mx_eau_nobio*dpu_max
+      ENDIF
+      ruu_ch(ji) = mx_eau_var(ji) / dpu_max
+    END DO
+    
+  !! 3. Initial values of the mean soil layer depths and water contents
+    
+    ! 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
+    
+    !! 4. Initial value of shumdiag (see hydrolc_soil, 8.2 for details)
+
+    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
+
+  !! 5. Initial value of the fraction of soil which is visibly dry (see hydrolc_soil, 8.3 for details)
+    
+    drysoil_frac(:) = MIN(MAX(dss(:,1),zero)*10._r_std, un)
+    
+  !! 6. Initial value of the resistance to bare soil evaporation (see hydrolc_soil, 8.4 for details)
+    
+    rsol(:) = -un
+    DO ji = 1, kjpindex
+       IF (tot_bare_soil(ji) .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_max - drysoil_frac(ji))+1.e-10)**2 ) * rsol_cste
+          rsol(ji) =  ( hdry(ji) + un/(10.*(dpu_max - hdry(ji))+1.e-10)**2 ) * rsol_cste
+       ENDIF
+    ENDDO
+    
+  !! 7. Initial value of litter humidity (see hydrolc_soil, 8.5 for details)
+    
+    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_var_init done '
+
+  END SUBROUTINE hydrolc_var_init
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrolc_snow
+!!
+!>\BRIEF        This routine computes accumulation, sublimation, snowmelt and snow ageing 
+!! over vegetated and nobio (eg land-ice) areas. Snowdepth is then updated.
+!! 
+!! DESCRIPTION  : In this routine the snow-related processes accumulation, sublimation, 
+!! melting and ageing are computed separately on vegetated and nobio areas. This subroutine 
+!! is the first one among the ones that compute the physical processes. The water budgets 
+!! of the interception reservoir and the soil are performed afterwards.\n
+!!
+!! - Values of the main parameters used in this routine are :\n
+!! tp_00=273.15K : freezing point\n
+!! snowcri=1.5\f$kg m^{-2}\f$ : critical snowmass for sublimation\n
+!! sneige=snowcri/1000._r_std : critical snowmass for snow melt\n
+!! maxmass_glacier=3000 \f$kg m^{-2}\f$ (~ 10m snow) : critical snowmass for glaciers\n
+!! snow_trans=0.3 (\f$kg m^{-2}\f$) : critical constant for snow ageing\n
+!! max_snow_age=50 (days) : maximum snow age\n
+!! sn_dens=330 (\f$kg m^{-3}\f$) : snow density\n
+!! one_day=86400 (s) : one day, expressed in seconds...
+!!
+!! - Accumulation\n
+!! On the vegetated areas, the snow mass increases due to area-weighted snow
+!! precipitations precip_snow; on nobio areas, rain additionnaly converts into snow.\n
+!!
+!! - Sublimation\n
+!! Sublimation on vegetated and nobio areas is calculated as the area-weighed fraction
+!! of vevapsno (from enerbil). In case snow on vegetated areas is limited (less than snowcri) 
+!! and a significant nobio area exists, the nobio area accomodates the whole sublimation 
+!! vevapsno. The nobio area also accomodates the possible excess sublimation from vegetated 
+!! areas, which otherwise goes into bare soil evaporation. In this case vevapsno is updated.\n
+!!
+!! - Melting\n
+!! Over vegetated and nobio areas, snowmelt occurs if the calculated soil temperature 
+!! temp_soil_new(ji) exceeds the freezing point tp_00. The energy required to warm up the soil
+!! surface above tp_00 is converted into melting, according to the following equation :
+!! \latexonly
+!! \input{hydrolcsnow1.tex}
+!! \endlatexonly
+!! \n
+!! with soilcap the soil heat capacity @tex ($J K^{-1}$) @endtex and chalfu0 the latent heat of
+!! fusion.\n
+!! A special case occurs in areas with snowmass exceeding maxmass_glacier, where
+!! all the snow in excess of maxmass_glacier adds to the total melting tot_melt.
+!! This excess melting is considered as additionnal snowmelt for vegetated areas
+!! and as ice_melt for nobio areas.\n
+!!
+!! - Ageing\n
+!! Over vegetated areas, during the time step dt_radia (usually 1800 s), the snow age is 
+!! incremented by a d_age calculated as follow:
+!! \latexonly
+!! \input{hydrolcsnow2.tex}
+!! \endlatexonly
+!! \n
+!! Over nobio areas and at subfreezing temperatures, snow ageing is limited by very 
+!! slow snow metamorphism, hence d_age is reduced as follow:
+!! \latexonly
+!! \input{hydrolcsnow3.tex}
+!! \endlatexonly
+!! \n
+!! Scientific reference for this parametrization choice is obviously missing !
+!! At the end of the routine the snowheight is diagnosed using the fixed
+!! snow density sn_dens.
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLES:
+!! for vegetated and nobio areas respectively:\n
+!! snow(kjpindex) and snow_nobio(kjpindex)\n
+!! snow_age(kjpindex) and snow_nobio_age(kjpindex)\n
+!! for the whole grid-cell:\n
+!! vevapnu(kjpindex)
+!! vevapsno(kjpindex)
+!! tot_melt(kjpindex)
+!! snowdepth(kjpindex)
+!!   
+!! REFERENCES : None
+!! 
+!! FLOWCHART  : None
+!! \n
+!_ ================================================================================================================================
+
+  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)
+
+  !! 0. Variable and parameter declaration
+
+    !! 0.1  Input variabless
+ 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex        !! Domain size  (unitless)
+    REAL(r_std), INTENT (in)                                 :: dtradia         !! Time step of the simulations for sechiba (s) 
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: precip_rain     !! Rainfall @tex ($kg m^{-2}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: precip_snow     !! Snow precipitation @tex ($kg m^{-2}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: temp_sol_new    !! New soil temperature (K)
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: soilcap         !! Soil heat capacity @tex ($J K^{-1}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(in)     :: frac_nobio      !! Fraction of continental ice, lakes, ... 
+                                                                                !! (unitless)
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: totfrac_nobio   !! Total fraction of continental ice+lakes+ ... 
+                                                                                !! (unitless)
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: tot_melt        !! Total melt @tex ($kg m^{-2}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: snowdepth       !! Snow depth (m)
+    
+    !! 0.3  Modified variables
+
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: vevapnu         !! Bare soil evaporation @tex ($kg m^{-2}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: vevapsno        !! Snow evaporation @tex ($kg m^{-2}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: snow            !! Snow mass @tex ($kg m^{-2}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: snow_age        !! Snow age (days)
+    REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(inout)  :: snow_nobio      !! Snomass on nobio areas 
+                                                                                !! @tex ($kg m^{-2}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(inout)  :: snow_nobio_age  !! Snow age on ice, lakes, ...(days)
+    
+    !! 0.4 Local variables
+    
+    INTEGER(i_std)                                           :: ji, jv          !! indices (unitless)
+    REAL(r_std), DIMENSION (kjpindex)                        :: d_age           !! Snow age change (days)
+    REAL(r_std), DIMENSION (kjpindex)                        :: xx              !! temporary
+    REAL(r_std)                                              :: snowmelt_tmp    !! temporary @tex ($kg m^{-2}$) @endtex
+    LOGICAL, DIMENSION (kjpindex)                            :: warnings 
+    LOGICAL                                                  :: any_warning
+!_ ================================================================================================================================
+    
+  !! 1. 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
+  
+  !! 2. On vegetation
+        
+    ! 2.1. It is snowing 
+    DO ji=1,kjpindex
+      snow(ji) = snow(ji) + (un - totfrac_nobio(ji))*precip_snow(ji)
+    ENDDO
+
+    DO ji=1,kjpindex
+      
+      ! 2.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.
+    DO ji=1,kjpindex
+      
+      ! 2.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.
+    DO ji=1,kjpindex
+      
+      ! 2.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 
+            
+            ! 2.3.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 
+            
+            ! 2.3.2 not enough snow
+            snowmelt(ji) = snow(ji)
+            snow(ji) = zero
+         ELSE 
+            
+            ! 2.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
+      
+      !! 2.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
+    
+   !! 3. On Land ice
+    
+    DO ji=1,kjpindex
+      
+      !! 3.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)
+      
+      !! 3.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)
+      
+      !! 3.3. snow melt only for continental ice fraction
+      snowmelt_tmp = zero
+      IF (temp_sol_new(ji) .GT. tp_00) THEN 
+         
+         ! 3.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
+      
+      !! 3.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
+
+    
+  !! 4. 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_p (3,'hydrolc_snow', '', &
+ &         'CANNOT TREAT SNOW ON THESE SURFACE TYPES', '')
+    ENDIF
+
+    
+  !! 5. computes total melt (snow and ice)
+ 
+
+    DO ji = 1, kjpindex
+      tot_melt(ji) = icemelt(ji) + snowmelt(ji)
+    ENDDO
+ 
+  !! 6. computes snow age on veg and ice (for albedo)
+    
+    DO ji = 1, kjpindex
+      
+      !! 6.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
+      
+      !! 6.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
+
+  !! 7. 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
+
+
+
+!! ================================================================================================================================
+!! SUBROUTINE      : hydrolc_canop 
+!!
+!>\BRIEF           This routine computes the water budget of the canopy interception reservoir. 
+!!
+!! DESCRIPTION     : The first sequence is to withdraw interception loss from the interception 
+!! reservoir, with independent values for each PFT. The reservoir loading happens afterwards. 
+!! Rain falls uniformly over the PFTs. It uniformly loads the canopy interception 
+!! reservoir of each PFT, up to the interception capacity, but a fraction of rainfall always falls to the ground.
+!! Throughfall is thus comprised of the fraction that always falls through, plus the remining fraction of rainfall that 
+!! exceeds the interception capacity, the interception loss having been removed. 
+!! \latexonly
+!! \input{interception.tex}
+!! \endlatexonly
+!! 
+!! IMPORTANT NOTE : Bare soil treatment is complex in hydrolc :
+!!  - veget_max(:,1) is the fraction of bare soil from the "annual" vegetation map 
+!!  - veget(:,1) is not the fraction of vegetation over bare soil but the total fraction of bare soil in the grid-cell 
+!! (including the bare soil fractions over the vegetation PFTs). 
+!! *** A diagram should be added in the spatial entry of the "umbrella"
+!!  - For interception to be zero on bare soil, we thus need to impose qsintmax(:,1)=0
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : precisol (throughfall), qsintveg (amount of water in the canopy interception reservoir)
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================  
+
+  SUBROUTINE hydrolc_canop (kjpindex, precip_rain, vevapwet, veget, qsintmax, qsintveg, precisol)
+
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                           :: kjpindex           !! Domain size (number of grid cells) (unitless)
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)        :: precip_rain        !! Rainfall @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)    :: vevapwet           !! Interception loss over each PFT 
+                                                                               !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)    :: veget              !! Grid-cell fraction effectively covered by 
+                                                                               !! vegetation for each PFT, except for soil 
+                                                                               !! (0-1, unitless) 
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)    :: qsintmax           !! Maximum amount of water in the canopy 
+                                                                               !! interception reservoir @tex ($kg m^{-2}$) @endtex 
+    
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(out)   :: precisol           !! Throughfall @tex ($kg m^{-2}$) @endtex
+
+    !! 0.3  Modified variables
+
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: qsintveg           !! Amount of water in the canopy interception 
+                                                                               !! reservoir @tex ($kg m^{-2}$) @endtex
+    
+    !! 0.4 Local variabless
+  
+    INTEGER(i_std)                                       :: ji, jv             !! Grid-cell and PFT indices (unitless)
+    REAL(r_std), DIMENSION (kjpindex,nvm)                :: zqsintvegnew       !! Temporary variable for intercepted water 
+                                                                               !! amount  @tex ($kg m^{-2}$) @endtex 
+
+!_ ================================================================================================================================
+
+    ! 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(:)
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+       IF (jv .EQ. 1) THEN
+          qsintveg(:,jv) = qsintveg(:,jv) + tot_bare_soil(:) * ((1-throughfall_by_pft(jv))*precip_rain(:))
+       ELSE
+          qsintveg(:,jv) = qsintveg(:,jv) + veget(:,jv) * ((1-throughfall_by_pft(jv))*precip_rain(:))
+       ENDIF
+    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)
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+        IF (jv .EQ. 1) THEN
+           precisol(ji,jv) = (tot_bare_soil(ji)*throughfall_by_pft(jv)*precip_rain(ji)) + qsintveg(ji,jv ) - zqsintvegnew (ji,jv)
+        ELSE
+           precisol(ji,jv) = (veget(ji,jv)*throughfall_by_pft(jv)*precip_rain(ji)) + qsintveg(ji,jv ) - zqsintvegnew (ji,jv)
+        ENDIF
+      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 
+!!
+!>\BRIEF        This subroutines works at adapting the distribution of water
+!! in the soil and interception reservoirs between the different soil columns when the vegetation 
+!! fraction of the PFTs (veget) has changed in slowproc.  
+!!
+!! DESCRIPTION  : Different vegetation changes are allowed in ORCHIDEE:\n 
+!!  - veget_max can be updated annually in slowproc (dynamic vegetation or prescribed vegetation change)\n
+!!  - veget can be updated daily in slowproc (because of changes in veget_max or depending on LAI)
+!!
+!! This subroutine aims at adapting the distribution of water among the different liquid water reservoirs 
+!! (interception reservoir and soil moisture) after these changes of veget :
+!! - the variable veget holds the "new" vegetation map
+!! - the variable resdist holds the previous vegetation map 
+!! *** I see no flag or time step dependance to control the call to vegupd : is it called at each time step ?
+!!
+!! The principle is that PFTs where "veget" has shrunk keep the same water contents in kg.m^{-2},
+!! whereas the water contents are increased in PFTs where "veget" has grown.
+!! *** I still have questions about redistribution to interception reservoirs which have shrunk
+!! *** and about thresholding to the reservoirs' capacities (is it ensured that the capacities are not exceeded ?)
+!! 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.
+!! 
+!! IMPORTANT NOTE : the definition of veget is not simple :
+!!  - for the non-bare soil PFTs (iv > 2), veget is the fraction effectively covered by 
+!! vegetation : veget \f$\le\f$ veget_max\n
+!!  - for the bare soil PFT (iv=1), veget holds the fraction of bare soil, from all 
+!! PFTs : veget(:,1) \f$\ge\f$ veget_max(:,1)\n
+!!
+!! RECENT CHANGE(S) : None
+!! 
+!! MAIN OUTPUT VARIABLE(S) : qsintveg, gqsb, bqsb, dsg, dss, dsp, resdist
+!! 
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART   : None
+!! \n
+!_ ================================================================================================================================  
+  
+  SUBROUTINE hydrolc_vegupd(kjpindex, veget, ruu_ch, qsintveg, gqsb, bqsb, dsg, dss, dsp, resdist)
+    
+  !! 0. Variable and parameter declaration
+
+    !! 0.1  Input variables
+ 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex   !! Domain size (number of grid cells) (unitless)
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(in)       :: veget      !! Grid-cell fraction effectively covered by vegetation 
+                                                                           !! for each PFT, except for soil (0-1, unitless)
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: ruu_ch     !! Volumetric soil water capacity 
+                                                                           !! @tex ($kg m^{-3}$) @endtex
+    
+    !! 0.2 Output variables
+
+    !! 0.3  Modified variables
+
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)  :: qsintveg      !! Water on vegetation due to interception
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: gqsb       !! Water content in the top layer 
+                                                                           !! @tex ($kg m^{-2}$) @endtex    
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: bqsb       !! Water content in the bottom layer 
+                                                                           !! @tex ($kg m^{-2}$) @endtex     
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: dsg        !! Depth of the top layer (m)   
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: dss        !! Depth of dry soil at the top, whether in the top or
+                                                                           !! bottom layer (m)   
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: dsp        !! Depth of dry soil in the bottom layer plus depth of
+                                                                           !! top layer (m) 
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(inout)    :: resdist    !! Previous values of "veget" (0-1, unitless)
+    
+    !! 0.4 Local variables
+    
+    INTEGER(i_std)                                :: ji,jv                 !!  Grid-cell and PFT indices (unitless)
+    REAL(r_std),DIMENSION (kjpindex,nvm)           :: qsintveg2            !! Ancillary qsintveg @tex ($kg m^{-2}$) @endtex  
+    REAL(r_std), DIMENSION (kjpindex,nvm)          :: bdq, gdq             !! Changes in surface and bottom soil layer water 
+                                                                           !! content @tex ($kg m^{-2}; positive$) @endtex
+    REAL(r_std), DIMENSION (kjpindex,nvm)          :: qsdq                 !! Changes in interception reservoir water content  
+                                                                           !! @tex ($kg m^{-2}; positive$) @endtex
+    REAL(r_std), DIMENSION (kjpindex,nvm)          :: vmr                  !! Variation of "veget" since previous values 
+                                                                           !! (-1,1; unitless)
+    REAL(r_std), DIMENSION(kjpindex)               :: gtr                  !! Total water mass to redistribute between the top 
+                                                                           !! layers of a grid-cell @tex ($kg m^{-2}; positive) 
+                                                                           !! @ endtex
+    REAL(r_std), DIMENSION(kjpindex)               :: btr                  !! Total water mass to redistribute between the bottom
+                                                                           !! layers of a grid-cell @tex ($kg m^{-2}; positive) 
+                                                                           !! @ endtex
+    REAL(r_std), DIMENSION(kjpindex)               :: vtr                  !! Total fraction  over which "veget" has decreased 
+                                                                           !! (dimensionless; positive)
+    REAL(r_std), DIMENSION(kjpindex)               :: qstr                 !! Total water mass to redistribute between the 
+                                                                           !! interception reservoirs of a grid-cell 
+                                                                           !! @tex ($kg m^{-2}; positive$) @endtex
+    REAL(r_std), DIMENSION(kjpindex)               :: fra                  !! Weight for redistribution (dimensionless; negative)
+    REAL(r_std), DIMENSION(kjpindex) :: vegchtot                           !! Total change of "veget" in the grid-point 
+                                                                           !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std), PARAMETER                         :: EPS1 = EPSILON(un)   !! Very small (scalar) *** why not use min_sechiba ?
+!_ ================================================================================================================================ 
+    
+  !! 1. vmr is the change in veget in the different PFTs
+
+    ! vmr is the change in veget in the different PFTs
+    ! (dimensionless; negative if the new "veget" is smaller, i.e. if the PFT has shrunk)
+    ! By construction, the algebraic sum of vmr in a grid-cell is zero
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+         IF (jv .EQ. 1) THEN 
+            IF ( ABS(tot_bare_soil(ji)-resdist(ji,jv)) .GT. EPS1 ) THEN
+               vmr(ji,jv) = tot_bare_soil(ji)-resdist(ji,jv)
+            ELSE
+               vmr(ji,jv) = zero
+            ENDIF
+         ELSE
+            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
+         ENDIF
+  !! 2. qsintveg2 is the intercepted water in mm 
+
+        ! qsintveg2 is the intercepted water in mmif the total volume 
+        ! was redistributed over the previous "veget" fractions 
+        ! This the distribution of intercepted water that needs to be 
+        ! changed if "veget" changes 
+
+         IF (resdist(ji,jv) .GT. zero) THEN
+            qsintveg2(ji,jv) = qsintveg(ji,jv)/resdist(ji,jv)
+         ELSE
+            qsintveg2(ji,jv) = zero
+         ENDIF
+      ENDDO
+    ENDDO
+
+
+ !! 3. vegchtot is the total change of "veget" in the grid-points
+
+    ! vegchtot is the total change of "veget" in the grid-points, 
+    ! integrated over the PFTs (vegchtot in kg m^{-2})
+    ! It is the sum of the absolute values of changes, it may thus 
+    ! be larger than 1 : it serves as a flag of change in each grid-point
+    vegchtot(:) = zero
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+        vegchtot(ji) = vegchtot(ji) + ABS( vmr(ji,jv) )
+      ENDDO
+    ENDDO
+    
+
+  !! 4. In the grid-points with "veget" change, we define changes in water content
+    
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+        IF ( vegchtot(ji) .GT. zero ) THEN
+
+           ! change in surface soil layer water content @tex ($kg m^{-2}$) @endtex
+          gdq(ji,jv) = ABS(vmr(ji,jv)) * gqsb(ji,jv)
+
+          ! change in bottom soil layer water content @tex ($kg m^{-2}$) @endtex
+          bdq(ji,jv) = ABS(vmr(ji,jv)) * bqsb(ji,jv)
+
+          ! change in interception reservoir water content  @tex ($kg m^{-2}$) @endtex
+          qsdq(ji,jv) = ABS(vmr(ji,jv)) * qsintveg2(ji,jv)
+        ENDIF
+      ENDDO
+    ENDDO
+
+  !! 5. Total water mass to redistribute in a grid-point = sum of water changes from PFTs where "veget" decreases
+
+    !  Calculate the total water mass that we need to redistribute by grid-point, for each water reservoir
+    !  We sum up the water changes from PFTs where "veget" decreases : this is the water that needs to be redistributed
+    !  vtr is the total fraction  over which "veget" has decreased (> 0)
+    !  By construction, it is balanced by the total fraction where "veget" has increased
+
+    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 is necessarily le 0 since we enter here only if vmr <0
+          vtr(ji) = vtr(ji) - vmr(ji,jv)
+        ENDIF
+      ENDDO
+    ENDDO
+   
+
+!! 6. Put the water to redistribute from the PFTs that "shrank" into the PFTs that "growed"
+
+    !     In doing so, water contents are kept constant in PFTs that shrank, and they increase in PFTs that growed
+    !     fra is the weight for that redistribution, scaled to vtr which is the total amount to redistribute 
+    !  *** Feasability of the redistribution : it doesn't seem to be checked ???
+    !  *** In the soil, if the water capacities are constant between PFTs, it's OK ;this is the default for wmax_veg in 
+    !  *** constantes_veg.f90
+    !  *** But qsintmax is different between PFTsand also evolves in time : how is this managed ???
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+
+        ! "veget" changed
+        IF ( vegchtot(ji) .GT. zero .AND. ABS(vtr(ji)) .GT. EPS1) THEN
+
+            ! negative when vmr positive, thus in the condition below 
+            fra(ji) = vmr(ji,jv) / vtr(ji)
+
+            ! the PFT growed, thus its water contents must be updated
+             IF ( vmr(ji,jv) .GT. zero)  THEN
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+              IF (jv .EQ. 1) THEN
+                 IF (tot_bare_soil(ji) .GT. zero) THEN
+                    gqsb(ji,jv) = (resdist(ji,jv)*gqsb(ji,jv) + fra(ji)*gtr(ji))/tot_bare_soil(ji)
+                    bqsb(ji,jv) = (resdist(ji,jv)*bqsb(ji,jv) + fra(ji)*btr(ji))/tot_bare_soil(ji)
+                 ENDIF
+              ELSE
+                 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
+              ENDIF
+              qsintveg(ji,jv) = qsintveg(ji,jv) + fra(ji)* qstr(ji)
+             ELSE
+
+              ! vmr negative *** I don't understand why we remove water from the interception reservoir in PFTs which shrank
+              qsintveg(ji,jv) = qsintveg(ji,jv) - qsdq(ji,jv)
+             ENDIF
+
+             ! Then we update the soil layers depths.
+             ! But we do not  change dss, so that the redistribution does directly affect transpiration
+             ! constantes : min_sechiba = 1.E-8_r_std
+             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_max - bqsb(ji,jv) / ruu_ch(ji)
+        ENDIF
+      ENDDO
+    ENDDO
+
+
+    !! 7. We update resdist for the next "veget" change
+    
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+    resdist(:,1) = tot_bare_soil(:)
+    DO jv = 2, nvm
+       resdist(:,jv) = veget(:,jv)
+    ENDDO
+
+
+  !! 8. 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
+
+!! ================================================================================================================================
+!! SUBROUTINE            : hydrolc_flood
+!!
+!>\BRIEF                   this routine computes the evolution of the surface reservoir (floodplain)
+!!
+!! DESCRIPTION           : 
+!!
+!! RECENT CHANGE(S) : None
+!! 
+!! MAIN OUTPUT VARIABLE(S) : floodout
+!!
+!! REFERENCE(S) : Same as for module hydrolc
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE hydrolc_flood (kjpindex, dtradia, vevapnu, vevapflo, flood_frac, flood_res, floodout)
+    ! 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), INTENT(in)            :: flood_frac       !! Fraction of floodplains in grid box
+    ! modified fields
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: floodout         !! Flux to take out from floodplains
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: flood_res        !! Floodplains reservoir estimate
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: vevapnu          !! Bare soil evaporation
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: vevapflo         !! Floodplains evaporation
+    ! local declaration
+    INTEGER(i_std)                                          :: ji, jst, jv       !! indices
+    REAL(r_std)                                              :: k_m              !! conductivity in the soil
+    REAL(r_std)                                              :: temp             !! 
+
+!_ ================================================================================================================================
+
+    !- 
+    !- 1. Take out vevapflo from the reservoir and transfer the remaining to vevapnu 
+    !-
+    DO ji = 1,kjpindex
+       temp = MIN(flood_res(ji), vevapflo(ji))
+       flood_res(ji) = flood_res(ji) - temp
+       vevapnu(ji) = vevapnu(ji) + vevapflo(ji) - temp
+       vevapflo(ji) = temp
+    ENDDO
+
+    !- 
+    !- 2. Compute the total flux from floodplain floodout (transfered to routing) 
+    !-
+    DO ji = 1,kjpindex
+       floodout(ji) = vevapflo(ji) - flood_frac(ji) * SUM(precisol(ji,:))
+    ENDDO
+
+    !-
+    !- 3. Discriminate between precip over land and over floodplain
+    !-
+    DO jv=1, nvm
+       DO ji = 1,kjpindex
+          precisol(ji,jv) = precisol(ji,jv) * (1 - flood_frac(ji))
+       ENDDO
+    ENDDO 
+
+    IF (long_print) WRITE (numout,*) ' hydrolc_flood done'
+
+  END SUBROUTINE hydrolc_flood
+
+!! ================================================================================================================================
+!! SUBROUTINE      : hydrolc_soil
+!!
+!>\BRIEF           This routines computes the soil water budget and the related soil water 
+!! fluxes and soil moisture diagnostics using the two-layer Choisnel scheme.
+!!
+!! DESCRIPTION     : 
+!!
+!! 1. Main processes: The Choisnel scheme relies on two soil layers. 
+!! As show in the figure below, the upper one has a variable depth 
+!! and can disappear after dry spells. It is created by infiltration (of throughfall or snow melt), 
+!! in which case the layer is saturated. If this top layer is already present, infiltration can either 
+!! fill it or make it deeper (DucoudrÃ© et al., 1993). 
+!! \latexonly
+!! \includegraphics[scale = 0.5]{choisnelvariables.pdf}
+!! \endlatexonly
+!!
+!! In this framework, most water fluxes updating soil moisture act from top:\n
+!!  - throughfall, melted snow and ice, and irrigation increase soil moisture (of the top layer if present);
+!!  - transpiration and bare soil evaporation reduce soil moisture (of the top layer if present);
+!!  - return flow from rivers increases bottom soil moisture. \n
+!!
+!! Soil moisture stress on bare soil evaporation and transpiration (for diffuco), vegetation growth and 
+!! litter processes (for stomate), proceed respectively via a soil resistance (rsol), and three soil 
+!! moisture stress factor (humrel, vegstress, and litterhumdiag), which are all controlled by the 
+!! height of dry soil at the top of soil: \n
+!! - Soil moisture stress factor on transpiration and bare soil evaporation: humrel = \f$U_s\f$ \n
+!! \latexonly
+!! \input{humrel.tex}
+!! \endlatexonly \n
+!! - Resistance to bare soil evaporation: rsol = \f$r_\mathrm{soil}\f$ \n
+!! \latexonly
+!! \input{rsol.tex}
+!! \endlatexonly
+!!
+!! Runoff is only produced when the entire soil column is saturated, as in the bucket 
+!! scheme of Manabe (1969). Drainage at the bottom of soil and surface runoff are only diagnosed,  
+!! mostly for use in the routing module, using a constant 95% - 5% redistribution (Ngo-Duc et al., 2005).
+!! Internal drainage is allowed from the top to the bottom layer, following Ducharne et al. (1998).
+!! \latexonly
+!! \input{gdrainage.tex}
+!! \endlatexonly
+!!
+!! Irrigation (de Rosnay et al., 2003) and return flow are optional inflows, calculated by the 
+!! routing scheme (Ngo-Duc et al., 2005; Guimberteau, 2010).
+!! 
+!! 2. Subgrid variability:
+!! The subgrid variability of soil is described by introducing as many soil columns as PFTs 
+!! (de Rosnay & Polcher, 1998). The water budget is performed independently in each PFT/soil 
+!! column, but the bottom soil moisture is merged between all PFTs at the end of the calculations.
+!! Therefore, vegetation withdraws from a shared bottom moisture (grid-cell weighted average).
+!! There can also be horizontal diffusion between the top layers, if the flag ok_hdiff is true (the default value 
+!! is false). This is performed in the subroutine hydrolc_hdiff, call after the present subroutine.
+!!
+!! The areas of each soil column are defined by veget (the vegetation fraction of the PFTs),
+!! and not by veget_max (the maximum area of the PFT defined annually in slowproc). 
+!! As veget can change at a daily time step, a redistribution of water between the soil 
+!! columns is required : this is done in hydrolc_vegupd.
+!! 
+!! 3. Water budget issues :
+!! Different issues can arise when solving the above processes :
+!!  - negative total soil moisture (tracked using flag warning, but no action taken, cf. 4)
+!!  - dsg > dsp after merging the bottom layers, solved iteratively (6.2)
+!!  - we may also have a pathological behavior of rsol if hdry > dpu_cste (8.4)
+!!
+!! 4. Diagnostics for other subroutines: humrel for diffuco (7.1), vegstress for stomate (8.1),
+!! shumdiag for stomate (8.2), drysoil_frac for condveg (8.3), rsol for diffuco (8.4), 
+!! litterhumdiag for stomate (8.5).
+!!
+!! MAIN OUTPUT VARIABLE(S) : rsol, drysoil_frac, hdry, runoff (total), 
+!! run_off_tot (surface runoff), drainage, humrel, vegstress, shumdiag, litterhumdiag
+!! gqsb, bqsb, dsg, dss, dsp 
+!!
+!! REFERENCE(S) :
+!!  - DucoudrÃ©, N, Laval, K & Perrier, A, 1993. SECHIBA, a new set of parameterisations
+!! of the hydrologic exchanges at the land-atmosphere interface within the LMD Atmospheric General
+!! Circulation Model. Journal of Climate, 6, pp. 248-273.
+!!  - Ducharne, A. Laval, K. and Polcher, J. (1998) Sensitivity of the hydrological cycle to the parameterization 
+!! of soil hydrology in a GCM. Climate Dynamics, 14:307-327.
+!!  - de Rosnay, P. and Polcher J. (1998) Modeling root water uptake in a complex land surface scheme coupled 
+!! to a GCM. Hydrology and Earth System Sciences, 2(2-3):239-256.
+!!  - de Rosnay, P., Polcher, J., Laval, K. et Sabre, M. (2003). Integrated parameterization of irrigation in
+!! the land surface model ORCHIDEE. Validation over Indian Peninsula. Geophys. Res. Lett, 30(19):HLS2-1 -
+!! HLS2-4.
+!!  - Ngo-Duc, T., J. Polcher, and K. Laval (2005), A 53-year forcing data set for land surface models, 
+!! J. Geophys. Res., 110, D06116.
+!!  - ALMA : http://www.lmd.jussieu.fr/~polcher/ALMA/
+!!  - DucoudrÃ©, N. (1990). Sensibilite du climat simule a la parametrisation des echanges de vapeur d'eau entre 
+!! la biosphere et l'atmosphere. These de Doctorat, UniversitÃ© Paris 6.
+!!  - Ducharne A (1997). Le cycle de l'eau : modelisation de l'hydrologie continentale, etude de ses interactions 
+!! avec le climat, These de Doctorat, UniversitÃ© Paris 6.
+!!  - de Rosnay, P. (1999). Representation des interactions sol-plante-atmosphere dans le modele de circulation generale
+!! du LMD. These de doctorat, UniversitÃ© Paris 6.
+!!  - Guimberteau, M, 2010. Modelisation de l'hydrologie continentale et influences de l'irrigation sur le cycle de l'eau, 
+!! These de doctorat, UniversitÃ© Paris 6.
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+    
+
+  SUBROUTINE hydrolc_soil(kjpindex, vevapnu, precisol, returnflow, reinfiltration, 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)
+     
+  !! 0. Variable and parameter declaration
+
+    !! 0.1  Input variables
+ 
+    INTEGER(i_std), INTENT(in)                          :: kjpindex       !! Domain size (number of grid cells) (unitless)
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)       :: vevapnu        !! Bare soil evaporation  @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)   :: precisol       !! Throughfall  @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)       :: returnflow     !! Routed water which comes back into the soil 
+                                                                          !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)       :: reinfiltration !! Water returning to the top reservoir
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)       :: irrigation     !! Irrigation water applied to soils 
+                                                                          !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)       :: tot_melt       !! Total melt @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)       :: mx_eau_var     !! Maximum water content of the soil 
+                                                                          !! @tex ($kg m^{-2}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(in)  :: veget          !! Grid-cell fraction effectively covered by vegetation 
+                                                                          !! for each PFT, except for soil (0-1, unitless) 
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)       :: ruu_ch         !! Volumetric soil water capacity 
+                                                                          !! @tex ($kg m^{-3}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)   :: transpir       !! Transpiration over each PFT @tex ($kg m^{-2}$) @endtex 
+    
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(out)  :: runoff         !! Total runoff @tex ($kg m^{-2}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)      :: run_off_tot    !! Diagnosed surface runoff  @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)      :: drainage       !! Diagnosed drainage at the bottom of soil
+                                                                          !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(out) :: humrel         !! Soil moisture stress factor on transpiration and bare
+                                                                          !! soil evaporation (0-1, unitless) ! Relative humidity
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out) :: shumdiag       !! Mean relative soil moisture in the different levels 
+                                                                          !! used by thermosoil.f90 (0-1, unitless) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: litterhumdiag  !! Litter humidity factor (0-1, unitless), used in 
+                                                                          !! stomate
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)      :: rsol           !! Resistance to bare soil evaporation (s m^{-1}) 
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)      :: drysoil_frac   !! Fraction of visible dry soil  (0-1, unitless)
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)      :: hdry           !! Mean top dry soil height (m) version beton
+
+    !! 0.3  Modified variables
+
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout):: gqsb           !! Water content in the top layer 
+                                                                          !! @tex ($kg m^{-2}$) @endtex              
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout):: bqsb           !! Water content in the bottom layer 
+                                                                          !! @tex ($kg m^{-2}$) @endtex     
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout):: dsg            !! Depth of the top layer (m) 
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout):: dss            !! Depth of dry soil at the top, whether in the top or 
+                                                                          !! bottom layer (m)
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout):: dsp            !! Depth of dry soil in the bottom layer plus depth of
+                                                                          !! top layer (m) 
+    REAL(r_std), DIMENSION (kjpindex, nvm), &
+                                          INTENT(inout) :: vegstress      !! Vegetation moisture stress (only for vegetation
+                                                                          !!  growth) (0-1, unitless)
+    
+    !! 0.4 Local variables
+   
+    INTEGER(i_std)                                      :: ji,jv, jd      !! Indices for grid-cells, PFTs and diagnostic levels in
+                                                                          !! the soil (unitless)
+    REAL(r_std), DIMENSION(kjpindex)                    :: zhumrel_lo     !! Soil moisture stress factors on transpiration for the
+                                                                          !! bottom and top layers (0-1, unitless)
+    REAL(r_std), DIMENSION(kjpindex)                    :: zhumrel_up     !! Soil moisture stress factors on transpiration for the
+                                                                          !! bottom and top layers (0-1, unitless)    
+    REAL(r_std), DIMENSION(kjpindex,nvm)                :: zeflux         !! Evaporation to be withdrawn from soil 
+                                                                          !! @tex ($kg m^{-2}) @endtex ! *** why divided by veget ?
+    REAL(r_std), DIMENSION(kjpindex,nvm)                :: zpreci         !! Throughfall @tex ($kg m^{-2}$) @endtex  
+                                                                          !! ! *** why divided by veget ?
+    LOGICAL, DIMENSION(kjpindex,nvm)                    :: warning        !! To track negative total soil moisture cases in soil 
+                                                                          !! columns (true/false)
+    REAL(r_std)                                         :: gtr, btr       !! Fractions of top and botttom soil layers to the 
+                                                                          !! different diagnostic soil layers (0-1, unitless)
+    REAL(r_std), DIMENSION(kjpindex)                    :: mean_dsg       !! Mean depth of water in top soil layer (m)
+    LOGICAL                                             :: OnceMore       !! To repeat the correction to solve dsg > dsp after 
+                                                                          !! diffusion between the bottom layers (true/false)
+    INTEGER(i_std), PARAMETER                           :: nitermax = 100 !! Maximum number of iterations to dsg > dsp after 
+                                                                          !! diffusion between the bottom layers (unitless) 
+    INTEGER(i_std)                                      :: niter          !! Counter of iterations to solve dsg > dsp after 
+                                                                          !! diffusion between the bottom layers (unitless) 
+    INTEGER(i_std)                                      :: nbad           !! Number of negative total soil moisture cases 
+                                                                          !! (unitless); this is before diffusion between the 
+                                                                          !! bottom layers, cf. "warning" ***
+    LOGICAL, DIMENSION(kjpindex,nvm)                    :: lbad           !! Tags "bad" PFTs where dsg > dsp after diffusion 
+                                                                          !! between the bottom layers (true/false)
+    LOGICAL, DIMENSION(kjpindex)                        :: lbad_ij        !! Tags "bad" grid-points where at least one PFT exhibits
+                                                                          !!  dsg > dsp after diffusion between the bottom layers 
+                                                                          !! (true/false) 
+    REAL(r_std)                                         :: gqseuil        !! Ancillary variables to compute drainage between the 
+                                                                          !! two soil layers @tex ($kg m^{-2}$) @endtex
+    REAL(r_std)                                         :: eausup         !! Ancillary variables to compute drainage between the 
+                                                                          !! two soil layers @tex ($kg m^{-2}$) @endtex
+    REAL(r_std)                                         :: wd1            !! Ancillary variables to compute drainage between the 
+                                                                          !! two soil layers @tex ($kg m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(nbdl+1)                      :: tmp_dl         !! Temporary diagnostic levels in the soil (m)
+    REAL(r_std), DIMENSION(kjpindex,nvm)                :: a_subgrd       !! Diagnosed subgrid fraction of saturated soil in the 
+                                                                          !! top layer, to calculate hdry (0-1, unitless)
+!_ ================================================================================================================================
+    
+  !! 1. Preliminary calculations
+    
+    !!  We define input and output fluxes at the soil surface, for each PFT
+    !!  The input flux is throughfall.
+    !!  The ouput flux is the total evaporation withdrawn from the soil (transpiration and bare soil evaporation, BSE)
+    ! *** I don't understand why the fluxes are divided by veget if they are in kg.m^{-2} within each PFT *** 
+    DO jv=1,nvm
+      DO ji = 1, kjpindex
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+         IF (jv .EQ. 1) THEN
+            IF ( tot_bare_soil(ji) .GT. zero ) THEN
+               zeflux(ji,jv) = transpir(ji,jv)/tot_bare_soil(ji)
+               zpreci(ji,jv) = precisol(ji,jv)/tot_bare_soil(ji)
+            ELSE
+               zeflux(ji,jv) = zero
+               zpreci(ji,jv) = zero
+            ENDIF
+         ELSE
+            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
+         ENDIF
+      ENDDO
+    ENDDO
+    
+    !!  For bare soil evaporation, we need to distinguish two cases. 
+    !!  This should only apply if there is vegetation but we do not test this case.
+    !!  Case 1 - if bare soil is present, BSE is extracted from the bare soil fraction
+    DO ji = 1, kjpindex
+      IF ( (vegtot(ji) .GT. zero) .AND. (tot_bare_soil(ji) .GT. min_sechiba) ) THEN
+        zeflux(ji,1) = vevapnu(ji)/tot_bare_soil(ji)
+      ENDIF
+    ENDDO
+
+    !!   Case 2 - if bare soil is not present, BSE is uniformly redistributed among the vegetation fractions
+    !!   This case is possible because of transfers (snow for instance). 
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+    DO jv = 2, nvm
+      DO ji = 1, kjpindex
+        IF ( (vegtot(ji) .GT. zero) .AND. (tot_bare_soil(ji) .LE. min_sechiba)&
+             & .AND. (veget(ji,jv) .GT. min_sechiba)) THEN
+          zeflux(ji,jv) =  zeflux(ji,jv) + vevapnu(ji)/vegtot(ji)
+        ENDIF
+      ENDDO
+    ENDDO
+    
+    ! Temporary diagnostic levels in the soil to diagnose shumdiag
+    tmp_dl(1) = 0
+    tmp_dl(2:nbdl+1) = diaglev(1:nbdl)
+
+  !! 2. Updating soil moisture
+
+    !!  We update soil moisture:
+    !!  The top soil moisture reacts to evaporation, throughfall, snow and ice melt, and inflow from irrigation
+    !!  The bottom soil moisture can receive returnflow from routing.f90
+    DO jv=1,nvm
+      DO ji=1,kjpindex
+      
+        ! Evaporated water is taken out of the ground
+        gqsb(ji,jv) = gqsb(ji,jv) - zeflux(ji,jv)
+        !
+        ! 1.2 Add snow and ice melt, troughfall from vegetation, reinfiltration and irrigation.
+        !
+        IF(vegtot(ji) .NE. zero) THEN
+
+           !  snow and ice melt, reinfiltration and troughfall from vegetation
+           gqsb(ji,jv) = gqsb(ji,jv) + zpreci(ji,jv) + (tot_melt(ji)+reinfiltration(ji))/vegtot(ji)
+           
+           ! We take care to add the irrigation only to the vegetated part if possible
+           !
+           IF (ABS(vegtot(ji)-tot_bare_soil(ji)) .LE. min_sechiba) THEN
+              gqsb(ji,jv) = gqsb(ji,jv) + irrigation(ji)/vegtot(ji)
+           ELSE
+
+              ! no vegetation, : we only add irrigation in the PFTs where vegetation can grow  
+              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)-tot_bare_soil(ji))
+                 ELSE
+                    bqsb(ji,jv) = bqsb(ji,jv) + irrigation(ji)/(vegtot(ji)-tot_bare_soil(ji))
+                 ENDIF
+              ENDIF
+           ENDIF
+           
+           ! We add the water returning from rivers to the lower reservoir.
+           bqsb(ji,jv) = bqsb(ji,jv) + returnflow(ji)/vegtot(ji)
+           
+        ENDIF
+        
+      END DO
+    ENDDO
+    
+  !! 3. We compute runoff and adjust the soil layers' depth and water content
+
+    !!     The depth of top dry soil, dss, is of particular importance as it controls the soil moisture stresses 
+    !!     to transpiration and BSE     
+    runoff(:,:) = zero
+    
+    warning(:,:) = .FALSE.
+    DO jv=1,nvm
+      DO ji = 1, kjpindex
+        
+        !! 3.1 Soil moisture in excess of total water holding capacity runs off
+        runoff(ji,jv) = MAX(gqsb(ji,jv) + bqsb(ji,jv) - mx_eau_var(ji), zero)
+        
+        !! 3.2 If the soil is saturated (runoff is generated): no top layer; dss = dsp 
+        IF (mx_eau_var(ji) .LE. (gqsb(ji,jv) + bqsb(ji,jv))) THEN
+            !
+            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
+            
+            !! 3.3 Else, if the top layer holds more water than allowed by its depth, the top layer deepens
+            !! The top layer is saturated, so that dss=0.
+            !! In this case, dsp is useless, and is not updated, 
+            !! even if bqsb has changed because of irrigation and return flow.
+            IF (gqsb(ji,jv) .GT. dsg(ji,jv) * ruu_ch(ji)) THEN
+                !
+                dsg(ji,jv) = gqsb(ji,jv) / ruu_ch(ji)
+                dss(ji,jv) = zero
+            ELSEIF (gqsb(ji,jv) .GT. zero ) THEN
+ 
+            !! 3.4 If the top layer is not saturated, its total depth does not change and we only update its dry soil depth
+            !! In this case, dsp is useless, and is not updated, 
+            !! even if bqsb has changed because of irrigation and return flow.
+                !
+                dss(ji,jv) = ((dsg(ji,jv) * ruu_ch(ji)) - gqsb(ji,jv)) / ruu_ch(ji) 
+            ELSE
+
+            !! 3.5 If the top layer's moisture is negative, it vanishes and the required moisture is withdrawn from the bottom layer
+            !! dsp is updated accordingly, and defines the depth of top dray soil dss.
+                !
+                bqsb(ji,jv) = bqsb(ji,jv) + gqsb(ji,jv)
+                dsp(ji,jv) = dpu_max - bqsb(ji,jv) / ruu_ch(ji) ! dsp>dpu if bqsb<0 *** we can be here with bsqb<0 and bqsb+gqsb>0
+                gqsb(ji,jv) = zero
+                dsg(ji,jv) = zero
+                dss(ji,jv) = dsp(ji,jv)
+            END IF
+
+        ELSE 
+
+        !! 3.6 If the total soil moisture is negative: we keep track of the problem for further warning.
+        !! In this extreme case of dry soil, the top layer is absent.
+        !! The top dry soil depth, dsp, is equal to the soil depth.
+        !! But we keep the negative moisture for water budget closure, and assign it to the bottom layer.
+        ! 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 signale que ce cas donc. 
+        ! *** But this is obviously not the case in CMIP5 runs ***
+        ! *** Also, I don't see the use of conditionning upon zeflux(ji,jv) .GT. zero : negative moisture is always a problem !
+            
+            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) ! this will be negative 
+            dsp(ji,jv) = dpu_max
+            gqsb(ji,jv) = zero
+            dsg(ji,jv) = zero
+            dss(ji,jv) = dsp(ji,jv)
+            
+        ENDIF
+        
+      ENDDO
+    ENDDO
+    
+  !! 4. If there are some PFTs with negative moisture, it is written in the run log
+    
+    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
+    
+  !! 5. Top layers that are very large or very dry can be deadlock situations for the Choisnel scheme
+ 
+    !!  Top layers that are very large or that hold a tiny amount of water .
+    !!  They are handled here.
+    IF (long_print) WRITE(numout,*)  'hydro_soil 2.0 : Resolve deadlocks'
+    DO jv=1,nvm
+      DO ji=1,kjpindex
+        
+        !! 5.1 If the top layer is almost dry, we merge the two layers 
+        IF ( ABS(dsp(ji,jv)-dsg(ji,jv)) .LT. min_sechiba ) THEN ! min_sechiba = 1.e-8 (constantes.f90)
+            bqsb(ji,jv) = bqsb(ji,jv) + gqsb(ji,jv)
+            dsp(ji,jv) = dpu_max - bqsb(ji,jv) / ruu_ch(ji) ! *** can this make dsp > dpu_cste
+            gqsb(ji,jv) = zero
+            dsg(ji,jv) = zero
+            dss(ji,jv) = dsp(ji,jv)
+        ENDIF
+        
+        !!  5.2 Internal drainage from the top to the bottom layer
+        !!   Much faster when the relative moisture of the top layer exceeds 75\% of the water holding capacity.
+        !!   The parameters are exp_drain = 1.5, min_drain = 0.002 mm/h and max_drain = 0.2 mm/h
+        gqseuil = min_sechiba * deux * ruu_ch(ji) ! min_sechiba = 1.e-8 (constantes.f90)
+        eausup = dsg(ji,jv) * ruu_ch(ji)
+        wd1 = .75*eausup
+        
+        IF (eausup .GT. gqseuil) THEN ! dsg > 2.e-8 m
+            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 ! *** why not remove the top layer in that case ?? 
+        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_max - bqsb(ji,jv)/ruu_ch(ji) ! *** this line shouldn't make dsp>dpu_cste
+      ENDDO
+    ENDDO
+    
+  !! 6. We want the vegetation to share a common bottom moisture:
+    !! Thus, we must account for moisture diffusion between the soil columns.
+    IF (long_print) WRITE(numout,*)  'hydrolc_soil 3.0 : Vertical diffusion'
+
+    !!  6.1 Average of bottom and top moisture over the "veget" fractions
+    mean_bqsb(:) = zero
+    mean_gqsb(:) = zero
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+        IF ( vegtot(ji) .GT. zero ) THEN
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+           IF (jv .EQ. 1) THEN
+              mean_bqsb(ji) = mean_bqsb(ji) + tot_bare_soil(ji)/vegtot(ji)*bqsb(ji,jv)
+              mean_gqsb(ji) = mean_gqsb(ji) + tot_bare_soil(ji)/vegtot(ji)*gqsb(ji,jv)
+           ELSE
+              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
+        ENDIF
+      ENDDO
+    ENDDO
+    
+    OnceMore = .TRUE.
+    niter = 0
+    lbad_ij(:)=.TRUE. 
+    DO WHILE ( OnceMore .AND. ( niter .LT. nitermax ) )  ! nitermax prevents infinite loops (should actually never occur)
+      
+      niter = niter + 1
+      
+      !! 6.2 We assign the mean value in all the soil columns in a grid-cell
+      DO jv = 1, nvm
+        DO ji = 1, kjpindex
+           IF (lbad_ij(ji)) THEN
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+              IF (jv .EQ. 1) THEN
+                 IF (tot_bare_soil(ji).GT.zero) THEN
+                    !
+                    bqsb(ji,jv) = mean_bqsb(ji)
+                    dsp(ji,jv) = dpu_max - bqsb(ji,jv)/ruu_ch(ji)
+                 ENDIF
+              ELSE IF ( veget(ji,jv) .GT. zero ) THEN
+                 !
+                 bqsb(ji,jv) = mean_bqsb(ji)
+                 dsp(ji,jv) = dpu_max - bqsb(ji,jv)/ruu_ch(ji) ! *** can this line make dsp>dpu_cste ?
+              ENDIF
+           ENDIF
+           
+        ENDDO
+      ENDDO    
+      
+      !! 6.3 Iterative adjustment if top layer larger than new average dsp
+      !! After averaging the bottom moistures, dsp becomes the mean depth of soil that is not filled by bottom moisture.
+      !! In "bad" points where dsg > dsp, we merge the two soil layers.
+      !! This adjustment needs to be done iteratively (WHILE loop)     
+      !! We diagnose the bad points where dsg>dsp
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+!!$      lbad(:,:) = ( ( dsp(:,:) .LT. dsg(:,:) ) .AND. &
+!!$                    ( dsg(:,:) .GT. zero ) .AND. &
+!!$                    ( veget(:,:) .GT. zero ) )
+      lbad(:,:) = ( ( dsp(:,:) .LT. dsg(:,:) ) .AND. &
+                    ( dsg(:,:) .GT. zero ) )
+      DO jv = 1, nvm
+         DO ji = 1, kjpindex
+            IF (jv .EQ. 1) THEN
+               lbad(ji,jv) = lbad(ji,jv) .AND. ( tot_bare_soil(ji) .GT. zero )
+            ELSE
+               lbad(ji,jv) = lbad(ji,jv) .AND. ( veget(ji,jv) .GT. zero )
+            ENDIF
+         ENDDO
+      ENDDO
+
+      
+      !! If there are no such points, we'll do no further iteration 
+      IF ( COUNT( lbad(:,:) ) .EQ. 0 ) OnceMore = .FALSE.
+      DO ji = 1, kjpindex
+        IF (COUNT(lbad(ji,:)) == 0 ) lbad_ij(ji)=.FALSE.
+      ENDDO
+      
+      !! In the bad PFTs, we merge the two soil layers.
+      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_max - 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_max - bqsb(ji,jv)/ruu_ch(ji)  ! *** could this line make dsp>dpu_cste ? 
+                                                           ! *** set a max to dpu_cste to be sure !
+            dss(ji,jv) = dsp(ji,jv)
+            dsg(ji,jv) = zero
+            
+          ENDIF
+        ENDDO
+      ENDDO  
+      
+      !! New average of bottom and top moisture over the "veget" fractions, for the next iteration
+      mean_bqsb(:) = zero
+      mean_gqsb(:) = zero
+      DO jv = 1, nvm
+        DO ji = 1, kjpindex
+          IF ( vegtot(ji) .GT. zero ) THEN
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+             IF (jv .EQ. 1) THEN
+                mean_bqsb(ji) = mean_bqsb(ji) + tot_bare_soil(ji)/vegtot(ji)*bqsb(ji,jv)
+                mean_gqsb(ji) = mean_gqsb(ji) + tot_bare_soil(ji)/vegtot(ji)*gqsb(ji,jv)
+             ELSE
+                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
+          ENDIF
+        ENDDO
+      ENDDO
+      
+    ENDDO ! end while, but no warning if nitermax has been reached ***
+    
+  !! 7. Compute total runoff from all soil columns and partition it into drainage and surface runoff
+
+    ! *** why isn't run_off_tot divided by vegtot ?
+    IF (long_print) WRITE(numout,*)  'hydrolc_soil 4.0: Computes total runoff'
+
+    !! 7.1 Average total runoff
+    run_off_tot(:) = zero
+    DO ji = 1, kjpindex
+      IF ( vegtot(ji) .GT. zero ) THEN
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+       run_off_tot(ji) = run_off_tot(ji) + (runoff(ji,1)*tot_bare_soil(ji))
+       DO jv = 2, 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) + reinfiltration(ji)
+      ENDIF
+    ENDDO
+    
+    !! 7.2 Diagnose drainage and surface runoff (95% and 5%)
+    drainage(:) = 0.95 * run_off_tot(:)
+    run_off_tot(:) = run_off_tot(:) - drainage(:)       
+    ! *** from now on, we lost track of total runoff
+    ! *** the name "run_off_tot" is VERY misleading
+    
+  !! 8. Diagnostics which are needed to carry information to other modules:
+
+    IF (long_print) WRITE(numout,*)  'hydro_soil 5.0: Diagnostics'
+    
+    ! Reset dsg if necessary
+    WHERE (gqsb(:,:) .LE. zero) dsg(:,:) = zero
+    
+    ! Average moisture profile for shumdiag
+    DO ji=1,kjpindex
+      mean_dsg(ji) = mean_gqsb(ji)/ruu_ch(ji) ! mean depth of water in top layer in meters
+    ENDDO
+    
+    !! 8.1 Moisture stress factors on vegetation (humrel and vegstress)
+    !! Moisture stress factors on vegetation:
+    !!  - "humrel" on transpiration (for condveg) exponentially decreases with top dry soil depth;
+    !!  the decay factor is the one of root density with depth (from 1 to 8 depending on PFTs),
+    !!  following de Rosnay and Polcher (1998) 
+    !!  - "vegstress" on vegetation growth (for stomate) 
+    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_max * (dsp(ji,jv)/dpu_max) )
+               dsg(ji,jv) = zero
+                   
+               ! humrel = 0 if dsp is larger than its value at the wilting point, or if the bottom layer's soil is negative
+               ! *** the condition based on qwilt (= 5.0) doesn't make much sense: (i) the Choisnel scheme works in available  
+               ! *** moisture, i.e. above wilting point (Ducharne & Laval, 2000), so that the moisture at withing point is ZERO; 
+               ! *** (ii) with the chosen values in constantes_soil.f90, qwilt/ruu_ch is around 0.033 and dpu_cste-qwilt/ruu_ch
+               ! *** is around dpu
+               IF (dsp(ji,jv).GT.(dpu_max - min_sechiba) .OR. bqsb(ji,jv).LT.zero) THEN
+                  humrel(ji,jv) = zero
+               ENDIF
+
+               vegstress(ji,jv) = humrel(ji,jv)
+               
+            ELSE
+
+               !! 8.1.2 If there are two soil layers, we need the "transpiring" fraction "a_subgrd"
+               !! We compute humrel as the average of the values defined by dss and dsp.
+	       !! The weights depend on "a_subgrd", which is defined by redistributing the top layer's 
+	       !! moisture in a virtual layer of depth dsg_min (set to 1 mm in hydrolc), 
+               !! what defines a totally dry and a totally saturated fraction (a_subgrd):
+               !!  - if the top layer's moisture > 1mm, then a_subgrd=1, and the humrel is normally deduced from dss only
+               !!  - if the top layer's moisture is very small, a_subgrd decreases from 1 to 0 as the top layer's moisture 
+               !!    vanishes, and it serves to describe a smooth transition to the case where the top soil layer has
+               !!    vanished and humrel depends on dsp.
+               !! \latexonly
+ 	       !! \includegraphics[scale = 1]{asubgrid.pdf}
+               !! \endlatexonly
+               !
+               zhumrel_lo(ji) = EXP( - humcste(jv) * dsp(ji,jv)) 
+               zhumrel_up(ji) = EXP( - humcste(jv) * dss(ji,jv))
+               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)
+               
+               !! As we need a slower variable for vegetation growth, vegstress is computed differently from humrel.
+               ! *** la formule ci-dessous est d'un empirisme absolu : on ajoute deux stresses, on en retranche un autre...????
+               ! que veut dire slower variable ??
+               vegstress(ji,jv) = zhumrel_lo(ji) + zhumrel_up(ji) - EXP( - humcste(jv) * dsg(ji,jv) ) 
+               
+            ENDIF
+            
+         ELSE 
+ 
+            !! 8.1.3 If total moisture is negative, the two moisture stress factors are set to zero. 
+            !! This should avoid that large negative soil moisture accumulate over time because of small skin layers
+            !! which transpire quickly.
+            ! *** Yet, CMIP5 exhibits such behaviors => because of rsol ?? or other reasons ?? The routing shouldn't 
+            ! *** create such situations, but couldn't some patches here or there ???
+            humrel(ji,jv) = zero
+            vegstress(ji,jv) = zero
+            
+         ENDIF
+        !
+      ENDDO
+    ENDDO
+    
+    !! 8.2 Mean relative soil moisture in the diagnostic soil levels: shumdiag (for thermosoil)
+    !! It is deduced from the mean moisture and depth of the two soil layers in the grid cell,
+    !! depending on how the soil diagnostic levels intersect the two mean soil depths
+    DO jd = 1,nbdl
+      DO ji = 1, kjpindex
+         IF ( tmp_dl(jd+1) .LT. mean_dsg(ji)) THEN ! mean_dsg = mean depth of water in top layer in meters
+
+            ! If the diagnostic soil level entirely fits into the mean top soil layer depth, they have the same 
+            ! relative moisture
+            shumdiag(ji,jd) = mean_gqsb(ji)/mx_eau_var(ji)
+         ELSE 
+            IF ( tmp_dl(jd) .LT. mean_dsg(ji)) THEN
+
+               ! If the diagnostic soil level intersects both soil layers, its relative moisture is the weighted
+               ! mean of the ones of two soil layers
+               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
+
+               ! If the diagnostic soil level entirely fits into the mean bottom soil layer depth,
+               ! they have the same relative moisture 
+               shumdiag(ji,jd) = mean_bqsb(ji)/mx_eau_var(ji)
+            ENDIF
+         ENDIF
+         shumdiag(ji,jd) = MAX(MIN(shumdiag(ji,jd), un), zero)
+      ENDDO
+    ENDDO
+
+    !! 8.3 Fraction of visibly dry soil in the bare soil fraction for soil albedo
+    !!  if we want to account for its dependance on soil moisture in condveg.
+    !!  We redistribute the top layer's moisture in a virtual layer of depth 0.1 m,
+    !!  what defines a totally saturated and a totally dry fraction (drysoil_frac). 
+    !!  The latter is thus 1 if dss > 0.1 m. 
+    drysoil_frac(:) = MIN(MAX(dss(:,1),zero)*10._r_std, un)
+
+    !! 8.4 Resistance to bare soil evaporation
+    !!  This resistance increases with the height of top dry soil, described by hdry.
+    !!  It depends on both dss and dsp (dry soil heights) in the bare soil fraction, 
+    !!  and, as for the soil moisture stress factor on transpiration (humrel), 
+    !!  we use "a_subgrd" (see 8.1.2) to describe a smooth transition between cases 
+    !!  when the top layer's moisture > 1mm and hdry=dss and cases when the top layer's 
+    !!  has vanished and hdy=dsp. 
+    !!  The relationship between rsol and dry soil height has been changed since 
+    !!  de Rosnay and Polcher (1998), to make rsol becomes VERY large when hdry 
+    !!  gets close to dpu_cste 
+    !!  Owing to this non-linear dependance, BSE tends to zero when the depth of dry reaches dpu_cste.
+    ! *** if hdry > dpu (several cases might lead to this pathological situation), 
+    ! *** we shift to the other limb of the hyperbolic function, and rsol decreases towards hdry*rsol_cste 
+    ! *** can this explain the accumulation of very negative soil moisture in arid zones in CMIP5 ???
+    ! *** COULD'NT WE SIMPLY SET THAT hdry CANNOT EXCEED dpu_cste ???
+    hdry(:) = a_subgrd(:,1)*dss(:,1) + (un-a_subgrd(:,1))*dsp(:,1) 
+    
+    rsol(:) = -un
+    DO ji = 1, kjpindex
+       IF (tot_bare_soil(ji) .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_max - hdry(ji))+1.e-10)**2 ) * rsol_cste
+       ENDIF
+    ENDDO
+    
+    !! 8.5 Litter humidity factor, used in stomate
+    !!  It varies from 1 when mean top dry soil height is 0, and decreases as mean top dry soil height increases
+    litterhumdiag(:) = EXP( - hdry(:) / hcrit_litter ) ! hcrit_litter=0.08_r_std
+
+    !!  Special case of it has just been raining a few drops: the top layer exists, but its height 
+    !!  is ridiculously small and the mean top dry soil height is almost zero: we assume a dry litter 
+    WHERE ( ( hdry(:) .LT. min_sechiba ) .AND. &  ! constantes : min_sechiba = 1.E-8_r_std
+            ( 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
+  
+
+!! ================================================================================================================================
+!! SUBROUTINE   : hydrolc_waterbal 
+!!
+!>\BRIEF        This subroutine checks the water balance closure in each terrestrial grid-cell
+!! over a time step.
+!!
+!! DESCRIPTION  : The change in total water amount over the time step must equal the algebraic sum of the  
+!! water fluxes causing the change, integrated over the timestep. The equality is checked to some precision, 
+!! set for double precision calculations (REAL*8). Note that this precision depends on the time step.
+!! This verification does not make much sense in REAL*4 as the precision is the same as some of the fluxes.
+!! The computation is only done over the soil area, as over glaciers (and lakes?) we do not have 
+!! water conservation. 
+!! *** The above sentence is not consistent with what I understand from the code, since snow_nobio is accounted for.
+!! *** what is the value of epsilon(1) ?
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : None
+!! 
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================   
+  
+  SUBROUTINE hydrolc_waterbal (kjpindex, index, first_call, dtradia, veget, totfrac_nobio, qsintveg, snow, snow_nobio,&
+       & precip_rain, precip_snow, returnflow, reinfiltration, irrigation, tot_melt, vevapwet, transpir, vevapnu,&
+       & vevapsno, vevapflo, floodout, run_off_tot, drainage)
+    
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT (in)                            :: kjpindex       !! Domain size (number of grid cells) (unitless)
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)       :: index          !! Indices of the points on the map
+    LOGICAL, INTENT (in)                                   :: first_call     !! This flag is set to true to initialize the total 
+                                                                             !! amount of water at beginning of time step 
+                                                                             !! (true/false)
+    REAL(r_std), INTENT (in)                               :: dtradia        !! Time step duration (s)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)      :: veget          !! Grid-cell fraction effectively covered by 
+                                                                             !! vegetation for each PFT, except for soil 
+                                                                             !! (0-1, unitless) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)          :: totfrac_nobio  !! Total fraction of terrestrial ice+lakes+...
+                                                                             !! (0-1, unitless) 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)      :: qsintveg       !! Amount of water in the canopy interception 
+                                                                             !! reservoir @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)          :: snow           !! Snow water equivalent @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(inout):: snow_nobio     !! Snow water equivalent on nobio areas  
+                                                                             !! @tex ($kg m^{-2}$) @endtex 
+									     ! Ice water balance
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)          :: precip_rain    !! Rainfall @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)          :: precip_snow    !! Snowfall  @tex ($kg m^{-2}$) @endtex  
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)          :: returnflow     !! Routed water which comes back into the soil 
+                                                                             !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)          :: reinfiltration !! Water returning from routing to the top reservoir
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)          :: irrigation     !! Irrigation water applied to soils 
+                                                                             !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)          :: tot_melt       !! Total melt @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)      :: vevapwet       !! Interception loss over each PFT 
+                                                                             !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)      :: transpir       !! Transpiration over each PFT 
+                                                                             !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)          :: vevapnu        !! Bare soil evaporation @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)          :: vevapflo       !! Floodplains evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)          :: vevapsno       !! Snow evaporation @tex ($kg m^{-2}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)          :: floodout       !! Outflow from floodplains
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)          :: run_off_tot    !! Diagnosed surface runoff @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)          :: drainage       !! Diagnosed rainage at the bottom of soil  
+                                                                             !! @tex ($kg m^{-2}$) @endtex 
+    
+    !! 0.2 Output variables
+    
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    
+    INTEGER(i_std)                                         :: ji, jv, jn     !!  Grid-cell, PFT and "nobio" fraction indices 
+                                                                             !! (unitless)
+    REAL(r_std)                                            :: allowed_err    !! Allowed error in the water budget closure 
+                                                                             !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex)                       :: watveg         !! Total amount of intercepted water in a grid-cell  
+                                                                             !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex)                       :: delta_water    !! Change in total water amount 
+                                                                             !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex)                       :: tot_flux       !! Algebraic sum of the water fluxes integrated over 
+                                                                             !! the timestep @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex)                       :: sum_snow_nobio !! Total amount of snow from the "nobio" fraction 
+                                                                             !! in a grid-cell @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex)                       :: sum_vevapwet   !! Sum of interception loss in the grid-cell 
+                                                                             !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex)                       :: sum_transpir   !! Sum of  transpiration in the grid-cell 
+                                                                             !! @tex ($kg m^{-2}$) @endtex 
+!_ ================================================================================================================================
+
+  !! 1. We initialize the total amount of water in terrestrial grid-cells at the beginning of the first time step
+    
+    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 ! nnobio=1
+          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
+    
+  !! 2. We check the water balance : this is done at the end of a time step
+    
+    tot_water_end(:) = zero
+    
+    !! 2.1 If the "nobio" fraction does not complement the "bio" fraction, we issue a warning
+    !!   If the "nobio" fraction (ice, lakes, etc.) does not complement the "bio" fraction (vegetation and bare soil),
+    !!   we do not need to go any further, and we output a warning ! *** how are oceans treated ?
+    DO ji = 1, kjpindex
+
+       ! 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
+    
+    !! 2.2 We calculate the total amount of water in grid-cells at the end the time step
+    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
+     
+    !! 2.3 Calculate the change in total water amount during the time step
+    !!  Calculate the change in total water amount during the time, stepand the algebraic sum
+    !!  of the water fluxes supposed to cause the total water amount change.
+    !!  If the model conserves water, they should be equal, since the fluxes are used in their integrated form, 
+    !!  over the time step dtradia, with a unit of kg m^{-2}.
+    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) + reinfiltration(ji) + irrigation(ji) - &
+             & sum_vevapwet(ji) - sum_transpir(ji) - vevapnu(ji) - vevapsno(ji) - vevapflo(ji) + &
+             & floodout(ji)- run_off_tot(ji) - drainage(ji) 
+       
+    ENDDO
+    
+       !! 2.4 We do the check, given some minimum required precision
+       !!       This is a wild guess and corresponds to what works on an IEEE machine under double precision (REAL*8).
+       !!       If the water balance is not closed at this precision, we issue a warning with some diagnostics.
+       allowed_err = 50000*EPSILON(un) ! *** how much is epsilon(1) ? where is it defined ?
+       
+    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, floodplains:', reinfiltration(ji), 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, evapflo : ', vevapnu(ji), vevapsno(ji), vevapflo(ji)
+          WRITE(numout,*) 'floodout : ', floodout(ji)
+          WRITE(numout,*) 'drainage : ', drainage(ji)
+          STOP 'in hydrolc_waterbal'
+       ENDIF
+       
+    ENDDO
+    
+  !! 3. Transfer the total water amount at the end of the current timestep to the begining of the next one
+    
+    tot_water_beg = tot_water_end
+    
+  END SUBROUTINE hydrolc_waterbal
+ 
+
+!! ================================================================================================================================
+!! SUBROUTINE  : hydrolc_alma 
+!!
+!>\BRIEF       This routine computes diagnostic variables required under the ALMA standards:
+!! changes in water amounts over the time steps (in the soil, snow and interception reservoirs); total water amount 
+!! at the end of the time steps; soil relative humidity.
+!!
+!! DESCRIPTION : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : 
+!!  - soilwet: mean relative humidity of soil in the grid-cells (0-1, unitless)
+!!  - delsoilmoist, delswe, delintercept: changes in water amount during the time step @tex ($kg m^{-2}$) @endtex, 
+!!    for the three water reservoirs (soil,snow,interception)
+!!  - tot_watsoil_end: total water amount at the end of the time steps aincluding the three water resrevoirs  
+!! @tex ($kg m^{-2}$) @endtex. 
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n   
+!_ ================================================================================================================================   
+  
+  SUBROUTINE hydrolc_alma (kjpindex, index, first_call, qsintveg, snow, snow_nobio, soilwet)
+    
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT (in)                         :: kjpindex    !! Domain size (number of grid cells) (unitless)
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)    :: index       !! Indices of the points on the map (unitless)
+    LOGICAL, INTENT (in)                                :: first_call  !! This flag is set to true to initialize the water amount 
+                                                                       !! variables at beginning of time step (true/false)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)   :: qsintveg    !! Amount of water in the canopy interception reservoir 
+                                                                       !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: snow        !! Snow water equivalent  @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in):: snow_nobio  !! Snow water equivalent on nobio areas 
+                                                                       !! @tex ($kg m^{-2}$) @endtex 
+    
+    !! 0.2 Output variables
+    
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: soilwet     !! Mean relative humidity of soil in the grid-cells 
+                                                                       !! (0-1, unitless)
+    
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variabless
+    
+    INTEGER(i_std)                                      :: ji          !! Grid-cell indices (unitless)
+    REAL(r_std)                                         :: watveg      !! Total amount of intercepted water in a grid-cell 
+                                                                       !! @tex ($kg m^{-2}$) @endtex 
+!_ ================================================================================================================================
+
+  !! 1. Initialize water in terrestrial grid-cells at the beginning of the first time step
+
+    !! Initialize the amounts of water in terrestrial grid-cells at the beginning of the first time step, 
+    !! for the three water reservoirs (interception, soil and snow). 
+    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
+    
+  !! 2. We calculate the required variables at the end of each 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
+    
+  !! 3. Transfer the total water amount at the end of the current timestep to the begining of the next one.
+    
+    tot_watveg_beg = tot_watveg_end
+    tot_watsoil_beg = tot_watsoil_end
+    snow_beg(:) = snow_end(:)
+    
+  !! 4. We calculate the mean relative humidity of soil in the grid-cells
+    
+    DO ji = 1,kjpindex
+       soilwet(ji) = tot_watsoil_end(ji) / mx_eau_var(ji)
+    ENDDO
+    
+  END SUBROUTINE hydrolc_alma
+ 
+  
+!! ================================================================================================================================
+!! SUBROUTINE     : hydrolc_hdiff 
+!!
+!>\BRIEF          This subroutine performs horizontal diffusion of water between each PFT/soil column, 
+!! if the flag ok_hdiff is true. 
+!!
+!! DESCRIPTION    : The diffusion is realized on the water contents of both the top and bottom 
+!! soil layers, but the bottom soil layers share the same soil moisture since the end of hydrolc_soil (step 6).
+!! This subroutine thus only modifies the moisture of the top soil layer.
+!!  \latexonly
+!!  \input{hdiff.tex}
+!!  \endlatexonly
+!!
+!! RECENT CHANGE(S) : None
+!!      
+!! MAIN OUTPUT VARIABLE(S) : gqsb, bqsb, dsg, dss, dsp
+!! 
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE hydrolc_hdiff(kjpindex, dtradia, veget, ruu_ch, gqsb, bqsb, dsg, dss, dsp)
+
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT (in)                          :: kjpindex         !! Domain size  (number of grid cells) (unitless)
+    REAL(r_std), INTENT (in)                             :: dtradia          !! Time step duration (s)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: veget            !! Grid-cell fraction effectively covered by 
+                                                                             !! vegetation for each PFT, except for soil 
+                                                                             !! (0-1, unitless) 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: ruu_ch           !! Volumetric soil water capacity 
+                                                                             !! @tex ($kg m^{-3}$) @endtex
+    
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: gqsb             !! Water content in the top layer 
+                                                                             !! @tex ($kg m^{-2}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: bqsb             !! Water content in the bottom layer 
+                                                                             !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: dsg              !! Depth of the top layer (m) 
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: dss              !! Depth of dry soil at the top, whether in the top
+                                                                             !! or bottom layer (m)
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: dsp              !! Depth of dry soil in the bottom layer plus depth
+                                                                             !! of top layer (m)
+    
+    !! 0.4 Local variables
+
+    REAL(r_std), DIMENSION (kjpindex)                    :: bqsb_mean        !! Mean value of bqsb in each grid-cell 
+                                                                             !! @tex ($kg m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION (kjpindex)                    :: gqsb_mean        !! Mean value of gqsb in each grid-cell 
+                                                                             !! @tex ($kg m^{-2}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex)                    :: dss_mean         !! Mean value of dss in each grid-cell (m)
+    REAL(r_std), DIMENSION (kjpindex)                    :: vegtot           !! Total fraction of grid-cell covered by PFTs (bare
+                                                                             !! soil + vegetation) (0-1, unitless) 
+                                                                             ! *** this variable is declared at the module level
+    REAL(r_std)                                          :: x                !! Coefficient of diffusion by time step 
+                                                                             !! (0-1, unitless)
+    INTEGER(i_std)                                       :: ji,jv            !! Indices for grid-cells and PFTs (unitless)
+    REAL(r_std), SAVE                                    :: tau_hdiff        !! Time scale for horizontal water diffusion (s) 
+!$OMP THREADPRIVATE(tau_hdiff)
+    LOGICAL, SAVE                                        :: firstcall=.TRUE. !! Flag to set tau_hdiff at the first time step 
+                                                                             !! ! *** why not define this parameter in 
+                                                                             !! constantes_soil.f90 ?
+!$OMP THREADPRIVATE(firstcall)
+!_ ================================================================================================================================
+
+  !! 1. First time step: we assign a value to the time scale for horizontal water diffusion (in seconds) 
+    
+    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.
+      !Config Units = [seconds]
+      tau_hdiff = one_day   ! 86400 s
+      CALL getin_p('HYDROL_TAU_HDIFF',tau_hdiff)
+
+      WRITE (numout,*) 'Hydrol: Horizontal diffusion, tau (s)=',tau_hdiff
+
+      firstcall = .FALSE.
+
+    ENDIF
+
+  !! 2. We calculate mean values of bqsb, gqsb and dss over the grid-cell ("bio" fraction).
+
+    ! Calculate mean values of bqsb, gqsb and dss over the grid-cell ("bio" fraction)
+    ! This could be done with SUM instruction but this kills vectorization
+    ! *** We compute here vegtot=SUM(veget), but it is already defined at a higher level (declared in the module) ***
+    bqsb_mean(:) = zero
+    gqsb_mean(:) = zero
+    dss_mean(:) = zero
+    vegtot(:) = zero
+    !
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+!MM veget(:,1) BUG ??!!!!!!!!!!!
+           IF (jv .EQ. 1) THEN
+              bqsb_mean(ji) = bqsb_mean(ji) + tot_bare_soil(ji)*bqsb(ji,jv)
+              gqsb_mean(ji) = gqsb_mean(ji) + tot_bare_soil(ji)*gqsb(ji,jv)
+              dss_mean(ji) = dss_mean(ji) + tot_bare_soil(ji)*dss(ji,jv)
+              vegtot(ji) = vegtot(ji) + tot_bare_soil(ji)
+           ELSE
+              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)
+           ENDIF
+      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
+
+  !! 3.  Relax PFT values towards grid-cell mean
+   
+    !! Relax values towards mean : the diffusion is proportional to the deviation to the mean,
+    !!  and inversely proportional to the timescale tau_hdiff
+    !!  We change the moisture of two soil layers, but also the depth of dry in the top soil layer. 
+    !!  Therefore, we need to accordingly adjust the top soil layer depth 
+    !!  and the dry soil depth above the bottom moisture (dsp).
+    ! *** This sequence does not seem to be fully consistent with the variable definitions, 
+    ! *** especially for the dry soil depths dss and dsp:
+    ! *** (i) is the "diffusion" of dss correct is some PFTs only have one soil layer (dss=dsp), 
+    ! *** given that hydrolc_soil acted to merge the bottom soil moistures bqsb
+    ! *** (ii) if gqsb is very small, we let the top layer vanish, but dss is not updated to dsp 
+    !
+    ! *** Also, it would be make much more sense to perform the diffusion in hydrolc_soil, when the 
+    ! *** bottom soil moistures are homogenized. It would benefit from the iterative consistency 
+    ! *** check between the dsg and dsp, and it would prevent from doing some calculations twice. 
+    ! *** Finally, it would be better to keep the water balance calculation for the real end of the 
+    ! *** hydrological processes.
+    !    
+    ! *** FORTUNATELY, the default value of ok_hdiff is false (hydrolc_init.f90)
+    x = MAX( zero, MIN( dtradia/tau_hdiff, un ) )
+    
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+
+        ! *** bqsb does not change as bqsb(ji,jv)=bqsb_mean(ji) since hydrolc_soil, step 6
+        bqsb(ji,jv) = (un-x) * bqsb(ji,jv) + x * bqsb_mean(ji) 
+        gqsb(ji,jv) = (un-x) * gqsb(ji,jv) + x * gqsb_mean(ji)
+
+        ! *** is it meaningful to apply the diffusion equation to dss ?
+        dss(ji,jv) = (un-x) * dss(ji,jv) + x * dss_mean(ji) 
+        
+        IF (gqsb(ji,jv) .LT. min_sechiba) THEN
+          dsg(ji,jv) = zero ! *** in this case, we should also set dss to dsp (defined below)
+        ELSE
+          dsg(ji,jv) = (dss(ji,jv) * ruu_ch(ji) + gqsb(ji,jv)) / ruu_ch(ji)
+        ENDIF
+        dsp(ji,jv) = dpu_max - bqsb(ji,jv) / ruu_ch(ji) ! no change here since bqsb does not change
+
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE hydrolc_hdiff
+  
+END MODULE hydrolc
Index: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/intersurf.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/intersurf.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/intersurf.f90	(revision 7236)
@@ -0,0 +1,8273 @@
+! =================================================================================================================================
+! MODULE       : intersurf
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         This subroutine is the interface between the main program (LMDZ or dim2_driver) and SECHIBA. 
+!!
+!!\n DESCRIPTION:  
+!! - Input fields are gathered to keep just continental points
+!! - call sechiba_main That's SECHIBA process.
+!! - Output fields are scattered to complete global fields
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	:
+!!
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_sechiba/intersurf.f90 $
+!! $Date: 2015-02-22 16:18:16 +0100 (Sun, 22 Feb 2015) $
+!! $Revision: 2555 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE intersurf
+
+  USE IOIPSL
+  USE xios_orchidee
+  USE ioipsl_para 
+  USE defprec
+  USE sechiba
+  USE constantes
+  USE constantes_soil
+  USE pft_parameters
+  USE mod_orchidee_para
+  USE watchout
+  USE solar
+  USE grid
+  USE Orch_Write_field_p
+!  USE thermosoil, ONLY : thermosoil_levels
+!  USE controlr
+  USE vertical_soil
+  IMPLICIT NONE
+
+  PRIVATE
+  PUBLIC :: Init_intersurf, intersurf_main,  intersurf_gathered, stom_define_history, stom_IPCC_define_history, intsurf_time
+
+
+  INTERFACE intersurf_main
+    MODULE PROCEDURE intersurf_main_2d, intersurf_main_1d, intersurf_gathered
+  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
+!$OMP THREADPRIVATE(l_first_intersurf)
+  !
+  INTEGER(i_std), SAVE                               :: hist_id, rest_id        !! IDs for history and restart files
+!$OMP THREADPRIVATE(hist_id, rest_id)
+  INTEGER(i_std), SAVE                               :: hist2_id                !! ID for the second history files (Hi-frequency ?)
+!$OMP THREADPRIVATE(hist2_id)
+  INTEGER(i_std), SAVE                               :: hist_id_stom, hist_id_stom_IPCC, rest_id_stom !! Dito for STOMATE
+!$OMP THREADPRIVATE(hist_id_stom, hist_id_stom_IPCC, rest_id_stom)
+  REAL(r_std), SAVE                                  :: dw                      !! frequency of history write (sec.)
+!$OMP THREADPRIVATE(dw)
+  !
+  INTEGER(i_std), SAVE                               :: itau_offset             !! This offset is used to phase the 
+  !                                                                             !! calendar of the GCM or the driver.
+!$OMP THREADPRIVATE(itau_offset)
+  REAL(r_std), SAVE                                  :: date0_shifted
+!$OMP THREADPRIVATE(date0_shifted)
+  !
+  TYPE(control_type), SAVE                           :: control_flags           !! Flags that (de)activate parts of the model
+!$OMP THREADPRIVATE(control_flags)
+  !
+  !
+
+  REAL(r_std), SAVE                                  :: julian0                 !! first day of this year
+!$OMP THREADPRIVATE(julian0)
+  !
+  LOGICAL, PARAMETER :: check_INPUTS = .FALSE.                                  !! (very) long print of INPUTs in intersurf 
+  LOGICAL, SAVE :: check_time = .false.
+!$OMP THREADPRIVATE(check_time)
+  LOGICAL, SAVE :: impose_param = .TRUE.                                        !! Flag impos_param : should we read all the 
+                                                                                !! parameters in the run.def file ?
+!$OMP THREADPRIVATE(impose_param)
+
+  ! THese next variables are all hacks to get the albedo to print out properly to
+  ! the histwrite when values are zero during the night and we don't want to average
+  ! over zero values.  I do not know where to deallocate these variables.  However,
+  ! that doesn't seem to be a problem for the code since, for example, sechiba_clear
+  ! (which deallocates all the sechiba variables) is never called, either.  So there
+  ! are already memory leaks.
+  REAL(r_std), SAVE, DIMENSION(:,:), ALLOCATABLE     :: albedo_prev             !! The albedo of the previous timestep
+!$OMP THREADPRIVATE(albedo_prev)
+  REAL(r_std), SAVE, DIMENSION(:), ALLOCATABLE       :: sinang_prev             !! The cosine of the solar zenith angle
+                                                                                !! of the previous timestep (1 is noon
+                                                                                !! on the equator; 0 is at night)
+!$OMP THREADPRIVATE(sinang_prev)
+    REAL(r_std), SAVE                                :: sec_old = zero          !! Time counter for to save the old  
+!$OMP THREADPRIVATE(sec_old)
+  REAL(r_std), SAVE, DIMENSION(:,:), ALLOCATABLE     :: albedo_day              !! The albedo of the diurnal cycle that
+                                                                                !! we want to write to the history file.
+                                                                                !! Right now, this is the value at the
+                                                                                !! highest solar zenith angle.
+!$OMP THREADPRIVATE(albedo_day)
+  LOGICAL, SAVE, DIMENSION(:), ALLOCATABLE           :: lmorning                !! A flag to indicate if the think we
+                                                                                !! we are in the morning, local time.
+!$OMP THREADPRIVATE(lmorning)
+  !
+  PUBLIC check_time, l_first_intersurf, impose_param
+  !
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE   : intersurf_main_2d
+!!
+!>\BRIEF         
+!!
+!! DESCRIPTION  : 
+!!                
+!!                
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!! - 
+!!
+!! FLOWCHART    : 
+!_ ================================================================================================================================
+
+  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, &
+! For VOC  radiation  
+     & sinang)
+    ! routines called : sechiba_main
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    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
+    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)             :: sinang          !!
+    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
+
+    !! 0.2 Output variables
+
+    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
+
+    !! 0.4 Local variables
+
+    ! 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)                        :: zsinang         !! Work array to keep sinang
+    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)                        :: znetco2         !! Work array to keep netco2flux
+    REAL(r_std), DIMENSION(kjpindex)                        :: zcarblu         !! Work array to keep fco2_land_use
+    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
+    REAL(r_std),ALLOCATABLE, DIMENSION (:)                :: soilth_lev    !! Vertical soil axis for thermal scheme (m)
+    !
+    INTEGER(i_std)                                          :: i, j, ik, ier, ikjp   !!
+    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 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_mpi(lon,lon_g)
+       CALL gather2D_mpi(lat,lat_g)
+       CALL gather2D_mpi(zlev,zlev_g)
+       !
+       !  Configuration of SSL specific parameters
+       !
+! tzjsf
+!       CALL controlr_initialize(xrdt)
+       CALL intsurf_config(control_flags, xrdt)
+       !
+       CALL intsurf_restart(kjit, date0, xrdt, control_flags, rest_id, rest_id_stom, itau_offset)
+       itau_sechiba = kjit + itau_offset
+       !
+
+
+       !!- Initialize module for output with XIOS
+       !
+       ! Get the vertical soil levels for the thermal scheme, to be used in xios_orchidee_init
+       ! Get the vertical soil levels for the thermal scheme, to be used in xios_orchidee_init
+       ALLOCATE(soilth_lev(ngrnd), stat=ier)
+       IF (ier /= 0) THEN
+          CALL ipslerr_p(3,'intersurf_main_2d', 'Error in allocation of soilth_lev','','')
+       END IF
+!       soilth_lev(1:ngrnd) = thermosoil_levels()
+!    IF (hydrol_cwrr) THEN
+       soilth_lev(1:ngrnd) = znt(:)
+!    ELSE
+!       soilth_lev(1:ngrnd) = thermosoilc_levels()
+!    END IF
+       
+       CALL xios_orchidee_init( MPI_COMM_ORCH,                &
+            date0,    year,    month,           day,          &
+            lon,      lat,     soilth_lev,      control_flags )
+
+       !- Initialize IOIPSL output files
+       CALL intsurf_history(iim, jjm, lon, lat,  kindex, kjpindex, 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
+       !
+       ! There is a problem when the albedo is written to the history file.
+       ! It is averaged over all timesteps in the day.  However, some albedo
+       ! types calculate albedo values based on the solar angle, and give
+       ! values of zero for nighttime.  This gives an incorrect value when
+       ! written to the history file.  We attempt to correct for that by saving
+       ! the value of the sinang and the albedo of the previous timestep.  If the
+       ! sinang for this timestep is lower, that means we have just passed solar
+       ! noon, we write the albedo value of the previous timestep to the history
+       ! file.  Otherwise, we write nothing to the history file.
+       ALLOCATE(albedo_prev(kjpindex,2),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in albedo_prev allocation. We stop. We need kjpindex*2 words = ',&
+               kjpindex*2
+          CALL ipslerr_p (3,'intersurf','intersurf','','')
+       ENDIF
+       ALLOCATE(albedo_day(kjpindex,2),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in albedo_day allocation. We stop. We need kjpindex*2 words = ',&
+               kjpindex*2
+          CALL ipslerr_p (3,'intersurf','intersurf','','')
+       ENDIF
+       ALLOCATE(sinang_prev(kjpindex),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in sinang_prev allocation. We stop. We need kjpindex words = ',&
+               kjpindex
+          CALL ipslerr_p (3,'intersurf','intersurf','','')
+       ENDIF
+       ALLOCATE(lmorning(kjpindex),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in lmorning allocation. We stop. We need kjpindex words = ',&
+               kjpindex
+          CALL ipslerr_p (3,'intersurf','intersurf','','')
+       ENDIF
+       ! Set them to their nighttime values.
+       sinang_prev(:)=zero
+       albedo_prev(:,:)=zero
+       albedo_day(:,:)=zero
+       lmorning(:)=.FALSE.
+
+       IF ( check ) WRITE(numout,*) 'End of Initialisation of intersurf'
+       !
+    ENDIF
+
+    !
+    !  Shift the time step to phase the two models
+    !
+    itau_sechiba = kjit + itau_offset
+    !
+
+    ! Update the calendar in xios by sending the new time step
+    IF (l_first_intersurf) THEN
+       ! Special case : the model is only in initialization phase and the current itau_sechiba is not a real time step. 
+       ! Therefor give itau_sechiba+1 to xios to have a correct time axis in output files. 
+       CALL xios_orchidee_update_calendar(itau_sechiba+1)
+    ELSE
+       CALL xios_orchidee_update_calendar(itau_sechiba)
+    ENDIF
+
+    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*precip_bias_correct
+       zprecip_snow(ik) = precip_snow(i,j)*xrdt
+       zlwdown(ik)      = lwdown(i,j)
+       zswnet(ik)       = swnet(i,j)
+       zswdown(ik)      = swdown(i,j)
+       zsinang(ik)      = sinang(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_p(hist_id, 'LandPoints',  itau_sechiba+1, (/ ( REAL(ik), ik=1,kjpindex ) /), kjpindex, kindex)
+       CALL histwrite_p(hist_id, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+       IF ( control_flags%ok_stomate ) THEN
+          CALL histwrite_p(hist_id_stom, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+          CALL histwrite_p(hist_id_stom_IPCC, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+       ENDIF
+
+       CALL histwrite_p(hist_id, 'Contfrac',  itau_sechiba+1, contfrac, kjpindex, kindex)
+       IF ( is_omp_root .AND. hist_id > 0 ) THEN
+          CALL histsync(hist_id)
+       END IF
+
+       CALL histwrite_p(hist2_id, 'LandPoints',  itau_sechiba+1, (/ ( REAL(ik), ik=1,kjpindex ) /), kjpindex, kindex)
+       CALL histwrite_p(hist2_id, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+       CALL histwrite_p(hist2_id, 'Contfrac',  itau_sechiba+1, contfrac, kjpindex, kindex)
+       IF ( is_omp_root .AND. hist2_id > 0 ) THEN
+          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, zsinang, zpb, &
+! Output : Fluxes
+       & zvevapp, zfluxsens, zfluxlat, zcoastal, zriver, znetco2, zcarblu, &
+! 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 
+    !
+    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)/mille
+       riverflow(i,j)    = zriver(ik)/mille
+       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)
+
+    ENDDO
+    !
+    ! Modified fields for variables scattered during the writing
+    !
+
+    dcoastal(:) = (zcoastal(:))/mille     
+    driver(:)   = (zriver(:))/mille
+
+    ! The albedo has become a special case, since values are not calculated
+    ! at night.  Therefore, we do not want to average over the whole day.  However,
+    ! we cannot just check to see for which points it is daytime and write those,
+    ! since we have to pass the whole block of points to histwrite at the same time.
+    ! Therefore, we write the values we want to a different array and then only
+    ! write out the array at the end of the day to the histwrite.  We also cannot
+    ! just write the daily maximum value, since the maximum may occur at sunrise
+    ! or sunset, depending on the wavelength.
+    DO ikjp=1,kjpindex
+       !  Check to see if we're in the morning.
+       IF( .NOT. lmorning(ikjp))THEN
+          IF(zsinang(ikjp) .GT. sinang_prev(ikjp))THEN
+             lmorning(ikjp)=.TRUE.
+          ENDIF
+       ENDIF
+       ! If our SZA is lower than the previous timestep,  and we were in the
+       ! morning, we have just passed
+       ! the solar noon.  Therefore, we save the previous value.
+       IF((zsinang(ikjp) .LT. sinang_prev(ikjp)) .AND. lmorning(ikjp))THEN
+          albedo_day(ikjp,:)=albedo_prev(ikjp,:)
+          ! It is no longer morning.
+          lmorning(ikjp)=.FALSE.
+       ENDIF
+    ENDDO
+    ! Save the current values of the albedo and the solar angle.
+    sinang_prev(:)=zsinang(:)
+    albedo_prev(:,:)=zalbedo(:,:)
+
+    IF ( .NOT. l_first_intersurf) THEN
+       
+       CALL xios_orchidee_send_field("LandPoints" ,(/ ( REAL(ik), ik=1,kjpindex ) /))
+       CALL xios_orchidee_send_field("Areas", area)
+       CALL xios_orchidee_send_field("Contfrac",contfrac)
+       CALL xios_orchidee_send_field("evap",zvevapp*one_day/dt_sechiba)
+       
+       CALL xios_orchidee_send_field("evap_alma",zvevapp/dt_sechiba)
+       CALL xios_orchidee_send_field("coastalflow",dcoastal/dt_sechiba)
+       CALL xios_orchidee_send_field("riverflow",driver/dt_sechiba)
+       CALL xios_orchidee_send_field("temp_sol_C",ztemp_sol_new-ZeroCelsius)
+       CALL xios_orchidee_send_field("temp_sol_K",ztemp_sol_new)
+       CALL xios_orchidee_send_field("fluxsens",zfluxsens)
+       CALL xios_orchidee_send_field("fluxlat",zfluxlat)
+       CALL xios_orchidee_send_field("alb_vis",zalbedo(:,1))
+       CALL xios_orchidee_send_field("alb_nir",zalbedo(:,2))
+       CALL xios_orchidee_send_field("tair",ztemp_air)
+       CALL xios_orchidee_send_field("qair",zqair)
+       CALL xios_orchidee_send_field("q2m",zqair)
+       CALL xios_orchidee_send_field("t2m",ztemp_air)
+       CALL xios_orchidee_send_field("swnet",zswnet)
+       CALL xios_orchidee_send_field("swdown",zswdown)
+       
+       IF ( .NOT. almaoutput ) THEN
+       !
+       !  scattered during the writing
+       ! 
+          CALL histwrite_p (hist_id, 'evap',     itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'temp_sol', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'tsol_max', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'tsol_min', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'fluxsens', itau_sechiba, zfluxsens, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'fluxlat',  itau_sechiba, zfluxlat, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'swnet',    itau_sechiba, zswnet, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'swdown',   itau_sechiba, zswdown, kjpindex, kindex)
+          ! Something special for albedo values, since we do not want to average
+          ! over the nightly values (which are zero and not used).  Since we only
+          ! write once a day, we do not need to normalize the value by anything.
+          ! The value printed at this one timestep is the value which appears
+          ! in the history file.
+          IF ( sec_old >= one_day - xrdt .AND.  sec >= zero ) THEN
+             CALL histwrite_p (hist_id, 'alb_vis',  itau_sechiba, albedo_day(:,1), kjpindex, kindex)
+             CALL histwrite_p (hist_id, 'alb_nir',  itau_sechiba, albedo_day(:,2), kjpindex, kindex)
+          ENDIF
+          CALL histwrite_p (hist_id, 'tair',     itau_sechiba, ztemp_air, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'qair',     itau_sechiba, zqair, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'q2m',     itau_sechiba, zqair, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 't2m',     itau_sechiba, ztemp_air, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'evap',     itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'temp_sol', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'tsol_max', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'tsol_min', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'fluxsens', itau_sechiba, zfluxsens, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'fluxlat',  itau_sechiba, zfluxlat, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'swnet',    itau_sechiba, zswnet, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'swdown',   itau_sechiba, zswdown, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'alb_vis',  itau_sechiba, zalbedo(:,1), kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'alb_nir',  itau_sechiba, zalbedo(:,2), kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'tair',     itau_sechiba, ztemp_air, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'qair',     itau_sechiba, zqair, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'q2m',     itau_sechiba, zqair, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 't2m',     itau_sechiba, ztemp_air, kjpindex, kindex)
+
+       ELSE
+          CALL histwrite_p (hist_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'SWnet',    itau_sechiba, zswnet, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'Qh', itau_sechiba, zfluxsens, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'Qle',  itau_sechiba, zfluxlat, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'AvgSurfT', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'RadT', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'Tair', itau_sechiba, ztemp_air, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'Qair', itau_sechiba, zqair, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'SWnet',    itau_sechiba, zswnet, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'Qh', itau_sechiba, zfluxsens, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'Qle',  itau_sechiba, zfluxlat, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'AvgSurfT', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'RadT', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+       ENDIF
+       !
+       IF ( is_omp_root ) THEN
+          IF ( (dw .EQ. xrdt) .AND. hist_id > 0 ) THEN
+             CALL histsync(hist_id)
+          ENDIF
+       END IF
+    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
+    !
+    ! Uncomment those lines to test all parallel getin in developments
+!    IF(l_first_intersurf) THEN
+!       CALL ipsldbg (new_status=.TRUE.)
+!       CALL getin_dump_para("test",mpi_rank) 
+!       CALL ipsldbg (new_status=.FALSE.)
+!    ENDIF
+    IF(l_first_intersurf .AND. is_root_prc) CALL getin_dump
+    ! 
+    l_first_intersurf = .FALSE.
+    !
+    ! Reset old time counter to the new value
+    sec_old = sec
+
+    IF (long_print) WRITE (numout,*) ' intersurf_main done '
+    !
+    CALL ipslnlf(new_number=old_fileout)
+
+!
+  END SUBROUTINE intersurf_main_2d
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : intersurf_main_1d
+!!
+!>\BRIEF         
+!!
+!! DESCRIPTION  : 
+!!                
+!!                
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!! - 
+!!
+!! FLOWCHART    : 
+!_ ================================================================================================================================
+
+  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, &
+! For VOC  radiation  
+    & sinang)    
+    ! routines called : sechiba_main
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    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
+    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)             :: sinang        !! 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
+
+    !! 0.2 Output variables
+
+    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
+
+    !! 0.4 Local variables
+
+    ! 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)                        :: zsinang       !! Work array to keep sinang
+    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)                        :: znetco2       !! Work array to keep netco2flux
+    REAL(r_std), DIMENSION(kjpindex)                        :: zcarblu       !! Work array to keep fco2_land_use
+    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
+    REAL(r_std),ALLOCATABLE, DIMENSION (:)                :: soilth_lev    !! Vertical soil axis for thermal scheme (m)
+    !
+    INTEGER(i_std)                                          :: i, j, ik, ier !!
+    INTEGER(i_std)                                          :: itau_sechiba  !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)                :: tmp_lon       !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)                :: tmp_lat       !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)                :: 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'
+       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
+       !
+! tzjsf
+!       CALL controlr_initialize(xrdt)
+
+       CALL intsurf_config(control_flags, xrdt)
+       !
+       CALL intsurf_restart(kjit, date0, xrdt, control_flags, rest_id, rest_id_stom, itau_offset)
+       itau_sechiba = kjit + itau_offset
+       !
+
+
+       !!- Initialize module for output with XIOS
+       !
+       ! Get the vertical soil levels for the thermal scheme, to be used in xios_orchidee_init
+       ALLOCATE(soilth_lev(ngrnd), stat=ier)
+       IF (ier /= 0) THEN
+          CALL ipslerr_p(3,'intersurf_main_1d', 'Error in allocation of soilth_lev','','')
+       END IF
+!       soilth_lev(1:ngrnd) = thermosoil_levels()
+!    IF (hydrol_cwrr) THEN
+       soilth_lev(1:ngrnd) = znt(:)
+!    ELSE
+!       soilth_lev(1:ngrnd) = thermosoilc_levels()
+!    END IF
+       
+       CALL xios_orchidee_init( MPI_COMM_ORCH,               &
+            date0,    year,    month,          day,          &
+            tmp_lon,  tmp_lat, soilth_lev,     control_flags )
+
+       !- Initialize IOIPSL output files
+       CALL intsurf_history(iim, jjm, tmp_lon, tmp_lat,  kindex, kjpindex, 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
+    
+    ! Update the calendar in xios by sending the new time step
+    IF (l_first_intersurf) THEN
+       ! Special case : the model is only in initialization phase and the current itau_sechiba is not a real time step. 
+       ! Therefor give itau_sechiba+1 to xios to have a correct time axis in output files. 
+       CALL xios_orchidee_update_calendar(itau_sechiba+1)
+    ELSE
+       CALL xios_orchidee_update_calendar(itau_sechiba)
+    ENDIF
+
+    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*precip_bias_correct
+       zprecip_snow(ik) = precip_snow(kindex(ik))*xrdt
+       zlwdown(ik)      = lwdown(kindex(ik))
+       zswnet(ik)       = swnet(kindex(ik))
+       zswdown(ik)      = swdown(kindex(ik))
+       zsinang(ik)      = sinang(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_p(hist_id, 'LandPoints',  itau_sechiba+1, (/ REAL(kindex) /), kjpindex, kindex)
+       CALL histwrite_p(hist_id, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+       
+       IF ( control_flags%ok_stomate ) THEN
+          CALL histwrite_p(hist_id_stom, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+          CALL histwrite_p(hist_id_stom_IPCC, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+       ENDIF
+       
+       CALL histwrite_p(hist_id, 'Contfrac',  itau_sechiba+1, contfrac, kjpindex, kindex)
+       IF ( is_omp_root .AND. hist_id > 0 ) THEN
+          CALL histsync(hist_id)
+       END IF
+       
+
+       CALL histwrite_p(hist2_id, 'LandPoints',  itau_sechiba+1, (/ REAL(kindex) /), kjpindex, kindex)
+       CALL histwrite_p(hist2_id, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+       CALL histwrite_p(hist2_id, 'Contfrac',  itau_sechiba+1, contfrac, kjpindex, kindex)
+       IF ( is_omp_root .AND. hist2_id > 0 ) THEN
+          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, zsinang, zpb, &
+! Output : Fluxes
+       & zvevapp, zfluxsens, zfluxlat, zcoastal, zriver, znetco2, zcarblu, &
+! 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 
+    !
+    DO ik=1, kjpindex
+       
+       z0(kindex(ik))           = zz0(ik)
+       coastalflow(kindex(ik))  = zcoastal(ik)/mille
+       riverflow(kindex(ik))    = zriver(ik)/mille
+       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)
+
+    ENDDO
+    !
+    ! Modified fields for variables scattered during the writing
+    !
+    dcoastal(:) = (zcoastal(:))/mille
+    driver(:)   = (zriver(:))/mille
+    !
+    IF ( .NOT. l_first_intersurf) THEN
+       
+       CALL xios_orchidee_send_field("LandPoints" ,(/ ( REAL(ik), ik=1,kjpindex ) /))
+       CALL xios_orchidee_send_field("Areas", area)
+       CALL xios_orchidee_send_field("Contfrac",contfrac)
+       CALL xios_orchidee_send_field("evap",zvevapp*one_day/dt_sechiba)
+       CALL xios_orchidee_send_field("evap_alma",zvevapp/dt_sechiba)
+       CALL xios_orchidee_send_field("coastalflow",dcoastal/dt_sechiba)
+       CALL xios_orchidee_send_field("riverflow",driver/dt_sechiba)
+       CALL xios_orchidee_send_field("temp_sol_C",ztemp_sol_new-ZeroCelsius)
+       CALL xios_orchidee_send_field("temp_sol_K",ztemp_sol_new)
+       CALL xios_orchidee_send_field("fluxsens",zfluxsens)
+       CALL xios_orchidee_send_field("fluxlat",zfluxlat)
+       CALL xios_orchidee_send_field("alb_vis",zalbedo(:,1))
+       CALL xios_orchidee_send_field("alb_nir",zalbedo(:,2))
+       CALL xios_orchidee_send_field("tair",ztemp_air)
+       CALL xios_orchidee_send_field("qair",zqair)
+       CALL xios_orchidee_send_field("q2m",zqair)
+       CALL xios_orchidee_send_field("t2m",ztemp_air)
+       CALL xios_orchidee_send_field("swnet",zswnet)
+       CALL xios_orchidee_send_field("swdown",zswdown)
+
+       IF ( .NOT. almaoutput ) THEN
+          !
+          !  scattered during the writing
+          !
+          CALL histwrite_p (hist_id, 'evap',     itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'temp_sol', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'tsol_max', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'tsol_min', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'fluxsens', itau_sechiba, zfluxsens, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'fluxlat',  itau_sechiba, zfluxlat, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'swnet',    itau_sechiba, zswnet, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'swdown',   itau_sechiba, zswdown, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'alb_vis',  itau_sechiba, zalbedo(:,1), kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'alb_nir',  itau_sechiba, zalbedo(:,2), kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'tair',     itau_sechiba, ztemp_air, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'qair',     itau_sechiba, zqair, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'q2m',     itau_sechiba, zqair, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 't2m',     itau_sechiba, ztemp_air, kjpindex, kindex)
+       
+          CALL histwrite_p (hist2_id, 'evap',     itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'temp_sol', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'tsol_max', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'tsol_min', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'fluxsens', itau_sechiba, zfluxsens, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'fluxlat',  itau_sechiba, zfluxlat, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'swnet',    itau_sechiba, zswnet, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'swdown',   itau_sechiba, zswdown, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'alb_vis',  itau_sechiba, zalbedo(:,1), kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'alb_nir',  itau_sechiba, zalbedo(:,2), kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'tair',     itau_sechiba, ztemp_air, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'qair',     itau_sechiba, zqair, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'q2m',     itau_sechiba, zqair, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 't2m',     itau_sechiba, ztemp_air, kjpindex, kindex)
+       
+       ELSE
+          CALL histwrite_p (hist_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'SWnet',    itau_sechiba, zswnet, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'Qh', itau_sechiba, zfluxsens, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'Qle',  itau_sechiba, zfluxlat, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'AvgSurfT', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'RadT', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'Tair', itau_sechiba, ztemp_air, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'Qair', itau_sechiba, zqair, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'SWnet',    itau_sechiba, zswnet, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'Qh', itau_sechiba, zfluxsens, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'Qle',  itau_sechiba, zfluxlat, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'AvgSurfT', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+          CALL histwrite_p (hist2_id, 'RadT', itau_sechiba, ztemp_sol_NEW, kjpindex, kindex)
+       ENDIF
+       !
+       IF ( is_omp_root ) THEN
+          IF ( (dw .EQ. xrdt) .AND. hist_id > 0 ) THEN
+             CALL histsync(hist_id)
+          ENDIF
+       END IF
+   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
+
+!! ================================================================================================================================
+!! SUBROUTINE   : Init_intersurf
+!!
+!>\BRIEF         
+!!
+!! DESCRIPTION  : 
+!!                
+!!                
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!! - 
+!!
+!! FLOWCHART    : 
+!_ ================================================================================================================================
+
+  SUBROUTINE Init_intersurf(nbp_l_lon,nbp_l_lat,kjpindex,kindex,orch_offset,orch_omp_size,orch_omp_rank,COMM)
+
+    ! This subroutine is called from LMDZ before first call to ORCHIDEE intersurf_main
+
+    USE mod_orchidee_para
+    USE timer
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    INTEGER, INTENT(in)  :: nbp_l_lon                !!
+    INTEGER, INTENT(in)  :: nbp_l_lat                !! 
+    INTEGER, INTENT(in)  :: kjpindex                 !!  
+    INTEGER, INTENT(in)  :: kindex(:)                !!
+    INTEGER, INTENT(in)  :: orch_offset              !!
+    INTEGER, INTENT(in)  :: COMM                     !!
+    INTEGER, INTENT(in)  :: orch_omp_size            !!
+    INTEGER, INTENT(in)  :: orch_omp_rank            !!
+
+    !! 0.4 Local variables
+
+    INTEGER, DIMENSION(kjpindex)  :: kindex_offset   !!
+
+!_ ================================================================================================================================
+
+    IF (orch_omp_rank==0) THEN
+      CALL Init_timer
+      CALL start_timer(timer_mpi)
+      CALL set_grid_glo(nbp_l_lon,nbp_l_lat)
+    ENDIF
+    CALL barrier2_omp()    
+    CALL init_orchidee_data_para(kjpindex,kindex,orch_offset,orch_omp_size,orch_omp_rank,COMM)
+    CALL Set_stdout_file('out_orchidee')
+    
+    IF (is_omp_root) CALL Allocate_grid_glo
+    CALL barrier2_omp()
+    CALL init_ioipsl_para
+          
+    kindex_offset(:)=kindex(:)+offset
+    CALL gather(kindex_offset,index_g)
+    CALL bcast(index_g)  
+
+    WRITE(numout,*) "kjpindex = ",kjpindex
+    WRITE(numout,*) "offset for OMP = ",offset_omp
+    WRITE(numout,*) "Index num local for continental points = ",kindex
+    WRITE(numout,*) "Index num global for continental points = ",kindex_offset
+    IF (is_omp_root) THEN
+       WRITE(numout,*) "ROOT OMP, Index global MPI : ",kindex_mpi(:)
+    ENDIF
+    IF (is_root_prc) THEN
+       WRITE(numout,*) "ROOT global, Index global : ",index_g(:)
+    ENDIF
+    
+  END SUBROUTINE Init_intersurf
+!
+
+!! ================================================================================================================================
+!! SUBROUTINE   : intersurf_gathered
+!!
+!>\BRIEF         
+!!
+!! DESCRIPTION  : 
+!!                
+!!                
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!! - 
+!!
+!! FLOWCHART    : 
+!_ ================================================================================================================================
+
+  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, q2m, t2m, &
+! Add emission/deposit fields
+     & field_out_names, fields_out, field_in_names, fields_in, &
+! For VOC
+     & sinang)  
+    ! routines called : sechiba_main
+
+    USE mod_orchidee_para
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                              :: kjit          !! Time step number
+    INTEGER(i_std), INTENT(in)                              :: iim_glo, jjm_glo  !! Dimension of global 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
+    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
+    REAL(r_std), DIMENSION(iim_glo,jjm_glo), INTENT(in)     :: lon_scat_g    !! The scattered values for longitude 
+    REAL(r_std), DIMENSION(iim_glo,jjm_glo), INTENT(in)     :: lat_scat_g    !! The scattered values for latitude
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in), OPTIONAL  :: q2m           !! Surface specific humidity
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in), OPTIONAL  :: t2m           !! Surface air temperature
+    CHARACTER(LEN=*), DIMENSION(:), INTENT(in), OPTIONAL    :: field_out_names !! Names and fields for emission variables :
+                                                                               !! to be transport by GCM to chemistry model.
+    CHARACTER(LEN=*), DIMENSION(:), INTENT(in), OPTIONAL    :: field_in_names  !! Names and fields for deposit variables : 
+                                                                               !! to be transport from chemistry model by GCM to ORCHIDEE.
+    REAL(r_std), DIMENSION(:,:), INTENT(in), OPTIONAL       :: fields_in     !!
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in), OPTIONAL  :: sinang        !! For VOC 
+
+    !! 0.2 Output variables
+
+    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
+    REAL(r_std), DIMENSION(:,:), INTENT(out), OPTIONAL      :: fields_out    !!
+
+
+    !! 0.4 Local variables
+
+    ! 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)                        :: znetco2       !! Work array to keep netco2flux
+    REAL(r_std), DIMENSION(kjpindex)                        :: zcarblu       !! Work array to keep fco2_land_use
+    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
+    REAL(r_std), DIMENSION(kjpindex)                        :: zsinang       !! Work array to keep sinang
+    REAL(r_std),ALLOCATABLE, DIMENSION (:)                :: soilth_lev    !! Vertical soil axis for thermal scheme (m)
+    !
+    REAL(r_std), DIMENSION(:,:) ,ALLOCATABLE                :: lon_scat      !! The scattered values for longitude 
+    REAL(r_std), DIMENSION(:,:) ,ALLOCATABLE                :: lat_scat      !! The scattered values for latitude
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)               :: dtemp_sol     !! for surface temperature
+!$OMP THREADPRIVATE(dtemp_sol)
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)               :: dfluxsens     !! for sensible heat flux
+!$OMP THREADPRIVATE(dfluxsens)
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)               :: dfluxlat      !! for latent heat flux
+!$OMP THREADPRIVATE(dfluxlat)
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)               :: dswnet        !! net solar radiation
+!$OMP THREADPRIVATE(dswnet)
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)               :: dswdown       !! Incident solar radiation
+!$OMP THREADPRIVATE(dswdown)
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)             :: dalbedo       !! albedo
+!$OMP THREADPRIVATE(dalbedo)
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)               :: dtair         !! air temperature
+!$OMP THREADPRIVATE(dtair)
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)               :: dqair         !! specific air humidity
+!$OMP THREADPRIVATE(dqair)
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)               :: dq2m          !! Surface specific humidity
+!$OMP THREADPRIVATE(dq2m)
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)               :: dt2m          !! Surface air temperature
+!$OMP THREADPRIVATE(dt2m)
+    !
+    INTEGER(i_std)                                          :: i, j, ik, ier, ikjp !!
+    INTEGER(i_std)                                          :: itau_sechiba  !!
+    REAL(r_std)                                             :: mx, zlev_mean !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)                :: tmp_lon       !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)                :: tmp_lat       !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)                :: tmp_lev       !!
+    LOGICAL                                                 :: do_watch      !! if it's time, write watchout
+    INTEGER(i_std)                                          :: old_fileout   !! old Logical Int for std IO output
+    LOGICAL                                                 :: check = .FALSE.!!
+    LOGICAL, SAVE                                           :: fatmco2       !! Flag to force the value of atmospheric CO2 for vegetation.
+!$OMP THREADPRIVATE(fatmco2)
+    REAL(r_std), SAVE                                       :: atmco2        !! atmospheric CO2 
+!$OMP THREADPRIVATE(atmco2)
+    LOGICAL, SAVE                                           :: ok_q2m_t2m    !!
+!$OMP THREADPRIVATE(ok_q2m_t2m)
+    !
+    INTEGER(i_std), SAVE                                    :: nb_fields_out !! Number of fields to give GCM
+!$OMP THREADPRIVATE(nb_fields_out)
+    INTEGER(i_std), SAVE                                    :: nb_fields_in  !! Number of fields to get from GCM
+!$OMP THREADPRIVATE(nb_fields_in)
+    ! 
+    INTEGER(i_std)                                          :: i_fields_out  !! Id of fields to give (nb_fields_out) GCM 
+    INTEGER(i_std)                                          :: i_fields_in   !! Id of fields to get from (nb_fields_in) GCM 
+    REAL, ALLOCATABLE, DIMENSION(:,:)                       :: lalo_mpi      !!
+    REAL, ALLOCATABLE, DIMENSION(:)                         :: zlev_glo1D    !! 
+    REAL(r_std), DIMENSION(kjpindex)                        :: landpoints    !! Local landpoints vector
+
+!_ ================================================================================================================================
+
+    IF(.NOT. PRESENT(sinang))THEN
+       CALL ipslerr_p (3,'intersurf',&
+            'The new albedo needs sinang to proceed!','','')
+    ENDIF
+
+    IF(ld_coupled)THEN
+       DO i=1,kjpindex
+          WRITE(numout,'(A,I5,2X,I5,4F20.10)') 'intersurf cdrag ',i,kjit,cdrag(i),latlon(i,:)
+          CALL ipslerr_p (3,'intersurf','intersurf cdrag','','')
+       ENDDO
+    ENDIF
+
+    CALL ipslnlf_p(old_number=old_fileout)
+    CALL ipslnlf_p(new_number=numout)
+    !
+    IF (l_first_intersurf) THEN
+       ! Test sur la presence de q2m et t2m
+       IF (PRESENT(q2m) .AND. PRESENT(t2m)) THEN
+         ok_q2m_t2m=.TRUE.
+       ELSE
+         ok_q2m_t2m=.FALSE.
+       ENDIF
+
+       CALL intsurf_time( kjit, date0, xrdt )
+
+       IF ( check ) WRITE(numout,*) 'Initialisation of intersurf'
+       WRITE(numout,*) 'Initialisation of intersurf gathered'       !
+
+       CALL ioget_calendar (one_year, one_day)
+
+       IF (is_omp_root) THEN
+          ALLOCATE(lon_scat(iim_g,jj_nb))
+          ALLOCATE(lat_scat(iim_g,jj_nb))
+       ELSE
+          ALLOCATE(lon_scat(1,1))
+          ALLOCATE(lat_scat(1,1))
+       ENDIF
+
+       ALLOCATE(dtemp_sol(kjpindex))
+       ALLOCATE(dfluxsens(kjpindex))
+       ALLOCATE(dfluxlat(kjpindex))
+       ALLOCATE(dswnet(kjpindex))
+       ALLOCATE(dswdown(kjpindex))
+       ALLOCATE(dalbedo(kjpindex,2))
+       ALLOCATE(dtair(kjpindex))
+       ALLOCATE(dqair(kjpindex)) 
+
+       IF (ok_q2m_t2m) THEN
+          ALLOCATE(dq2m(kjpindex))
+          ALLOCATE(dt2m(kjpindex))
+       ENDIF
+
+       CALL init_WriteField_p
+       !
+       ! 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_g,jj_nb))
+       ENDIF
+       IF ( (.NOT.ALLOCATED(tmp_lat))) THEN
+          ALLOCATE(tmp_lat(iim_g,jj_nb))
+       ENDIF
+       IF ( (.NOT.ALLOCATED(tmp_lev))) THEN
+          ALLOCATE(tmp_lev(iim_g,jj_nb))
+       ENDIF
+       !
+       !  Either we have the scattered coordinates as arguments or
+       !  we have to do the work here.
+       !
+       IF (is_omp_root) THEN
+          lon_scat(:,:)=zero
+          lat_scat(:,:)=zero 
+          CALL scatter2D_mpi(lon_scat_g,lon_scat)
+          CALL scatter2D_mpi(lat_scat_g,lat_scat)
+          lon_scat(:,1)=lon_scat(:,2)
+          lon_scat(:,jj_nb)=lon_scat(:,2)
+          lat_scat(:,1)=lat_scat(iim_g,1)
+          lat_scat(:,jj_nb)=lat_scat(1,jj_nb)
+          
+          tmp_lon(:,:) = lon_scat(:,:)
+          tmp_lat(:,:) = lat_scat(:,:)
+          
+          IF (is_mpi_root) THEN
+             lon_g(:,:) = lon_scat_g(:,:)
+             lat_g(:,:) = lat_scat_g(:,:)
+          ENDIF
+       ENDIF
+       !
+
+!ANNE ici possibilite de calculer la grille du modele ? (lignes 965 ??
+       
+
+!ANNE calcul zlev, conserve la version de Martial
+       IF (is_root_prc) ALLOCATE(zlev_glo1D(nbp_glo))
+       CALL gather(zlev,zlev_glo1D)
+       
+       IF (is_root_prc) THEN
+          DO ik=1, nbp_glo
+             j = INT( (index_g(ik)-1) / iim_g ) + 1
+             i = index_g(ik) - (j-1) * iim_g
+             zlev_g(i,j) = zlev_glo1D(ik)
+          ENDDO
+       ENDIF  
+       !
+       !
+       !  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=296.
+          CALL getin_p('ATM_CO2',atmco2)
+          WRITE(numout,*) 'atmco2 ',atmco2
+       ENDIF
+       
+       !
+       CALL intsurf_restart(kjit, date0, xrdt, control_flags, rest_id, rest_id_stom, itau_offset)
+       itau_sechiba = kjit + itau_offset
+       !
+
+       !!- Initialize module for output with XIOS
+       !
+       ! Get the vertical soil levels for the thermal scheme, to be used in xios_orchidee_init
+       ALLOCATE(soilth_lev(ngrnd), stat=ier)
+       IF (ier /= 0) THEN
+          CALL ipslerr_p(3,'intersurf_gathered', 'Error in allocation of soilth_lev','','')
+       END IF
+       !soilth_lev(1:ngrnd) = thermosoil_levels()
+!    IF (hydrol_cwrr) THEN
+       soilth_lev(1:ngrnd) = znt(:)
+!    ELSE
+!       soilth_lev(1:ngrnd) = thermosoilc_levels()
+!    END IF
+       
+       CALL xios_orchidee_init( MPI_COMM_ORCH,               &
+            date0,    year,    month,          day,          &
+            tmp_lon,  tmp_lat, soilth_lev,     control_flags )
+       
+       !- Initialize IOIPSL output files
+       CALL intsurf_history(iim_g, jj_nb, tmp_lon, tmp_lat,  kindex, kjpindex, itau_sechiba, &
+ &                          date0_shifted, xrdt, control_flags, hist_id, hist2_id, hist_id_stom, hist_id_stom_IPCC)
+       !
+
+       CALL bcast_omp(hist_id)
+       CALL bcast_omp(hist2_id)
+       CALL bcast_omp(hist_id_stom)
+       CALL bcast_omp(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
+          IF (is_root_prc) &
+               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
+
+       ! Prepare fieds out/in for interface with GCM.
+       IF (PRESENT(field_out_names)) THEN
+          nb_fields_out=SIZE(field_out_names)
+       ELSE
+          nb_fields_out=0
+       ENDIF
+       IF (PRESENT(field_in_names)) THEN
+          nb_fields_in=SIZE(field_in_names)
+       ELSE
+          nb_fields_in=0
+       ENDIF
+
+       !
+       ! There is a problem when the albedo is written to the history file.
+       ! It is averaged over all timesteps in the day.  However, some albedo
+       ! types calculate albedo values based on the solar angle, and give
+       ! values of zero for nighttime.  This gives an incorrect value when
+       ! written to the history file.  We attempt to correct for that by saving
+       ! the value of the sinang and the albedo of the previous timestep.  If the
+       ! sinang for this timestep is lower, that means we have just passed solar
+       ! noon, we write the albedo value of the previous timestep to the history
+       ! file.  Otherwise, we write nothing to the history file.
+       ALLOCATE(albedo_prev(kjpindex,2),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in albedo_prev allocation. We stop. We need kjpindex*2 words = ',&
+               kjpindex*2
+          CALL ipslerr_p (3,'intersurf','intersurf','','')
+       ENDIF
+       ALLOCATE(albedo_day(kjpindex,2),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in albedo_day allocation. We stop. We need kjpindex*2 words = ',&
+               kjpindex*2
+          CALL ipslerr_p (3,'intersurf','intersurf','','')
+       ENDIF
+       ALLOCATE(sinang_prev(kjpindex),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in sinang_prev allocation. We stop. We need kjpindex words = ',&
+               kjpindex
+          CALL ipslerr_p (3,'intersurf','intersurf','','')
+       ENDIF
+       ALLOCATE(lmorning(kjpindex),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in lmorning allocation. We stop. We need kjpindex words = ',&
+               kjpindex
+          CALL ipslerr_p (3,'intersurf','intersurf','','')
+       ENDIF
+       ! Set them to their nighttime values.
+       sinang_prev(:)=zero
+       albedo_prev(:,:)=zero
+       albedo_day(:,:)=zero
+       lmorning(:)=.FALSE.
+
+       !
+       IF ( check ) WRITE(numout,*) 'End of Initialisation of intersurf'
+       !
+    ENDIF
+
+    ! This was initialially needed for the VOCs, but it was only
+    ! present occasionally, and for some reason it was only set
+    ! during the first call.  For the albedo scheme of Pinty et al,
+    ! we need the solar angle at every timestep.  Therefore, we
+    ! do this every time.  Notice this value always needs to
+    ! be between zero and one!
+    IF ( PRESENT(sinang) )  THEN 
+       zsinang(:) = sinang(:)
+    ELSE
+       zsinang(:) = zero
+    ENDIF
+
+!!! ANNE CALL ipslnlf_p(new_number=numout) est-il utile ? 
+
+    !
+    !! Change to be in the orchidee context for XIOS
+    !
+    CALL xios_orchidee_change_context("orchidee")
+    
+    !
+    !  Shift the time step to phase the two models
+    !
+    itau_sechiba = kjit + itau_offset
+    
+    ! Update the calendar in xios by sending the new time step
+    IF (l_first_intersurf) THEN
+       ! Special case : the model is only in initialization phase and the current itau_sechiba is not a real time step. 
+       ! Therefor give itau_sechiba+1 to xios to have a correct time axis in output files. 
+       CALL xios_orchidee_update_calendar(itau_sechiba+1)
+    ELSE
+       CALL xios_orchidee_update_calendar(itau_sechiba)
+    ENDIF
+
+    CALL intsurf_time( itau_sechiba, date0_shifted, xrdt )
+
+    ! Test LMDz inputs
+    IF (check_INPUTS) THEN
+       IF ( sec <= 7200 ) THEN
+          WRITE(numout,*) "sec = ",sec
+          CALL WriteFieldI_p("Wu",u)
+          WRITE(numout,*) "Lowest level wind speed :",u
+          CALL WriteFieldI_p("Wv",v)
+          WRITE(numout,*) "Lowest level wind speed  :",v
+          CALL WriteFieldI_p("Wzlev",zlev)
+          WRITE(numout,*) "Height of first layer :",zlev
+          CALL WriteFieldI_p("Wqair",qair)
+          WRITE(numout,*) "Lowest level specific humidity :",qair
+          CALL WriteFieldI_p("Wprecip_rain",precip_rain)
+          WRITE(numout,*) "Rain precipitation :",precip_rain
+          CALL WriteFieldI_p("Wprecip_snow",precip_snow)
+          WRITE(numout,*) "Snow precipitation :",precip_snow
+          CALL WriteFieldI_p("Wlwdown",lwdown)
+          WRITE(numout,*) "Down-welling long-wave flux  :",lwdown
+          CALL WriteFieldI_p("Wswnet",swnet)
+          WRITE(numout,*) "Net surface short-wave flux :",swnet
+          CALL WriteFieldI_p("Wswdown",swdown)
+          WRITE(numout,*) "Downwelling surface short-wave flux :",swdown
+          CALL WriteFieldI_p("Wtemp_air",temp_air)
+          WRITE(numout,*) "Air temperature in Kelvin :",temp_air
+          CALL WriteFieldI_p("Wepot_air",epot_air)
+          WRITE(numout,*) "Air potential energy :",epot_air
+          CALL WriteFieldI_p("Wccanopy",ccanopy)
+          WRITE(numout,*) "CO2 concentration in the canopy :",ccanopy
+          CALL WriteFieldI_p("WpetAcoef",petAcoef)
+          WRITE(numout,*) "Coeficients A from the PBL resolution :",petAcoef
+          CALL WriteFieldI_p("WpeqAcoef",peqAcoef)
+          WRITE(numout,*) "One for T and another for q :",peqAcoef
+          CALL WriteFieldI_p("WpetBcoef",petBcoef)
+          WRITE(numout,*) "Coeficients B from the PBL resolution :",petBcoef
+          CALL WriteFieldI_p("WpeqBcoef",peqBcoef)
+          WRITE(numout,*) "One for T and another for q :",peqBcoef
+          CALL WriteFieldI_p("Wcdrag",cdrag)
+          WRITE(numout,*) "Cdrag :",cdrag
+          CALL WriteFieldI_p("Wpb",pb)
+          WRITE(numout,*) "Lowest level pressure :",pb
+          CALL WriteFieldI_p("Wzcontfrac",zcontfrac)
+          WRITE(numout,*) "Fraction of continent :",zcontfrac
+          IF ( ok_q2m_t2m) THEN
+             CALL WriteFieldI_p("Wq2m",q2m)
+             WRITE(numout,*) "Surface specific humidity :",q2m
+             CALL WriteFieldI_p("Wt2m",t2m)
+             WRITE(numout,*) "Surface air temperature :",t2m
+          ENDIF
+          IF ( PRESENT(sinang) ) THEN
+             CALL WriteFieldI_p("Wsinang",sinang)
+             WRITE(numout,*) "Cosine of the solar zenith angle :",sinang
+          ENDIF
+       ENDIF
+    ENDIF
+
+    !
+    ! 1. Just change the units of some input fields
+    !
+    DO ik=1, kjpindex
+       
+       zprecip_rain(ik) = precip_rain(ik)*xrdt*precip_bias_correct
+       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 for local mpi process = ",iim_g, jj_nb
+       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,*) "offset for OMP = ",offset_omp
+       WRITE(numout,*) "Index for continental points = ",kindex
+       IF (is_omp_root) THEN
+          WRITE(numout,*) "ROOT OMP, Index global MPI : ",kindex_mpi(:)
+       ENDIF
+       IF (is_root_prc) THEN
+          WRITE(numout,*) "ROOT global, Index global : ",index_g(:)
+       ENDIF
+       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
+! Variables utilisees uniquement dans l_first et donc plus definies ensuite
+!       IF (is_omp_root) THEN
+!          WRITE(numout,*) "Geographical coordinates lon = "
+!          WRITE(numout,*) lon_scat
+!          WRITE(numout,*) "Geographical coordinates lat = "
+!          WRITE(numout,*) lat_scat 
+!       ENDIF
+       WRITE(numout,*) "Geographical land coordinates lon = ", lalo(:,2)
+       WRITE(numout,*) "Geographical land coordinates lat = ", lalo(:,1)
+       WRITE(numout,*) "Fraction of continent in the grid = ",zcontfrac
+    ENDIF
+
+    ! Fields for deposit variables : to be transport from chemistry model by GCM to ORCHIDEE.
+    WRITE(numout,*) "Get fields from atmosphere."
+
+    DO i_fields_in=1,nb_fields_in
+       WRITE(numout,*) i_fields_in," Champ = ",TRIM(field_in_names(i_fields_in)) 
+       SELECT CASE(TRIM(field_in_names(i_fields_in)))
+       CASE DEFAULT 
+          CALL ipslerr_p (3,'intsurf_gathered', &
+            &          'You ask in GCM an unknown field '//TRIM(field_in_names(i_fields_in))//&
+            &          ' to give to ORCHIDEE for this specific version.',&
+            &          'This model won''t be able to continue.', &
+            &          '(check your tracer parameters in GCM)')
+       END SELECT
+    ENDDO
+
+
+    !
+    ! 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
+       landpoints(:)=(/ ( REAL(ik), ik=1,kjpindex ) /)
+       CALL histwrite_p(hist_id, 'LandPoints',  itau_sechiba+1, landpoints, kjpindex, kindex)
+       CALL histwrite_p(hist_id, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+       IF ( control_flags%ok_stomate ) THEN
+          CALL histwrite_p(hist_id_stom, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+          IF ( hist_id_stom_ipcc > 0 ) &
+               CALL histwrite_p(hist_id_stom_IPCC, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+       ENDIF
+       CALL histwrite_p(hist_id, 'Contfrac',  itau_sechiba+1, contfrac, kjpindex, kindex)
+       
+       IF (is_omp_root .AND. hist_id > 0) THEN
+          CALL histsync(hist_id)
+       ENDIF
+       !
+       IF ( hist2_id > 0 ) THEN
+          CALL histwrite_p(hist2_id, 'LandPoints',  itau_sechiba+1, landpoints, kjpindex, kindex)
+          CALL histwrite_p(hist2_id, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+          CALL histwrite_p(hist2_id, 'Contfrac',  itau_sechiba+1, contfrac, kjpindex, kindex)
+          IF (is_omp_root) THEN
+             CALL histsync(hist2_id)
+          ENDIF
+       ENDIF
+       !
+    ENDIF
+    !
+    ! 4. call sechiba for continental points only
+    !
+    IF ( check ) WRITE(numout,*) 'Calling sechiba'
+    !
+    IF (.NOT. ok_q2m_t2m) THEN
+       CALL sechiba_main (itau_sechiba, iim_g*jj_nb, 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, zsinang, pb, &
+! Output : Fluxes
+            & zvevapp, zfluxsens, zfluxlat, zcoastal, zriver, znetco2, zcarblu, &
+! 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 ) 
+    ELSE
+       CALL sechiba_main (itau_sechiba, iim_g*jj_nb, 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, zsinang, pb, &
+! Output : Fluxes
+            & zvevapp, zfluxsens, zfluxlat, zcoastal, zriver, znetco2, zcarblu, &
+! 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 ) 
+    ENDIF
+    !
+    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_g, jj_nb, 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_g) + 1
+!!$             i = (kindex(ik) - (j-1)*iim_g)
+!!$             
+!!$             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_g) + 1
+!!$                i = (kindex(ik) - (j-1)*iim_g)
+!!$                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
+    !    
+
+    DO ik=1, kjpindex
+       
+       z0(ik)           = zz0(ik)
+       coastalflow(ik)  = zcoastal(ik)/mille
+       riverflow(ik)    = zriver(ik)/mille
+       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)
+       
+      
+
+       
+    ENDDO
+
+    !
+    ! Modified fields for variables scattered during the writing
+    !
+    dcoastal(:) = (zcoastal(:))/mille
+    driver(:)   = (zriver(:))/mille
+    !
+
+    ! The albedo has become a special case, since values are not calculated
+    ! at night.  Therefore, we do not want to average over the whole day.  However,
+    ! we cannot just check to see for which points it is daytime and write those,
+    ! since we have to pass the whole block of points to histwrite at the same time.
+    ! Therefore, we write the values we want to a different array and then only
+    ! write out the array at the end of the day to the histwrite.  We also cannot
+    ! just write the daily maximum value, since the maximum may occur at sunrise
+    ! or sunset, depending on the wavelength.
+    DO ikjp=1,kjpindex
+       !  Check to see if we're in the morning.
+       IF( .NOT. lmorning(ikjp))THEN
+          IF(zsinang(ikjp) .GT. sinang_prev(ikjp))THEN
+             lmorning(ikjp)=.TRUE.
+          ENDIF
+       ENDIF
+       ! If our SZA is lower than the previous timestep,  and we were in the
+       ! morning, we have just passed
+       ! the solar noon.  Therefore, we save the previous value.
+       IF((zsinang(ikjp) .LT. sinang_prev(ikjp)) .AND. lmorning(ikjp))THEN
+          albedo_day(ikjp,:)=albedo_prev(ikjp,:)
+          ! It is no longer morning.
+          lmorning(ikjp)=.FALSE.
+       ENDIF
+    ENDDO
+    ! Save the current values of the albedo and the solar angle.
+    sinang_prev(:)=zsinang(:)
+    albedo_prev(:,:)=zalbedo(:,:)
+
+    IF ( .NOT. l_first_intersurf) THEN
+       
+       CALL xios_orchidee_send_field("LandPoints" ,(/ ( REAL(ik), ik=1,kjpindex ) /))
+       CALL xios_orchidee_send_field("Areas", area)
+       CALL xios_orchidee_send_field("Contfrac",contfrac)
+       CALL xios_orchidee_send_field("evap",zvevapp*one_day/dt_sechiba)
+       CALL xios_orchidee_send_field("evap_alma",zvevapp/dt_sechiba)
+       CALL xios_orchidee_send_field("coastalflow",dcoastal/dt_sechiba)
+       CALL xios_orchidee_send_field("riverflow",driver/dt_sechiba)
+       CALL xios_orchidee_send_field("temp_sol_C",ztemp_sol_new-ZeroCelsius)
+       CALL xios_orchidee_send_field("temp_sol_K",ztemp_sol_new)
+       CALL xios_orchidee_send_field("fluxsens",zfluxsens)
+       CALL xios_orchidee_send_field("fluxlat",zfluxlat)
+       CALL xios_orchidee_send_field("alb_vis",zalbedo(:,1))
+       CALL xios_orchidee_send_field("alb_nir",zalbedo(:,2))
+       CALL xios_orchidee_send_field("tair",temp_air)
+       CALL xios_orchidee_send_field("qair",qair)
+       CALL xios_orchidee_send_field("swnet",swnet)
+       CALL xios_orchidee_send_field("swdown",swdown)
+          
+       IF (ok_q2m_t2m) THEN
+          CALL xios_orchidee_send_field("t2m",t2m)
+          CALL xios_orchidee_send_field("q2m",q2m)
+       ELSE
+          CALL xios_orchidee_send_field("t2m",temp_air)
+          CALL xios_orchidee_send_field("q2m",qair)
+       ENDIF
+
+       IF ( .NOT. almaoutput ) THEN
+          !
+          !  scattered during the writing
+          !           
+          CALL histwrite_p (hist_id, 'evap',     itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
+          ! 
+          CALL histwrite_p (hist_id, 'temp_sol', itau_sechiba, ztemp_sol_new, kjpindex, kindex)
+
+          CALL histwrite_p (hist_id, 'tsol_max', itau_sechiba, ztemp_sol_new, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'tsol_min', itau_sechiba, ztemp_sol_new, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'fluxsens', itau_sechiba, zfluxsens, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'fluxlat',  itau_sechiba, zfluxlat,  kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'swnet',    itau_sechiba, swnet,    kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'swdown',   itau_sechiba, swdown,   kjpindex, kindex)
+          ! Something special for albedo values, since we do not want to average
+          ! over the nightly values (which are zero and not used).  Since we only
+          ! write once a day, we do not need to normalize the value by anything.
+          ! The value printed at this one timestep is the value which appears
+          ! in the history file.
+          IF ( MOD(sec,one_day) .EQ. zero ) THEN
+             CALL histwrite_p (hist_id, 'alb_vis',  itau_sechiba, albedo_day(:,1), kjpindex, kindex)
+             CALL histwrite_p (hist_id, 'alb_nir',  itau_sechiba, albedo_day(:,2), kjpindex, kindex)
+          ENDIF
+          CALL histwrite_p (hist_id, 'tair',     itau_sechiba, temp_air, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'qair',     itau_sechiba, qair, kjpindex, kindex)
+          IF (ok_q2m_t2m) THEN
+             CALL histwrite_p (hist_id, 't2m',      itau_sechiba, t2m, kjpindex, kindex)
+             CALL histwrite_p (hist_id, 'q2m',      itau_sechiba, q2m, kjpindex, kindex)
+          ELSE
+            CALL histwrite_p (hist_id, 't2m',      itau_sechiba, temp_air, kjpindex, kindex)
+            CALL histwrite_p (hist_id, 'q2m',      itau_sechiba, qair, kjpindex, kindex)
+          ENDIF
+          !
+          IF ( hist2_id > 0 ) THEN
+             CALL histwrite_p (hist2_id, 'evap',     itau_sechiba, zvevapp, kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
+             ! 
+             CALL histwrite_p (hist2_id, 'temp_sol', itau_sechiba, temp_sol_new, kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'tsol_max', itau_sechiba, temp_sol_new, kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'tsol_min', itau_sechiba, temp_sol_new, kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'fluxsens', itau_sechiba, zfluxsens, kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'fluxlat',  itau_sechiba, zfluxlat,  kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'swnet',    itau_sechiba, swnet,    kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'swdown',   itau_sechiba, swdown,   kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'alb_vis',  itau_sechiba, zalbedo(:,1), kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'alb_nir',  itau_sechiba, zalbedo(:,2), kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'tair',     itau_sechiba, temp_air, kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'qair',     itau_sechiba, qair, kjpindex, kindex)
+             IF (ok_q2m_t2m) THEN
+                CALL histwrite_p (hist2_id, 't2m',      itau_sechiba, t2m, kjpindex, kindex)
+                CALL histwrite_p (hist2_id, 'q2m',      itau_sechiba, q2m, kjpindex, kindex)
+             ELSE
+               CALL histwrite_p (hist2_id, 't2m',      itau_sechiba, temp_air, kjpindex, kindex)
+               CALL histwrite_p (hist2_id, 'q2m',      itau_sechiba, qair, kjpindex, kindex)
+            ENDIF
+          ENDIF
+       ELSE
+          CALL histwrite_p (hist_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'SWnet',    itau_sechiba, swnet, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'Qh', itau_sechiba, zfluxsens, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'Qle',  itau_sechiba, zfluxlat, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'AvgSurfT', itau_sechiba, ztemp_sol_new, kjpindex, kindex)
+          CALL histwrite_p (hist_id, 'RadT', itau_sechiba, ztemp_sol_new, kjpindex, kindex)
+          !
+          IF ( hist2_id > 0 ) THEN
+             CALL histwrite_p (hist2_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'SWnet',    itau_sechiba, swnet, kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'Qh', itau_sechiba, zfluxsens, kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'Qle',  itau_sechiba, zfluxlat, kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'AvgSurfT', itau_sechiba, ztemp_sol_new, kjpindex, kindex)
+             CALL histwrite_p (hist2_id, 'RadT', itau_sechiba, ztemp_sol_new, kjpindex, kindex)
+          ENDIF
+       ENDIF
+
+       !
+       IF (is_omp_root) THEN
+          IF ( (dw .EQ. xrdt) .AND. hist_id > 0 ) THEN
+             CALL histsync(hist_id)
+          ENDIF
+       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
+    !
+    WRITE(numout,*) "Give fields to atmosphere."
+    
+    ! Fields for emission variables : to be transport by GCM to chemistry model.
+    DO i_fields_out=1,nb_fields_out
+       SELECT CASE(TRIM(field_out_names(i_fields_out)))
+       CASE("fCO2_land") 
+          fields_out(:,i_fields_out)=znetco2(:)
+       CASE("fCO2_land_use")
+          fields_out(:,i_fields_out)=zcarblu(:)
+       CASE DEFAULT 
+          CALL ipslerr_p (3,'intsurf_gathered', &
+            &          'You ask from GCM an unknown field '//TRIM(field_out_names(i_fields_out))//&
+            &          ' to ORCHIDEE for this specific version.',&
+            &          'This model won''t be able to continue.', &
+            &          '(check your tracer parameters in GCM)')
+       END SELECT
+    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 '
+
+!Test ORCHIDEE Outputs
+    IF (check_INPUTS) THEN
+       IF ( sec <= 7200 ) THEN
+          CALL WriteFieldI_p("Wcdrag",cdrag)
+          WRITE(numout,*) "Cdrag :",cdrag
+          CALL WriteFieldI_p("Wz0",z0)
+          WRITE(numout,*) "Surface roughness :",z0
+          CALL WriteFieldI_p("Wcoastalflow",coastalflow)
+          WRITE(numout,*) "Diffuse flow of water into the ocean (m^3/dt) :",coastalflow
+          CALL WriteFieldI_p("Wriverflow",riverflow)
+          WRITE(numout,*) "Largest rivers flowing into the ocean (m^3/dt) :",riverflow
+          CALL WriteFieldI_p("Wtsol_rad",tsol_rad)
+          WRITE(numout,*) "Radiative surface temperature :",tsol_rad
+          CALL WriteFieldI_p("Wvevapp",vevapp)
+          WRITE(numout,*) "Total of evaporation :",vevapp
+          CALL WriteFieldI_p("Wtemp_sol_new",temp_sol_new)
+          WRITE(numout,*) "New soil temperature :",temp_sol_new
+          CALL WriteFieldI_p("Wqsurf",qsurf)
+          WRITE(numout,*) "Surface specific humidity :",qsurf
+          CALL WriteFieldI_p("Walbedo_nir",albedo(:,1))
+          WRITE(numout,*) "Albedo nir:",albedo(:,1)
+          CALL WriteFieldI_p("Walbedo_vis",albedo(:,2))
+          WRITE(numout,*) "Albedo vir :",albedo(:,2)
+          CALL WriteFieldI_p("Wfluxsens",fluxsens)
+          WRITE(numout,*) "Sensible chaleur flux :",fluxsens
+          CALL WriteFieldI_p("Wfluxlat",fluxlat)
+          WRITE(numout,*) "Latent chaleur flux :",fluxlat
+          CALL WriteFieldI_p("Wemis",emis)
+          WRITE(numout,*) "Emissivity :",emis
+       ENDIF
+    ENDIF
+
+    !
+    CALL ipslnlf_p(new_number=old_fileout)
+    !        
+
+    !
+    !! Finalize the XIOS orchidee context if it is the last call
+    !
+    IF (lrestart_write) THEN
+       CALL xios_orchidee_context_finalize
+    END IF
+    !
+    !! Change back to be in the LMDZ context for XIOS
+    !
+    CALL xios_orchidee_change_context("LMDZ")
+
+  END SUBROUTINE intersurf_gathered
+!
+!! ================================================================================================================================
+!! SUBROUTINE   : intsurf_time
+!!
+!>\BRIEF        This subroutine initialized the time global variables in grid module. 
+!!
+!! DESCRIPTION  : 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!! - 
+!!
+!! FLOWCHART    : 
+!_ ================================================================================================================================
+
+  SUBROUTINE intsurf_time(istp, date0, dt)
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    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
+
+!_ ================================================================================================================================
+
+    IF (l_first_intersurf) THEN
+
+       ! Initialization de dt_sechiba in module constants_var
+       dt_sechiba=dt
+
+       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_time) 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_time) &
+         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_time) 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_time) 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_time) 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_time) 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_time) &
+!!$            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 - julian0
+       month_len = ioget_mon_len (year,month)
+       IF (check_time) 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_time) &
+!!$         WRITE(numout,*) "---" 
+
+  END SUBROUTINE intsurf_time
+!
+
+!! ================================================================================================================================
+!! SUBROUTINE   : intsurf_config
+!!
+!>\BRIEF        This subroutine reads all the configuration flags which control the behaviour of the model 
+!!
+!! DESCRIPTION  : 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!! - 
+!!
+!! FLOWCHART    : 
+!_ ================================================================================================================================
+
+  SUBROUTINE intsurf_config(control_flags,dt)
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    REAL, INTENT(in)                           :: dt             !! Time step in seconds
+
+    !! 0.2 Output variables
+
+    TYPE(control_type), INTENT(out)            :: control_flags  !! Flags that (de)activate parts of the model
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                             :: jv             !!
+ ! tzjsf 
+    INTEGER(i_std)                             :: ier           !! Error handeling
+
+!_ ================================================================================================================================
+
+    !Config Key   = LONGPRINT
+    !Config Desc  = ORCHIDEE will print more messages
+    !Config If    = OK_SECHIBA
+    !Config Def   = n
+    !Config Help  = This flag permits to print more debug messages in the run.
+    !Config Units = [FLAG]
+    !
+    long_print = .FALSE.
+    CALL getin_p('LONGPRINT',long_print)
+    !
+    !Config Key   = CHECKTIME
+    !Config Desc  = ORCHIDEE will print messages on time
+    !Config If    = OK_SECHIBA
+    !Config Def   = n
+    !Config Help  = This flag permits to print debug messages on the time.
+    !Config Units = [FLAG]
+    !
+    check_time = .FALSE.
+    CALL getin_p('CHECKTIME',check_time)
+
+    ! This DOFOCO flag is one that needs to be read in very early on in the
+    ! sequence of run.def variables, since setting it to yes changes the values
+    ! of some of the flags.  The other way to do this was to read it in at the end
+    ! of the calling sequence and change the variables then, but certain variables
+    ! are read in only if other are true, and therefore this way is the safest.
+    !
+    !Config Key   = OK_DOFOCO
+    !Config Desc  = Decides if we do a DOFOCO simulation
+    !Config If    = OK_SECHIBA
+    !Config Def   = n
+    !Config Help  = This flag groups together and sets the flags required for
+    !Config         a DOFOCO simulation.  Right now this includes the albedo type,
+    !Config         stomate, a different energy budget, a different snow albedo,
+    !Config         the 11-layer hydrology, and a hydrolic architecture.  
+    !Config         This prints warning messages
+    !Config         to the screen for every variable it overwrites if set to Y.
+    !Config Units = [FLAG]
+    !
+    control_flags%ok_dofoco = .FALSE.
+    CALL getin_p('OK_DOFOCO', control_flags%ok_dofoco)
+    
+    !Config Key   = OK_RECRUITMENT
+    !Config Desc  = Decides if we do a DOFOCO simulation
+    !Config If    = OK_SECHIBA
+    !Config Def   = n
+    !Config Help  = This flag groups together and sets the flags required for
+    !Config         a DOFOCO simulation.  Right now this includes the albedo type,
+    !Config         stomate, a different energy budget, a different snow albedo,
+    !Config         the 11-layer hydrology, and a hydrolic architecture.  
+    !Config         This prints warning messages
+    !Config         to the screen for every variable it overwrites if set to Y.
+    !Config Units = [FLAG]
+    !
+    IF(control_flags%ok_dofoco)THEN
+        control_flags%ok_recruitment = .FALSE.
+        CALL getin_p('RECRUITMENT', control_flags%ok_recruitment)
+        control_flags%ok_daily_recruitment = .FALSE.
+        CALL getin_p('DAILY_RECRUITMENT', control_flags%ok_daily_recruitment)
+    ENDIF
+    
+    !
+    !Config Key   = SOILTYPE_CLASSIF
+    !Config Desc  = Type of classification used for the map of soil types 
+    !Config Def   = zobler
+    !Config If    = !IMPOSE_VEG
+    !Config Help  = The classification used in the file that we use here 
+    !Config         There are three classification supported:  
+    !Config         FAO (3 soil types), Zobler (7 converted to 3) and USDA (12) 
+    !Config Units = [-]
+    !
+    !-tdo- Suivant le type de classification utilisee pour le sol, on adapte nscm 
+    soil_classif = 'zobler'
+    CALL getin_p('SOILTYPE_CLASSIF',soil_classif)
+    SELECTCASE (soil_classif)
+    CASE ('zobler', 'fao','none')
+       nscm = nscm_fao
+    CASE ('usda')
+       nscm = nscm_usda
+    CASE DEFAULT
+       WRITE(numout,*) "Unsupported soil type classification. Choose between zobler, fao and usda according to the map"
+       CALL ipslerr(3,'intersurf','intsurf_config','','')
+    ENDSELECT
+
+!
+    !Config Key   = ORCHIDEE_WATCHOUT
+    !Config Desc  = ORCHIDEE will write out its forcing to a file
+    !Config If    =
+    !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.
+    !Config Units = [FLAG]
+    !
+    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. 
+       !Config Units = [seconds]
+       !
+       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. 
+       !Config Units = [FILE]
+       !
+       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 If    = OK_SECHIBA
+    !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.
+    !Config Units = [FLAG]
+    !
+    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 Desc  = Allows to switch on the multilayer hydrology of CWRR
+   ! Config If    = OK_SECHIBA
+   ! 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.
+   ! Config Units = [FLAG]
+    !
+    control_flags%hydrol_cwrr = .FALSE.
+    ! If the DOFOCO flag is on, we need the 11 layer hydrology for the hydrolic architecture.
+    IF(control_flags%ok_dofoco)THEN
+       ! We set the flag without calling getin_p so nothing will be written to used_run_def
+       control_flags%hydrol_cwrr = .TRUE.
+       WRITE(numout,*) "OK_DOFOCO flag has been set.  Ignoring hydrol_cwrr in the run.def.  Using HYDROL_CWRR=Y."
+    ELSE
+       CALL getin_p('HYDROL_CWRR', control_flags%hydrol_cwrr)
+    ENDIF
+    WRITE(numout,*) "CWRR hydrology is activated : ",control_flags%hydrol_cwrr
+    !
+    IF ( control_flags%hydrol_cwrr ) THEN
+       zmaxh = 2.0
+    ELSE
+       zmaxh = 4.0
+    END IF
+
+! tzjsf
+!    !Config Key   = HYDROL_SOIL_DEPTH
+!    !Config Desc  = Total depth of soil reservoir
+!    !Config If    = OK_SECHIBA 
+!    !Config Def   = 4./ 2. (if HYDROL_CWRR)
+!    !Config Help  = By default, ORCHIDEE uses the AR5 configuration (Choisnel-4m).
+!    !Config Units = [m]
+!    CALL getin_p ("HYDROL_SOIL_DEPTH", zmaxh)
+!    WRITE(numout,*) "SOIL DEPTH value read in configuration file run.def : ", zmaxh
+!    !
+!    DO jv = 1, nslm-1
+!       diaglev(jv) = zmaxh/(2**(nslm-1) -1) * ( ( 2**(jv-1) -1) + ( 2**(jv) -1) ) / deux
+!    ENDDO
+!    diaglev(nslm) = zmaxh
+!    !
+
+    !Config Key   = DO_IRRIGATION
+    !Config Desc  = Should we compute an irrigation flux 
+    !Config If    = RIVER_ROUTING 
+    !Config Def   = n
+    !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.
+    !Config Units = [FLAG]
+    !
+    control_flags%do_irrigation = .FALSE.
+    CALL getin_p('DO_IRRIGATION', control_flags%do_irrigation)
+    WRITE(numout,*) "IRRIGATION is activated, ", control_flags%do_irrigation
+    !
+    !Config Key   = DO_FLOODPLAINS
+    !Config Desc  = Should we include floodplains 
+    !Config If    = RIVER_ROUTING 
+    !Config Def   = n
+    !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.
+    !Config Units = [FLAG]  
+    !
+    control_flags%do_floodplains = .FALSE.
+    CALL getin_p('DO_FLOODPLAINS', control_flags%do_floodplains)
+    WRITE(numout,*) "FLOODPLAINS are taken into account, ",control_flags%do_floodplains
+    !
+    !Config Key   = CHECK_WATERBAL
+    !Config Desc  = Should we check the global water balance 
+    !Config If    = OK_SECHIBA
+    !Config Def   = FALSE
+    !Config Help  = This parameters allows the user to check
+    !Config         the integrated water balance at the end
+    !Config         of each time step
+    !Config Units = [FLAG]  
+    !
+    check_waterbal = .FALSE.
+    CALL getin_p('CHECK_WATERBAL', check_waterbal)
+    WRITE(numout,*) 'check waterbalance is activated: ', check_waterbal
+    !
+    !Config Key   = STOMATE_OK_CO2
+    !Config Desc  = Activate CO2?
+    !Config If    = OK_SECHIBA 
+    !Config Def   = n
+    !Config Help  = set to TRUE if photosynthesis is to be activated
+    !Config Units = [FLAG]
+    !
+    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 If    = OK_SECHIBA and OK_CO2
+    !Config Def   = n
+    !Config Help  = set to TRUE if STOMATE is to be activated
+    !Config Units = [FLAG]
+    !
+    control_flags%ok_stomate = .FALSE.
+    CALL getin_p('STOMATE_OK_STOMATE',control_flags%ok_stomate)
+    ! If the DOFOCO flag is on, we need the 11 layer hydrology for the hydrolic architecture.
+    IF(control_flags%ok_dofoco)THEN
+       ! We set the flag without calling getin_p so nothing will be written to used_run_def
+       control_flags%ok_stomate = .TRUE.
+       WRITE(numout,*) "OK_DOFOCO flag has been set.  Ignoring STOMATE_OK_STOMATE in the run.def.  Using STOMATE_OK_STOMATE=Y."
+    ELSE
+       CALL getin_p('STOMATE_OK_STOMATE',control_flags%ok_stomate) 
+    ENDIF
+    WRITE(numout,*) 'STOMATE is activated: ', control_flags%ok_stomate
+    
+
+    IF (control_flags%ok_stomate) THEN
+       !
+       !Config Key   = HERBIVORY
+       !Config Desc  = herbivores allowed ?
+       !Config If    = OK_STOMATE 
+       !Config Def   = n
+       !Config Help  = With this variable, you can determine
+       !Config         if herbivores are activated, unclear whether this includes grazing
+       !Config         by cattle - there is a grassland module that does that.
+       !Config Units = [FLAG]
+       control_flags%ok_herbivory = .FALSE.
+       CALL getin_p('HERBIVORY',control_flags%ok_herbivory)
+       WRITE(numout,*) 'HERBIVORY is activated: ', control_flags%ok_herbivory
+       !
+       !Config Key   = STOMATE_OK_DGVM
+       !ConfigWRITE(numout,*) 'STOMATE is activated: ',control_flags%ok_stomate Desc  = Activate DGVM?
+       !Config If    = OK_STOMATE
+       !Config Def   = n
+       !Config Help  = set to TRUE if DGVM is to be activated
+       !Config Units = [FLAG]
+       !
+       control_flags%ok_dgvm = .FALSE.
+       CALL getin_p('STOMATE_OK_DGVM',control_flags%ok_dgvm)
+       WRITE(numout,*) 'DGVM is activated: ',control_flags%ok_dgvm 
+       !
+       !Config Key  = STOMATE_FUNCTIONAL_ALLOCATION
+       !Config Desc = use Friedlingstein etal. 1999 or Zaehle et al 2010 for allocation
+       !Config If   = OK_STOMATE
+       !Config Def  = n
+       !Config Help = set to TRUE if functional allocation is to be activated
+       !
+       control_flags%ok_functional_allocation = .FALSE.
+       ! If the DOFOCO flag is on, we need the functional allocation for the canopy structure.
+       IF(control_flags%ok_dofoco)THEN
+          ! We set the flag without calling getin_p so nothing will be written to used_run_def
+          control_flags%ok_functional_allocation = .TRUE.
+          WRITE(numout,*) "OK_DOFOCO flag has been set.  Ignoring the run.def. Using STOMATE_FUNCTIONAL_ALLOCATION=Y."
+       ELSE
+          CALL getin_p('STOMATE_FUNCTIONAL_ALLOCATION',control_flags%ok_functional_allocation)
+       ENDIF
+       WRITE(numout,*) 'ALLOCATION is based on plant structure: ',control_flags%ok_functional_allocation
+       !
+       !Config Key  = SECHIBA_HYDROL_ARCH
+       !Config Desc = Use hydraulic architecture to calculate water supply for transpiration for the leaves
+       !Config If   = OK_STOMATE, OK_FUNCTIONAL_ALLOCATION
+       !Config Def  = n
+       !Config Help = set to TRUE if hydraulic architecture is to be activated
+       !
+       control_flags%ok_hydrol_arch = .FALSE.
+       ! If the DOFOCO flag is on, we need the functional allocation for the canopy structure.
+       IF(control_flags%ok_dofoco)THEN
+          ! We set the flag without calling getin_p so nothing will be written to used_run_def
+          control_flags%ok_hydrol_arch = .TRUE.
+          WRITE(numout,*) "OK_DOFOCO flag has been set.  Ignoring the run.def. Using SECHIBA_HYDROL_ARCH=Y."
+       ELSE
+          CALL getin_p('SECHIBA_HYDROL_ARCH',control_flags%ok_hydrol_arch)
+       ENDIF
+       WRITE(numout,*) 'TRANSPIRATION SUPPLY is based on hydraulic architecture: ',control_flags%ok_hydrol_arch
+       !
+     
+
+      ! FLAG tzjh    
+       !Config Key  = JOETZJER_HYDRO
+       !Config Desc = Use joetzjer hydraulic architecture 
+       !Config If   = 
+       !Config Def  = n
+       !Config Help = set to TRUE if hydraulic architecture is to be activated
+       !
+         
+       control_flags%ok_joetzjer_hydro = .TRUE.
+       WRITE(numout,*) 'TRANSPIRATION SUPPLY is based on hydraulic architecture: ',control_flags%ok_joetzjer_hydro
+
+
+       !Config Key  = SECHIBA_NENERBIL
+       !Config Desc = Activate the new energy budget scheme
+       !Config If   = OK_STOMATE, OK_FUNCTIONAL_ALLOCATION
+       !Config Def  = n
+       !Config Help = set to TRUE if the new energy budget scheme is to be activated
+       !
+       control_flags%ok_nenerbil = .FALSE.
+       ! If the DOFOCO flag is on, we need the functional allocation for the canopy structure.
+       IF(control_flags%ok_dofoco)THEN
+          ! We set the flag without using getin_p so nothing will be written to the used_run_def
+          control_flags%ok_nenerbil = .TRUE.
+          WRITE(numout,*) "OK_DOFOCO flag has been set.  Ignoring the run.def. Using SECHIBA_NENERBIL=Y."
+       ELSE
+          CALL getin_p('SECHIBA_NENERBIL',control_flags%ok_nenerbil)
+       ENDIF
+       WRITE(numout,*) 'SECHIBA_NENERBIL Using an updated version of the energy budget? ',control_flags%ok_nenerbil
+       !
+       !Config Key  = SECHIBA_GS_FEEDBACK
+       !Config Desc = Activate water stress impact on the stomatal conductance.
+       !Config If   = OK_STOMATE, OK_FUNCTIONAL_ALLOCATION, OK_HYDROL_ARCH
+       !Config Def  = n
+       !Config Help = set to TRUE if you desire the hydraulic architecture scheme to reduce the stomatal
+       !               conductance in the case of water stress.  Note that this requires recalculation of
+       !               of the energy budget.
+       !
+       IF(control_flags%ok_hydrol_arch)THEN
+          control_flags%ok_gs_feedback  = .TRUE.
+       ELSE
+          control_flags%ok_gs_feedback  = .FALSE.
+       ENDIF
+       ! If the DOFOCO flag is on, we need the functional allocation for the canopy structure.
+       IF(control_flags%ok_dofoco)THEN
+          ! We set the flag without using getin_p so nothing will be written to the used_run_def
+          control_flags%ok_gs_feedback  = .TRUE.
+          WRITE(numout,*) "OK_DOFOCO flag has been set.  Ignoring the run.def. Using SECHIBA_GS_FEEDBACK=Y."
+       ELSE
+          CALL getin_p('SECHIBA_GS_FEEDBACK',control_flags%ok_gs_feedback)
+       ENDIF
+       WRITE(numout,*) 'SECHIBA_GS_FEEDBACK Water stress forces recalculation of stomatal conductance: ',&
+            control_flags%ok_gs_feedback
+       !
+       !Config Key  = CONSTANT_MORTALITY
+       !Config Desc = Assume constant prescribed mortality or calculate mortality as a function of last year's NPP
+       !Config If   = OK_STOMATE
+       !Config Def  = y
+       !Config Help = set to TRUE if constant mortality is to be assumed
+       !
+       control_flags%ok_constant_mortality = .TRUE.
+       CALL getin_p('CONSTANT_MORTALITY',control_flags%ok_constant_mortality)
+       WRITE(numout,*) 'MORTALITY is assumed to be constant (instead of being a function of vigor): ', &
+            control_flags%ok_constant_mortality
+       !
+       !Config Key  = STOMATE_OK_CEXCHANGE
+       !Config Desc = use Friend and Kiang, 2005, for photosynthesis?
+       !Config If   = OK_STOMATE
+       !Config Def  = n
+       !Config Help = set to TRUE if photosynthesis is to be calculated as in CEXCHANGE
+       !
+       control_flags%ok_cexchange = .FALSE.
+       CALL getin_p('STOMATE_GOES_CEXCHANGE',control_flags%ok_cexchange)
+       WRITE(numout,*) 'PHOTOSYNTHESIS is calculated using Friend and Kiang, 2005: ',control_flags%ok_cexchange
+       
+    ENDIF
+
+    ! +++CHECK+++
+    ! Should land_use of land_cover_change be the primary flag?
+    ! To Seb L (and based on the code) it looks like land_cover_change should be. Also the 
+    ! the difference with land_use is unclear.
+    !Config Key   = LAND_COVER_CHANGE
+    !Config Desc  = treat land use modifications
+    !Config If    = LAND_USE - CHECK
+    !Config Def   = n
+    !Config Help  = Treat land cover changes
+    !Config Units = [FLAG]
+    control_flags%ok_land_cover_change = .FALSE.
+    CALL getin_p('LAND_COVER_CHANGE', control_flags%ok_land_cover_change)
+    WRITE(numout,*) "LAND COVER CHANGE is accounted for, ",control_flags%ok_land_cover_change
+
+    !Config Key   = HARVEST_AGRI
+    !Config Desc  = Harvest model for agricultural PFTs.
+    !Config If    = OK_STOMATE - CHECK whether it depends on LAND_COVER_CHANGE??? 
+    !Config Def   = y
+    !Config Help  = Compute harvest above ground biomass for agriculture.
+    !Config         Change daily turnover.
+    !Config Units = [FLAG]
+    control_flags%ok_agricultural_harvest = .FALSE.
+    CALL getin_p('AGRICULTURAL_HARVEST', control_flags%ok_agricultural_harvest)
+    WRITE(numout,*) "AGRICULTURAL_HARVEST is accounted for, ",control_flags%ok_agricultural_harvest  
+    ! +++++++++++  
+    !
+    !Config Key   = DIFFUCO_OK_INCA
+    !Config Desc  = Activate DIFFUCO_INCA?
+    !Config If    = OK_SECHIBA
+    !Config Def   = n
+    !Config Help  = set to TRUE if biogenic emissions calculation is to be activated
+    !Config Units = [FLAG]
+    !
+    control_flags%ok_inca = .FALSE.
+    CALL getin_p('DIFFUCO_OK_INCA', control_flags%ok_inca)
+    WRITE(numout,*) 'Biogenic emissions: ', control_flags%ok_inca
+    !
+    !Config Key   = LEAFAGE_OK_INCA
+    !Config Desc  = Activate LEAFAGE?
+    !Config If    = DIFFUCO_OK_INCA
+    !Config Def   = n
+    !Config Help  = set to TRUE if biogenic emissions calculation takes leaf age into account
+    !Config Units = [FLAG]
+    !
+    control_flags%ok_leafage = .FALSE.
+    CALL getin_p('LEAFAGE_OK_INCA', control_flags%ok_leafage)
+    WRITE(numout,*) 'Leaf Age: ', control_flags%ok_leafage
+    !
+    !Config Key   = CANOPY_EXTINCTION 
+    !Config Desc  = Use canopy radiative transfer model?
+    !Config If    = DIFFUCO_OK_INCA 
+    !Config Def   = n
+    !Config Help  = set to TRUE if canopy radiative transfer model is used for biogenic emissions 
+    !Config Units = [FLAG]
+    !
+    control_flags%ok_radcanopy = .FALSE.
+    CALL getin_p('CANOPY_EXTINCTION', control_flags%ok_radcanopy)
+    WRITE(numout,*) 'Canopy radiative transfer model: ', control_flags%ok_radcanopy
+    !
+    !Config Key   = CANOPY_MULTILAYER
+    !Config Desc  = Use canopy radiative transfer model with multi-layers
+    !Config If    = CANOPY_EXTINCTION 
+    !Config Def   = n
+    !Config Help  = set to TRUE if canopy radiative transfer model is with multiple layers 
+    !Config Units = [FLAG]
+    !
+    control_flags%ok_multilayer = .FALSE.
+    CALL getin_p('CANOPY_MULTILAYER', control_flags%ok_multilayer)
+    WRITE(numout,*) 'Multi-layer Canopy model (for INCA): ', control_flags%ok_multilayer
+    WRITE(numout,*) 'NOTICE: This multilayer canopy model option is for INCA. '
+    WRITE(numout,*) '        Using functional allocation results in a canopy which is '
+    WRITE(numout,*) '        has multiple vertically resolved levels, but that has absolutely '
+    WRITE(numout,*) '        nothing to do with the CANOPY_MULTILAYER flag. '
+    !
+    !Config Key   = NOx_RAIN_PULSE
+    !Config Desc  = Calculate NOx emissions with pulse?
+    !Config If    = DIFFUCO_OK_INCA 
+    !Config Def   = n
+    !Config Help  = set to TRUE if NOx rain pulse is taken into account
+    !Config Units = [FLAG]
+    !
+    control_flags%ok_pulse_NOx = .FALSE.
+    CALL getin_p('NOx_RAIN_PULSE', control_flags%ok_pulse_NOx)
+    WRITE(numout,*) 'Rain NOx pulsing: ', control_flags%ok_pulse_NOx
+    !
+    !Config Key   = NOx_BBG_FERTIL
+    !Config Desc  = Calculate NOx emissions with bbg fertilizing effect?
+    !Config If    = DIFFUCO_OK_INCA 
+    !Config Def   = n
+    !Config Help  = set to TRUE if NOx emissions are calculated with bbg effect 
+    !Config         Fertil effect of bbg on NOx soil emissions 
+    !Config Units = [FLAG]
+    !
+    control_flags%ok_bbgfertil_NOx = .FALSE.
+    CALL getin_p('NOx_BBG_FERTIL', control_flags%ok_bbgfertil_NOx)
+    WRITE(numout,*) 'NOx bbg fertil effect: ', control_flags%ok_bbgfertil_NOx
+    !
+    !Config Key   = NOx_FERTILIZERS_USE
+    !Config Desc  = Calculate NOx emissions with fertilizers use?
+    !Config If    = DIFFUCO_OK_INCA 
+    !Config Def   = n
+    !Config Help  = set to TRUE if NOx emissions are calculated with fertilizers use
+    !Config         Fertilizers use effect on NOx soil emissions  
+    !Config Units = [FLAG] 
+    !
+    control_flags%ok_cropsfertil_NOx = .FALSE.
+    CALL getin_p('NOx_FERTILIZERS_USE', control_flags%ok_cropsfertil_NOx)
+    WRITE(numout,*) 'NOx Fertilizers use: ', control_flags%ok_cropsfertil_NOx
+    !
+    !Config Key   = FOREST_MANAGEMENT
+    !Config Desc  = Activate forest management ?
+    !Config If    = STOMATE_OK_STOMATE
+    !Config Def   = n
+    !Config Help  = 
+    !Config Units = [FLAG] 
+    !
+    control_flags%forest_management = .FALSE.
+    CALL getin_p("FOREST_MANAGEMENT", control_flags%forest_management)
+    WRITE(numout,*) 'Forest management : ',control_flags%forest_management
+
+    ! There is a difference between the behavior of the FM module with and without 
+    WRITE(numout,*) 'NOTICE: The forest_management flag results in different behavior if'
+    WRITE(numout,*) '        activated with the resource limited allocation scheme.  This '
+    WRITE(numout,*) '        is NOT the case for the functional allocation scheme, which '
+    WRITE(numout,*) '        ignores this flag completely.  If the management strategy is '
+    WRITE(numout,*) '        set to 1, no FM is done for functional allocation.'
+
+    
+    !
+    ! 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.
+    IF ( control_flags%ok_multilayer .AND. .NOT.(control_flags%ok_radcanopy) ) THEN
+       control_flags%ok_radcanopy  = .TRUE.
+       WRITE(numout,*) 'You want to use the multilayer model without activating the flag CANOPY_EXTINCTION'
+       WRITE(numout,*) 'We set CANOPY_EXTINCTION to TRUE to ensure consistency'
+    ENDIF
+    !
+    !Config Key   = STOMATE_WATCHOUT
+    !Config Desc  = STOMATE does minimum service
+    !Config If    = OK_SECHIBA 
+    !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.
+    !Config Units = [FLAG]
+    !
+    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.
+    !
+
+    !
+    ! Configuration : number of PFTs and parameters
+    !
+
+    ! 1. Number of PFTs defined by the user
+
+    !Config Key   = NVM
+    !Config Desc  = number of PFTs  
+    !Config If    = OK_SECHIBA or OK_STOMATE
+    !Config Def   = 13
+    !Config Help  = The number of vegetation types define by the user
+    !Config Units = [-]
+    !
+    CALL getin_p("NVM",nvm)
+    WRITE(numout,*)'the number of pfts used by the model is : ', nvm
+
+    ! 2. Should we read the parameters in the run.def file ?
+
+    !Config Key   = IMPOSE_PARAM
+    !Config Desc  = Do you impose the values of the parameters?
+    !Config if    = OK_SECHIBA or OK_STOMATE
+    !Config Def   = y
+    !Config Help  = This flag can deactivate the reading of some parameters.
+    !               Useful if you want to use the standard values without commenting the run.def
+    !Config Units = [FLAG]
+    !
+    CALL getin_p('IMPOSE_PARAM',impose_param)
+
+    ! 3. Allocate and intialize the pft parameters
+
+    CALL pft_parameters_main(control_flags)
+
+    ! 4. Activation sub-models of ORCHIDEE
+
+    CALL activate_sub_models(control_flags)
+
+    ! 5. Vegetation configuration (impose_veg, land_use, lcchange...previously in slowproc)
+
+    CALL veget_config
+
+    ! 6. Read the parameters in the run.def file  according the flags
+
+    IF (impose_param ) THEN 
+       CALL config_pft_parameters
+    ENDIF
+
+    IF ( control_flags%ok_sechiba ) THEN
+       IF (impose_param ) THEN
+          CALL config_sechiba_parameters(control_flags)
+          CALL config_sechiba_pft_parameters(control_flags)
+          WRITE(numout,*)'    some sechiba parameters have been imposed '
+       ENDIF
+    ENDIF
+    
+    ! Initialize variables in constantes_soil
+    CALL config_soil_parameters(control_flags, impose_param)
+! tzjsf test mettre control.f90 dont on a besoin ici        
+   CALL vertical_soil_init  !
+
+  nbdl = nslm
+    ALLOCATE(diaglev(nbdl), stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'control_initialize','Pb in allocation of diaglev','','')
+!    IF ( hydrol_cwrr ) THEN
+!       ! Get diaglev from module vertical for CWRR
+       diaglev=znt(1:nbdl)
+!    ELSE
+!       ! Calculate diaglev for Choisnel
+!       DO jv = 1, nbdl-1
+!           diaglev(jv) = zmaxh/(2**(nbdl-1) -1) * ( ( 2**(jv-1) -1) + (
+!           2**(jv)-1) ) / deux
+!      ENDDO
+!      diaglev(nbdl) = zmaxh
+!    END IF
+    IF (printlev>=2) WRITE(numout,*) 'In control_initialize, diaglev = ',diaglev
+
+ 
+
+    IF ( control_flags%ok_co2 ) THEN
+       IF ( impose_param ) THEN
+          CALL config_co2_parameters
+          WRITE(numout,*)'    some co2 parameters have been imposed '         
+       ENDIF
+    ENDIF
+    
+    IF ( control_flags%ok_stomate ) THEN
+       IF ( impose_param ) THEN
+          CALL config_stomate_parameters
+          CALL config_stomate_pft_parameters
+          WRITE(numout,*)'    some stomate parameters have been imposed '
+       ENDIF
+    ENDIF
+
+    ! Take care of the forestry parameters if needed, remembering that functional
+    ! allocation does forestry automatically.
+    IF ( control_flags%forest_management .OR. &
+         control_flags%ok_functional_allocation) THEN
+       IF ( impose_param ) THEN
+          CALL config_forest_manage_parameters
+          CALL config_forest_manage_pft_parameters
+          WRITE(numout,*)'    some forest management parameters have been imposed '
+       ENDIF
+    ENDIF
+    
+    IF ( control_flags%ok_dgvm ) THEN
+       IF ( impose_param ) THEN
+          CALL config_dgvm_parameters
+          WRITE(numout,*)'    some dgvm parameters have been imposed '         
+       ENDIF
+    ENDIF    
+
+    ! insert a check here to see if we have conflicting flags
+    SELECTCASE (albedo_type)
+    CASE ('standard')
+    CASE ('pinty')
+       IF(.NOT. control_flags%ok_functional_allocation)THEN
+          WRITE(numout,*) "If you are using Pinty's albedo scheme, you must also do functional plant allocation."
+          WRITE(numout,*) "Set STOMATE_FUNCTIONAL_ALLOCATION = y in run.def."
+!!!!!!!!! temp move         CALL ipslerr_p (3,'intersurf','intersurf','','')
+       ENDIF
+       IF(.NOT. control_flags%ok_stomate)THEN
+          WRITE(numout,*) "If you are using Pinty's albedo scheme, you must also activate stomate."
+          WRITE(numout,*) "Set STOMATE_OK_STOMATE = y in run.def."
+          CALL ipslerr_p (3,'intersurf','intersurf','','')
+       ENDIF
+    CASE DEFAULT
+       WRITE(numout,*) "Unsupported albedo type. ",albedo_type
+       CALL ipslerr_p (3,'intersurf','intersurf','','')
+    END SELECT
+
+    !
+    !
+    RETURN
+    !
+  END SUBROUTINE intsurf_config
+
+!! ================================================================================================================================
+!! SUBROUTINE   : intsurf_restart
+!!
+!>\BRIEF         This subroutine initialized the restart file for the land-surface scheme 
+!!
+!! DESCRIPTION  : 
+!!                
+!!                
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!! - 
+!!
+!! FLOWCHART    : 
+!_ ================================================================================================================================
+
+  SUBROUTINE intsurf_restart(istp, date0, dt, control_flags, rest_id, rest_id_stom, itau_offset)
+
+    USE mod_orchidee_para
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    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
+    TYPE(control_type), INTENT(in)              :: control_flags  !! Flags that (de)activate parts of the model
+
+    !! 0.2 Output variables
+
+    INTEGER(i_std), INTENT(out)                 :: rest_id        !! ID of the restart file
+    INTEGER(i_std), INTENT(out)                 :: rest_id_stom   !! ID of the restart file
+    INTEGER(i_std), INTENT(out)                 :: itau_offset    !!
+
+    !! 0.4 Local variables
+
+    REAL(r_std)                                 :: dt_rest        !!
+    REAL(r_std)                                 :: 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      !!
+    REAL(r_std)                                 :: 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 If    = OK_SECHIBA 
+    !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.
+    !Config Units = [FILE]
+!-
+    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 If    = OK_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.
+    !Config Units = [FILE]
+    !
+    CALL getin_p('SECHIBA_rest_out', restname_out)
+    !
+    !Config Key   = SECHIBA_reset_time
+    !Config Desc  = Override the time from the restart files for SECHIBA and STOMATE
+    !Config If    = OK_SECHIBA
+    !Config Def   = y
+    !Config Help  = This option allows the model to override the time
+    !Config         found in the restart files of SECHIBA and STOMATE with the time
+    !Config         given by the GCM or the forcing file.
+    !Config Units = [FLAG]
+    !
+    overwrite_time = .TRUE.
+    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.'
+          CALL ipslerr_p (3,'intersurf','intersurf','','')
+       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 of STOMATE
+       !Config If    = STOMATE_OK_STOMATE or 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.
+       !Config Units = [FILE]
+       !-
+       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 or 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.
+       !Config Units = [FILE]
+       !-
+       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
+!!
+!>\BRIEF         This subroutine initialized the history files for the land-surface scheme 
+!!
+!! DESCRIPTION  : 
+!!                
+!!                
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!! - 
+!!
+!! FLOWCHART    : 
+!_ ================================================================================================================================
+
+  SUBROUTINE intsurf_history(iim, jjm, lon, lat, kindex, kjpindex, istp_old, date0, dt, control_flags, hist_id, hist2_id, &
+       & hist_id_stom, hist_id_stom_IPCC)
+
+    USE mod_orchidee_para
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    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)                   :: kjpindex
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)      :: kindex
+    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
+
+    !! 0.2 Output variables 
+
+    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 ?)
+    INTEGER(i_std), INTENT(out)                  :: hist_id_stom       !! History file identification for STOMATE 
+    INTEGER(i_std), INTENT(out)                  :: hist_id_stom_IPCC  !! History file identification for IPCC
+
+    !! 0.4 Local variables
+
+    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=40)                            :: flux_insec  !! Operation in seconds
+    CHARACTER(LEN=40)                            :: flux_scinsec
+    INTEGER(i_std)                               :: hist_level, hist2_level     !! history output level (default is 10 => maximum output)
+    !! The various operation to be performed 
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: ave
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: avecels
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: avescatter
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: fluxop
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: fluxop_scinsec
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: tmincels
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: tmaxcels
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: once
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: sumscatter
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: t_min
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: tmax
+    !! The various operation to be performed for HF
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: ave2
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: avecels2
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: avescatter2
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: fluxop2
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: fluxop_scinsec2
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: tmincels2
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: tmaxcels2
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: once2
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: sumscatter2
+    !
+    CHARACTER(LEN=80)                            :: global_attribute              !! for writing attributes in the output files
+    INTEGER(i_std)                               :: i, jst
+    ! SECHIBA AXIS
+    INTEGER(i_std)                               :: hori_id                      !! ID of the default horizontal longitude and latitude map.
+    !! ID's for two vertical coordinates
+    INTEGER(i_std)                               :: vegax_id
+    INTEGER(i_std)                               :: laiax_id
+    INTEGER(i_std)                               :: solax_id
+    INTEGER(i_std)                               :: soltax_id
+    INTEGER(i_std)                               :: nobioax_id
+    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)                               :: canx_tot_id
+    !! ID's for two vertical coordinates HF
+    INTEGER(i_std)                               :: vegax_id2
+    INTEGER(i_std)                               :: laiax_id2
+    INTEGER(i_std)                               :: solax_id2
+    INTEGER(i_std)                               :: soltax_id2
+    INTEGER(i_std)                               :: nobioax_id2
+    INTEGER(i_std)                               :: albax_id2
+    INTEGER(i_std)                               :: solayax_id2                   !! ID for the vertical axis of the CWRR hydrology 
+    ! STOMATE AXIS
+    INTEGER(i_std)                               :: hist_PFTaxis_id
+    INTEGER(i_std)                               :: hist_pool_s_axis_id
+    INTEGER(i_std)                               :: hist_pool_m_axis_id
+    INTEGER(i_std)                               :: hist_pool_l_axis_id
+    INTEGER(i_std)                               :: hist_pool_ss_axis_id
+    INTEGER(i_std)                               :: hist_pool_mm_axis_id
+    INTEGER(i_std)                               :: hist_pool_ll_axis_id
+    INTEGER(i_std)                               :: canx_id
+    INTEGER(i_std)                               :: canx_tot_stom_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(nlai+1)               :: lai
+    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
+    REAL(r_std), DIMENSION(nlevels)              :: canlev
+    !
+    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(nshort)               :: hist_pool_s_axis   !! Deforestation axis
+    REAL(r_std), DIMENSION(nmedium)              :: hist_pool_m_axis   !! Deforestation axis
+    REAL(r_std), DIMENSION(nlong)                :: hist_pool_l_axis   !! Deforestation axis
+    REAL(r_std), DIMENSION(nshort+1)             :: hist_pool_ss_axis  !! Deforestation axis
+    REAL(r_std), DIMENSION(nmedium+1)            :: hist_pool_mm_axis  !! Deforestation axis
+    REAL(r_std), DIMENSION(nlong+1)              :: hist_pool_ll_axis  !! 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
+    REAL(r_std), DIMENSION(nlevels_tot)          :: z_levels_tot       !! A dummy array to label canopy levels
+    INTEGER(i_std)                               :: ilev,ivm,icir           !! Index
+!_ ================================================================================================================================
+    !
+    !=====================================================================
+    !- 3.0 Setting up the history files
+    !=====================================================================
+    !- 3.1 SECHIBA
+    !=====================================================================
+    !Config Key   = ALMA_OUTPUT
+    !Config Desc  = Should the output follow the ALMA convention
+    !Config If    = OK_SECHIBA
+    !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.
+    !Config Units = [FLAG]
+    !-
+    almaoutput = .FALSE.
+    CALL getin_p('ALMA_OUTPUT', almaoutput)    
+    WRITE(numout,*) 'ALMA_OUTPUT', almaoutput
+    !---------------------------------------------------------------------
+    ! NOTICE: The ALMA convention changes the units that are used.  In order
+    ! to deal with this, it appears that the histdefs and histwrites have
+    ! adapted a convention that a variable is written and declared with
+    ! a capital first letter for ALMA output (e.g., Z0) and a lower case
+    ! first letter for non-ALMA output (z0).
+    !---------------------------------------------------------------------
+    !-
+    !Config Key   = OUTPUT_FILE
+    !Config Desc  = Name of file in which the output is going to be written
+    !Config If    = OK_SECHIBA
+    !Config Def   = sechiba_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.
+    !Config Units = [FILE]
+    !-
+    histname='sechiba_history.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 If    = OK_SECHIBA
+    !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 !
+    !Config Units = [seconds]
+    !-
+    dw = one_day
+    CALL getin_p('WRITE_STEP', dw)
+    IF ( dw == 0 ) WRITE(numout,*) ' sechiba_history file will not be created' 
+    !
+    veg(1:nvm)   = (/ (REAL(i,r_std),i=1,nvm) /)
+    lai(1:nlai+1) = (/ (REAL(i,r_std),i=1,nlai+1) /)
+    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) /)
+
+    ! Get the vertical soil levels for the thermal scheme
+!    sol(1:ngrnd) = thermosoil_levels()
+!    IF (hydrol_cwrr) THEN
+       sol(1:ngrnd) = znt(:)
+!    ELSE
+!       soilth_lev(1:ngrnd) = thermosoilc_levels()
+!    END IF
+
+    !
+    !- 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_insec,'("ave(X*",F8.6,")")') un/dt
+    !    WRITE(flux_insec,'("ave(X*",F12.10,")")') un/dt
+    WRITE(flux_scinsec,'("ave(scatter(X*",F12.9,"))")') un/dt
+    WRITE(numout,*) 'flux_op=',flux_op,' one_day/dt=', one_day/dt, ' dt=',dt,' dw=', dw
+    !-
+    !Config Key   = SECHIBA_HISTLEVEL
+    !Config Desc  = SECHIBA history output level (0..10)
+    !Config If    = OK_SECHIBA and HF
+    !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 Units = [-]
+    !-
+    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
+       CALL ipslerr_p (3,'intersurf','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(scatter(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
+
+    avecels(1:max_hist_level) = 'ave(cels(scatter(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(scatter(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(scatter(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
+    t_min(1:max_hist_level) = 't_min'
+    IF (hist_level < max_hist_level) THEN
+       t_min(hist_level+1:max_hist_level) = 'never'
+    ENDIF
+    tmax(1:max_hist_level) = 't_max(scatter(X))'
+    IF (hist_level < max_hist_level) THEN
+       tmax(hist_level+1:max_hist_level) = 'never'
+    ENDIF
+
+    !- Initialize sechiba_history output file
+    !- 
+    IF ( dw == 0 ) THEN
+       ! sechiba_history file will not be created.
+       hist_id = -1
+
+    ELSE
+       ! sechiba_history file will be created
+
+       !- Calculation necessary for initialization of sechiba_history file
+       !- Check if we have by any change a rectilinear grid. This would allow us to 
+       !- simplify the output files.
+       IF (is_omp_root) THEN
+
+          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
+                CALL ipslerr_p (3,'intersurf','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
+                CALL ipslerr_p (3,'intersurf','intersurf history','','')
+             ENDIF
+             lon_rect(:) = lon(:,1)
+             lat_rect(:) = lat(1,:)
+          ENDIF
+          !-
+          !-
+          !-
+          ! Initialize sechiba_history file
+          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, 'laiax', 'Nb LAI', '1', &
+                  &    nlai+1,   lai, laiax_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, diaglev(1:nslm), solayax_id)
+             ENDIF
+             ! For the number of canopy levels including all those used in photosynthesis.
+             ! Notice we cannot use the real heights here, since they can change every day
+             ! as the canopy develops.
+             DO ilev=1,nlevels_tot
+                z_levels_tot(ilev)=REAL(ilev,r_std)
+             ENDDO
+             CALL histvert(hist_id, 'canleveltot', 'Total canopy levels', '-', &
+                  &    nlevels_tot,  z_levels_tot, canx_tot_id)
+
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! This is where we need to add all of our variables for
+             ! sechiba that we want to print out.  For production,
+             ! we will use histlevel = 1.  For optimization, we will use
+             ! histlevel = 2.  Histlevel = 3 are variables that we've
+             ! looked at but do not want printed out anymore.
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+             ! Production (histlevel = 1)
+
+             ! Added by MJM
+             CALL histdef(hist_id, 'alb_vis', 'Albedo visible', '', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(1), dt,dw)
+             CALL histdef(hist_id, 'alb_nir', 'Albedo near infrared', '', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(1), dt,dw)
+             CALL histdef(hist_id, 'snowfrac', 'Snow cover fraction', '',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(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)
+            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', 'm3/m3', &
+                        & iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32, avescatter(1),  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(1),  dt,dw)
+
+                   ! var_name= "kfact_root_1" ... "kfact_root_3"
+                   WRITE (var_name,"('kfactroot_',i1)") jst
+                   CALL histdef(hist_id, var_name, 'Root fraction profile for soil type', '%', &
+                        & iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32, avescatter(1), dt,dw)
+                ! three variables were added by yitong yao 4 Jan 2021
+                 WRITE (var_name,"('soilwaterinf_',i1)") jst
+                   CALL histdef(hist_id, var_name, 'soil water infilt', '%', &
+                        & iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32, avescatter(1), dt,dw)
+
+                  WRITE (var_name,"('soildtinf_',i1)") jst
+                   CALL histdef(hist_id, var_name, 'soil dt infilt', '%', &
+                        & iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32,avescatter(1), dt,dw)
+                
+                  WRITE (var_name,"('soilinfilttmp_',i1)") jst
+                   CALL histdef(hist_id, var_name, 'soil infilt tmp', '%', &
+                        & iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32, avescatter(1), dt,dw)
+                  WRITE (var_name,"('soilkm_',i1)") jst
+                   CALL histdef(hist_id, var_name, 'soil km', '%', &
+                        & iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32, avescatter(1), dt,dw)
+                 WRITE (var_name,"('soilsmcinfilt_',i1)") jst
+                   CALL histdef(hist_id, var_name, 'soil smc infilt', '%', &
+                        & iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32, avescatter(1), dt,dw)
+
+                 WRITE (var_name,"('soilresinfilt_',i1)") jst
+                   CALL histdef(hist_id, var_name, 'soil res infilt', '%', &
+                        & iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32, avescatter(1), dt,dw)
+
+ 
+                ! above added                    
+
+
+ 
+                  ! tzj write phi soil per layer
+                  WRITE (var_name,"('phi_soil_',i1)") jst
+                  CALL histdef(hist_id, var_name, 'Phisoil profil', 'MPa', &
+                  & iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32,avescatter(1),  dt,dw)  
+
+                ENDDO
+jst=2
+                  WRITE (var_name,"('res_soil_',i1)") jst
+                  CALL histdef(hist_id, var_name, 'res_soil profil', 'runits', &
+                  & iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32,avescatter(1),  dt,dw)
+
+                  WRITE (var_name,"('e_max_',i1)") jst
+                  CALL histdef(hist_id, var_name, 'emax profil', 'runits', &
+                  & iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32,avescatter(1),  dt,dw)
+
+!                  WRITE (var_name,"('ksave_',i1)") jst
+!                  CALL histdef(hist_id, var_name, 'ksave profil', 'runits', &
+!                  & iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32,avescatter(1),  dt,dw)
+                  
+                  CALL histdef(hist_id, 'e_frac_2', 'e frac soil', 'runits', &
+                  & iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32,avescatter(1),  dt,dw)
+
+!tzjh
+!
+                CALL histdef(hist_id, 'soiltotalinfilt', 'total infiltration', 'mm/d', &
+                     & iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, fluxop(4), dt,dw)
+                CALL histdef(hist_id, 'begininfilt', 'begin to infilt', 'mm/d', &
+                     & iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, fluxop(4), dt,dw)
+
+
+!                       
+     DO icir = 1, ncirc
+          WRITE (var_name,"('PHI_soilroot_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'psi_soilroot_circ ', '-MPa',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+          WRITE (var_name,"('PSLeaf_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'psileaf ', '-MPa',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+          WRITE (var_name,"('PSStem_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'psistem ', '-MPa',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+          WRITE (var_name,"('PSRoot_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'psiroot ', '-MPa',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+          WRITE (var_name,"('stemPLC_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'stem percentage loos conductivity ','%',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+          WRITE (var_name,"('vl_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'amount of water in the leaves ','mmol',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+          WRITE (var_name,"('vx_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'amount of water in the stem ','mmol',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+          WRITE (var_name,"('vr_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'amount of water in the roots ','mmol',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+          WRITE (var_name,"('optileaf_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'info ','na',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+        
+          WRITE (var_name,"('v_storage_leaf_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'water from leaf water storage','mmol',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+        
+          WRITE (var_name,"('v_hydr_leaf_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'water from stem to leaf pathway','mmol',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+        
+          WRITE (var_name,"('v_hydr_leaf_vert_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'water from stem to leaf pathway','mmol',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+ 
+          WRITE (var_name,"('v_storage_stem_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'water from stem water storage','mmol',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+          WRITE (var_name,"('v_hydr_stem_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'water from root to stem pathway','mmol',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+          WRITE (var_name,"('v_storage_root_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'water from root water storage','mmol',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+
+
+ 
+          WRITE (var_name,"('tzj_Et_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'water from leaf to atm','mmol',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+          
+          WRITE (var_name,"('tzj_stem_volume_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'stem volume','mmol',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+          WRITE (var_name,"('tzj_root_volume_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'root volume','mmol',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+          WRITE (var_name,"('tzj_canopy_LAI_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'leaf area index','m2/m2',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+          WRITE (var_name,"('optistem_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'INFO for psi stem ','na',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+          WRITE (var_name,"('optiroot_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'INFO for psi root ','na',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+ 
+          WRITE (var_name,"('tzj_gsh_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'gsh_tzj ', 'mmol/m2/s',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+          WRITE (var_name,"('tzj_supply_',i3.3)") icir
+          CALL histdef(hist_id, var_name, 'tzj_supply ', 'mm/h/2',&
+               & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+     ENDDO
+
+
+
+
+
+             ENDIF
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by YC
+             ! Energy componments for the Energy Budget
+             CALL histdef(hist_id, 'fluxnet', 'Net Radiation Flux', 'W/m^2', &
+                  & iim, jjm, hori_id, 1, 1, 1, -99, 32, ave(1), dt, dw)
+             CALL histdef(hist_id, 'fluxsoil', 'Soil/Ground Heat Flux', 'W/m^2', &
+                  & iim, jjm, hori_id, 1, 1, 1, -99, 32, ave(1), dt, dw)
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++     
+             
+             
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by SBL 
+             CALL histdef(hist_id, 'evapot', 'Potential evaporation', 'mm/d',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(1), dt,dw)
+             CALL histdef(hist_id, 'evapot_corr', 'Potential evaporation', 'mm/d',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(1), dt,dw)
+             CALL histdef(hist_id, 'transpir', 'Transpiration', 'mm/d', &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(1), dt,dw)
+             CALL histdef(hist_id, 'transpir_init', 'Initial transpiration', 'mm/d', &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(1), dt,dw)
+             CALL histdef(hist_id, 'transpot', 'Potential transpiration', 'mm/d', &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(1), dt,dw)
+             CALL histdef(hist_id, 'transpir_supply', 'Water supply for transpiration', 'mm/d', &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(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)
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by JR
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by JO
+             !- Vegetation
+             !-
+             CALL histdef(hist_id, 'vegetfrac', 'Fraction of vegetation', '1', &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(1), dt,dw)
+             CALL histdef(hist_id, 'maxvegetfrac', 'Maximum fraction of vegetation', '1', &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(1), dt,dw)
+
+             !-  General energy balance
+             !-
+             CALL histdef(hist_id, 'tair', 'Near surface air temperature at forcing level', 'K',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(1), dt,dw)
+             CALL histdef(hist_id, 'qair', 'Near surface specific humidity at forcing level', 'g/g',  &
+                  & 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, 'swnet', 'Net shortwave radiation', 'W/m^2',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(1), dt,dw)
+            
+             !- Surface state
+             !-
+             CALL histdef(hist_id, 'swe', 'Snow Water Equivalent', 'kg/m^2', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
+
+
+             !- Surface turbulence
+             !-
+             CALL histdef(hist_id, 'z0', 'Roughness height', 'm',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
+
+             !-  Cold Season Processe
+             CALL histdef(hist_id, 'snowdepth', '3D snow depth', 'm', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
+
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by KN
+
+             !----------------------------------------------------------
+             ! HIST_LEVEL = 2
+             !----------------------------------------------------------
+
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by MJM
+             CALL histdef(hist_id, 'fluxsens', 'Sensible Heat Flux', 'W/m^2',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(2), dt,dw)
+             CALL histdef(hist_id, 'fluxlat', 'Latent Heat Flux', 'W/m^2',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(2), dt,dw)
+             ! This should only be written out once a year, on the first day, so you should not
+             ! need to correct for averaging.
+             CALL histdef(hist_id, 'sum_veget_diff', 'Difference in vegetation fractions between this year and next', '', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(2), dt,dw)
+             !+++++++++++++++++++++++++++
+             ! Added by SBL
+             CALL histdef(hist_id,'laieffpix', 'Effective Leaf Area Index per pixel', &
+                  &               '-', iim,jjm, hori_id, &
+                  &               1,1,1,-99,32, ave(2), dt, dw)
+             
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by JR
+             CALL histdef(hist_id, 'vbeta1', 'Beta for sublimation', '1',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(2), dt,dw)
+             CALL histdef(hist_id, 'vbeta2', 'Beta for canopy interception', '1',  &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(2), dt,dw)
+             CALL histdef(hist_id, 'vbeta3', 'Beta for vegetation', '1',  &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(2), dt,dw)
+             CALL histdef(hist_id, 'vbeta3pot', 'Beta for potential vegetation resistance', '1',  &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(2), dt,dw)
+             CALL histdef(hist_id, 'vbeta4', 'Beta for bare soil', '1',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(2), dt,dw)
+             CALL histdef(hist_id, 'vbeta5', 'Beta for floodplains', '1',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(2), dt,dw)
+
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by JO
+
+             !- 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(2), dt,dw)
+             CALL histdef(hist_id, 'rainf', 'Rainfall rate', 'kg/m^2/s',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(2), dt,dw)
+     
+
+             !-  Evaporation components
+             !-
+ 	     CALL histdef(hist_id, 'evap', 'Total Evapotranspiration', 'mm/d', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(2), dt,dw)
+
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by KN
+
+
+             !  CALL histdef(hist_id,'Abslight', 'Absorbed light in the canopy', &
+             ! &               '-', iim,jjm, hori_id, &
+             ! &               nvm,1,nvm,vegax_id,32, ave(2), dt, dw)
+
+
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+             ! Debugging (histlevel = 3)
+             CALL histdef(hist_id, 'photo_warn', 'Divide by zero in photosynthesis', '-',  &
+                  & iim,jjm, hori_id, nvm,1,nvm, vegax_id, 32, ave(3), dt,dw)
+
+
+
+             ! I'm changing all the variables below this line to be written
+             ! out at level four or higher.
+             CALL histdef(hist_id, 'coastalflow', 'Diffuse coastal flow', 'm^3/s', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(4), 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(4), dt,dw) 
+             CALL histdef(hist_id, 'rain', 'Rainfall', 'mm/d',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(4), dt,dw)
+             !CALL histdef(hist_id, 'netrad', 'Net radiation', 'W/m^2',  &
+             !     & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             CALL histdef(hist_id, 'lai', 'Leaf Area Index', '1', &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(4), dt,dw)
+
+             !
+             IF (  control_flags%hydrol_cwrr ) THEN
+                CALL histdef(hist_id, 'reinf_slope', 'Slope index for each grid box', '1', &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, once(4),  dt,dw)
+                CALL histdef(hist_id, 'soilindex', 'Soil index', '1', &
+                     & iim,jjm, hori_id, 1, 1, 1, -99, 32, once(4),  dt,dw)
+             ENDIF
+             !
+             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(4), 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(4), dt,dw)  
+             ENDIF
+             !-
+             !- SECHIBA_HISTLEVEL = 2
+             !-
+             CALL histdef(hist_id, 'subli', 'Sublimation', 'mm/d', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(4), dt,dw)
+             CALL histdef(hist_id, 'evapnu', 'Bare soil evaporation', 'mm/d', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(4), dt,dw)
+             CALL histdef(hist_id, 'runoff', 'Surface runoff', 'mm/d', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(4), dt,dw)
+             CALL histdef(hist_id, 'drainage', 'Deep drainage', 'mm/d', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(4), 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(4), 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(4), 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(4), 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(4), 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(4), 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(4), dt,dw)
+             ENDIF
+             !
+             !          CALL histdef(hist_id, 'tair', 'Air Temperature', 'K',  &
+             !               & iim,jjm, hori_id, 1,1,1, -99, 32, ave(4), dt,dw)
+             !          CALL histdef(hist_id, 'qair', 'Air humidity', 'g/g',  &
+             !               & iim,jjm, hori_id, 1,1,1, -99, 32, ave(4), 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(4), dt,dw)
+             CALL histdef(hist_id, 't2m', '2m Air Temperature', 'K',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(4), dt,dw)
+             ! Fin ajouts Nathalie
+             ! Ajouts Nathalie - Septembre 2008
+             CALL histdef(hist_id, 'soilalb_vis', 'Soil Albedo visible', '1', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             CALL histdef(hist_id, 'soilalb_nir', 'Soil Albedo near infrared', '1', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             CALL histdef(hist_id, 'vegalb_vis', 'Vegetation Albedo visible', '1', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             CALL histdef(hist_id, 'vegalb_nir', 'Vegetation Albedo near infrared', '1', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             ! Fin ajouts Nathalie - Septembre 2008
+             CALL histdef(hist_id, 'roughheight', 'Effective roughness height', 'm',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             CALL histdef(hist_id, 'transpir_supplysec', 'Water supply for transpiration', 'kg/m2/s', &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(4), dt,dw)
+             CALL histdef(hist_id, 'phi_soilroot', 'Sum of the soil water potential &
+                  & in each layer weighted by the relative share of the roots in the layer', 'MPa',&
+                  & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+             CALL histdef(hist_id, 'phi_soilroot2', 'Sum of the soil water potential &
+                  & in each layer weighted by the relative share of the roots inthe layer', 'MPa',&
+                  & iim,jjm,hori_id, nvm, 1, nvm,vegax_id, 32, ave(4), dt,dw)
+
+             CALL histdef(hist_id, 'VPD_tzj', 'VPD from tzj', 'kPa', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(4), dt,dw)
+              
+
+             CALL histdef(hist_id, 'transpir_tot_tzj', 'Water supply for transpiration','mm/d', &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(4),dt,dw)
+             CALL histdef(hist_id, 'gsh', 'stomatal conductance hydro','mm/d', &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(4),dt,dw) ! ave(4)
+             CALL histdef(hist_id, 'inter', 'Interception loss', 'mm/d', &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(4), dt,dw)
+
+             CALL histdef(hist_id, 'tzj_supply', 'tzj_transpir_supply','mm/d', &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(4),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(4), dt,dw)
+             CALL histdef(hist_id, 'tsol_min', 'Minimum Surface Temperature',&
+                  & 'C', iim,jjm, hori_id, 1,1,1, -99, 32, tmincels(4), dt,dw)
+             CALL histdef(hist_id, 'snow', 'Snow mass', 'mm/day', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             CALL histdef(hist_id, 'snowage', 'Snow age', '?', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), 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(4), dt,dw)
+             CALL histdef(hist_id, 'snownobioage', 'Snow age on other surfaces', 'd', &
+                  & iim,jjm, hori_id, nnobio,1, nnobio, nobioax_id, 32, avescatter(4), dt,dw)
+             IF ( control_flags%do_floodplains ) THEN
+                CALL histdef(hist_id, 'flood_frac', 'Flooded fraction', '1', &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+                CALL histdef(hist_id, 'reinfiltration', 'Reinfiltration from floodplains', 'mm/d', &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(4), dt,dw)
+             ENDIF
+             !
+             CALL histdef(hist_id, 'frac_bare', 'Bare soil fraction for each tile', '-', &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(4), dt,dw)
+             CALL histdef(hist_id, 'soiltile', 'Fraction of soil tiles', '%', &
+                  & iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, once(4),  dt,dw)
+             CALL histdef(hist_id, 'swi', 'Soil wetness index','',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             !CALL histdef(hist_id,'','coeffcient of drainage in each tile','%',& 
+             !     & iim,jjm,hori_id,nstm,1,nstm,soltax_id,32,once(4), dt, dw)
+             CALL histdef(hist_id, 'free_drain_coef_o','free_drain_coef for soil type', 'mm/d', &
+                     & iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, fluxop(4), dt,dw)
+
+             !-
+             !- SECHIBA_HISTLEVEL = 4
+             !-
+             !CALL histdef(hist_id, 'nobiofrac', 'Fraction of other surface types', '1', &
+             !     & iim,jjm, hori_id, nnobio, 1, nnobio, nobioax_id, 32, avescatter(4), dt,dw)
+             !CALL histdef(hist_id, 'treeFrac', "Tree Cover Fraction", "%", &
+             !     & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
+             !CALL histdef(hist_id, 'grassFrac', "Natural Grass Fraction", "%", &
+             !     & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
+             !CALL histdef(hist_id, 'cropFrac', "Crop Fraction", "%", &
+             !     & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
+             !CALL histdef(hist_id, 'baresoilFrac', "Bare Soil Fraction", "%", &
+             !     & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
+             CALL histdef(hist_id, 'tot_bare_soil', "Total Bare Soil Fraction", "%", &
+                  & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), 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(4), dt,dw)
+             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', 'Kg/m^2',  &
+                     & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
+                CALL histdef(hist_id, 'bqsb', 'Lower Soil Moisture', 'Kg/m^2',  &
+                     & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
+             ELSE
+                CALL histdef(hist_id, 'humtot', 'Total Soil Moisture', 'Kg/m^2', &
+                     & 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/m^2', &
+                     & iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, avescatter(4), dt,dw)
+                CALL histdef(hist_id, 'njsc', 'Soil class used for hydrology', '-', &
+                     & iim,jjm, hori_id, 1, 1, 1, -99, 32, once(4), dt,dw)
+             ENDIF
+          
+           CALL histdef(hist_id, 'twbr', 'Total water balance residual', 'Kg/m^2', &
+                     & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
+
+ 
+            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(4), 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
+             !-
+
+             ! Absorbed light in the canopy
+             ! I want to write this out as a function of canopy level
+             ! and not PFT, since it will make for easier plotting.
+             ! This variable takes up a lot of space, and therefore
+             ! I'm putting it at a fairly high hist level.
+             DO ivm=1,nvm
+
+                WRITE(var_name,'(A,I3.3)') 'ABS_CANOPY_LIGHT_',ivm
+                CALL histdef (hist_id, &
+                     &               TRIM(var_name), &
+                     &               TRIM("Fraction of light that reaches this canopy level which is absorbed"), &
+                     &               TRIM("-               "), iim,jjm, hori_id, &
+                     &               nlevels_tot,1,nlevels_tot, canx_tot_id, 32, ave(5), dt, dw)
+             ENDDO
+
+             !          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)
+             !-
+             !- 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)
+
+                !-
+                !- SECHIBA_HISTLEVEL = 8
+                !-
+                CALL histdef(hist_id, 'pondr', 'Ponds reservoir', 'kg/m^2', &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
+                CALL histdef(hist_id, 'swampmap', 'Map of swamps', 'm^2', &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, once(8), dt,dw)
+                !
+                IF ( control_flags%do_irrigation ) THEN
+                   CALL histdef(hist_id, 'irrigation', 'Net irrigation', 'mm/d', &
+                        & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(8), dt,dw)
+                   CALL histdef(hist_id, 'netirrig', 'Net irrigation requirement', 'mm/d', &
+                        & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(8), dt,dw)
+                   CALL histdef(hist_id, 'irrigmap', 'Map of irrigated surfaces', 'm^2', &
+                        & iim,jjm, hori_id, 1,1,1, -99, 32, once(8), dt,dw)
+                ENDIF
+                IF ( control_flags%do_floodplains ) THEN
+                   CALL histdef(hist_id, 'floodmap', 'Map of floodplains', 'm^2', &
+                        & iim,jjm, hori_id, 1,1,1, -99, 32, once(8), dt,dw)
+                   CALL histdef(hist_id, 'floodh', 'Floodplains height', 'mm', &
+                        & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
+                   CALL histdef(hist_id, 'floodr', 'Floodplains reservoir', 'kg/m^2', &
+                        & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
+                   CALL histdef(hist_id, 'floodout', 'Flow out of floodplains', 'mm/d', &
+                        & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(8), dt,dw)
+                   CALL histdef(hist_id, 'evapflo', 'Floodplains evaporation', 'mm/d', &
+                        & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(8), dt,dw)
+                ENDIF
+                !
+             ENDIF
+
+             IF ( control_flags%hydrol_cwrr ) THEN
+                CALL histdef(hist_id, 'k_litt', 'Litter cond', 'mm/d', &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
+             ENDIF
+             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
+             !
+             CALL histdef(hist_id, 'qsatt' , 'Surface saturated humidity', 'g/g', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
+             IF ( control_flags%ok_co2 ) THEN
+                CALL histdef(hist_id, 'gsmean', 'mean stomatal conductance', 'umol/m2/s', &
+                     & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(8), dt,dw)
+             ENDIF
+             CALL histdef(hist_id, 'humrel', 'Soil moisture stress', '-',  &
+                  & iim,jjm, hori_id, nvm,1,nvm, vegax_id, 32, avescatter(8), dt,dw)
+             !-
+             !- SECHIBA_HISTLEVEL = 9
+             !-
+             !-
+             !- SECHIBA_HISTLEVEL = 10
+             !-
+             IF ( control_flags%ok_co2 ) THEN
+                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)
+             ENDIF
+             CALL histdef(hist_id, 'rveget', 'Canopy resistance', 's/m', &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(10), dt,dw)
+             IF ( .NOT. control_flags%hydrol_cwrr ) THEN
+                CALL histdef(hist_id, 'rsol', 'Soil resistance', 's/m',  &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(10), dt,dw)
+             ENDIF
+             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, fluxop_scinsec(11), dt,dw)
+
+                CALL histdef(hist_id, 'mrro', "Total Runoff", "kg m-2 s-1", &
+                     & iim,jjm, hori_id, 1, 1, 1, -99, 32, fluxop_scinsec(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, fluxop_scinsec(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, fluxop_scinsec(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, fluxop_scinsec(11), dt,dw)
+
+             CALL histdef(hist_id, 'tran', "Transpiration", "kg m-2 s-1", &
+                  & iim,jjm, hori_id, 1, 1, 1, -99, 32, fluxop_scinsec(11), dt,dw)
+
+                    
+             IF ( control_flags%ok_inca ) THEN
+                CALL histdef(hist_id, 'PAR', 'PAR', 'umol phot/m^2/s',  &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(11), dt,dw)
+                IF ( control_flags%ok_radcanopy ) THEN
+                   CALL histdef(hist_id, 'PARsun', 'Sunlit Leaf PAR', 'umol phot/m^2/s', &
+                        & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                   CALL histdef(hist_id, 'PARsh', 'Shaded Leaf Area PAR', 'umol phot/m^2/s', &
+                        & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                   CALL histdef(hist_id, 'laisun', 'Sunlit Leaf Area Index', '1', &
+                        & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                   CALL histdef(hist_id, 'laish', 'Shaded Leaf Area Index', '1', &
+                        & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                   CALL histdef(hist_id, 'Fdf', 'Fdf', '1',  &
+                        & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(11), dt,dw)
+                   IF ( control_flags%ok_multilayer ) then 
+                      CALL histdef(hist_id, 'PARsuntab', 'Sunlit Leaf PAR', 'umol phot/m^2/s', &
+                           & iim,jjm, hori_id, nlai+1, 1, nlai+1, laiax_id, 32, avescatter(11), dt,dw)
+                      CALL histdef(hist_id, 'PARshtab', 'Shaded Leaf Area PAR', 'umol phot/m^2/s', &
+                           & iim,jjm, hori_id, nlai+1, 1, nlai+1, laiax_id, 32, avescatter(11), dt,dw)
+                   ENDIF
+                   CALL histdef(hist_id, 'PARdf', 'PARdf', '1',  &
+                        & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(11), dt,dw)
+                   CALL histdef(hist_id, 'PARdr', 'PARdr', '1',  &
+                        & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(11), dt,dw)
+                   CALL histdef(hist_id, 'Trans', 'Trans', '1',  &
+                        & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(11), dt,dw)
+                   CALL histdef(hist_id, 'Day', 'Day', '1',  &
+                        & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(11), dt,dw)
+                   CALL histdef(hist_id, 'Year_length', 'Year_length', '1',  &
+                        & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(11), dt,dw)
+                END IF
+
+                CALL histdef(hist_id, 'flx_fertil_no', 'flx_fertil_no', 'ngN/m^2/s', &
+                     & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                CALL histdef(hist_id, 'CRF', 'CRF', '1', &
+                     & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                CALL histdef(hist_id, 'flx_co2_bbg_year', 'flx_co2_bbg_year', 'kgC/m^2/yr ', &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, once(11), dt,dw)  
+                CALL histdef(hist_id, 'N_qt_WRICE_year', 'N_qt_WRICE_year', 'kgN/yr ', &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, once(11), dt,dw)  
+                CALL histdef(hist_id, 'N_qt_OTHER_year', 'N_qt_OTHER_year', 'kgN/yr ', &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, once(11), dt,dw)  
+                CALL histdef(hist_id, 'ptnlev1', 'ptnlev1', 'K',  &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(11), dt,dw)
+                CALL histdef(hist_id, 'flx_iso', 'flx_iso', 'kgC/m^2/s', &
+                     & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                CALL histdef(hist_id, 'flx_mono', 'flx_mono', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                CALL histdef(hist_id, 'flx_ORVOC', 'flx_ORVOC', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                CALL histdef(hist_id, 'flx_MBO', 'flx_MBO', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                CALL histdef(hist_id, 'flx_methanol', 'flx_methanol', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                CALL histdef(hist_id, 'flx_acetone', 'flx_acetone', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                CALL histdef(hist_id, 'flx_acetal', 'flx_acetal', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                CALL histdef(hist_id, 'flx_formal', 'flx_formal', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                CALL histdef(hist_id, 'flx_acetic', 'flx_acetic', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                CALL histdef(hist_id, 'flx_formic', 'flx_formic', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                CALL histdef(hist_id, 'flx_no_soil', 'flx_no_soil', 'ngN/m^2/s',&
+                     & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+                CALL histdef(hist_id, 'flx_no', 'flx_no', 'ngN/m^2/s',&
+                     & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(11), dt,dw)
+             ENDIF
+
+          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, diaglev(1:nslm), solayax_id)
+             ENDIF
+
+             ! These are added to make sure that the code runs with ALMA output
+             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, '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, 'Qg', 'Ground heat flux', 'W/m^2',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), 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)
+             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, '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, 'SWnet', 'Net shortwave radiation', 'W/m^2',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(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, 'AvgSurfT', 'Average surface temperature', 'K', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(1), dt,dw)
+             CALL histdef(hist_id, 'Tair', 'Near surface air temperature at forcing level', 'K',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(2), dt,dw)
+             CALL histdef(hist_id, 'Qair', 'Near surface specific humidity at forcing level', 'g/g',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(2), dt,dw)
+             !-
+             !-  Vegetation
+             !-
+             CALL histdef(hist_id, 'Qv', 'Energy of sublimation', 'W/m^2',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), 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(4), 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(4), dt,dw)
+             !-
+             !- General water balance
+             !-
+             CALL histdef(hist_id, 'Rainf', 'Rainfall rate', 'kg/m^2/s',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(4), dt,dw)
+             CALL histdef(hist_id, 'Qs', 'Surface runoff', 'kg/m^2/s', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(4), 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(4), dt,dw)
+             CALL histdef(hist_id, 'Qsm', 'Snowmelt', 'kg/m^2/s', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(4), dt,dw)
+             CALL histdef(hist_id, 'DelSoilMoist', 'Change in soil moisture', 'kg/m^2',  &
+                  & iim,jjm, hori_id, 1, 1, 1, -99, 32, sumscatter(4), dt,dw)
+             CALL histdef(hist_id, 'DelSurfStor', 'Change in Surface Water Storage','kg/m^2',&
+                  & iim,jjm, hori_id, 1, 1, 1, -99, 32, sumscatter(4), dt,dw)
+             CALL histdef(hist_id, 'DelIntercept', 'Change in interception storage', 'kg/m^2',  &
+                  & iim,jjm, hori_id, 1, 1, 1, -99, 32, sumscatter(4), dt,dw)
+             CALL histdef(hist_id, 'DelSWE', 'Change in Snow Water Equivalent', 'kg/m^2',  &
+                  & iim,jjm, hori_id, 1, 1, 1, -99, 32, sumscatter(4), dt,dw)
+             IF ( control_flags%do_irrigation ) THEN
+                CALL histdef(hist_id, 'Qirrig', 'Irrigation', 'kg/m^2/s', &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(4), dt,dw)
+                CALL histdef(hist_id, 'Qirrig_req', 'Irrigation requirement', 'kg/m^2/s', &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(4), dt,dw)
+             ENDIF
+             !-
+             !- Surface state
+             !-
+             CALL histdef(hist_id, 'avgsurft', 'Average surface temperature', 'K', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(4), dt,dw)
+             CALL histdef(hist_id, 'PotSurfT', 'Potential (Unstressed) surface temperature', 'K', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(4), dt,dw)
+             CALL histdef(hist_id, 'RadT', 'Surface radiative temperature', 'K', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, ave(4), dt,dw)
+             ! Notice that this albedo is a merge of the individual spectral bands.
+             CALL histdef(hist_id, 'Albedo', 'Albedo', '1', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             CALL histdef(hist_id, 'SurfStor', 'Surface Water Storage','kg/m^2',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             CALL histdef(hist_id, 'SWE', 'Snow Water Equivalent', 'kg/m^2', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), 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(4), 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(4), dt,dw)
+             ENDIF
+             CALL histdef(hist_id, 'SoilWet', 'Total soil wetness', '-',  &
+                  & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
+             CALL histdef(hist_id, 'SoilTemp', '3D layer average soil temperature', 'K', &
+                  & iim,jjm, hori_id, ngrnd, 1, ngrnd, solax_id, 32, avescatter(4),  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(4), dt,dw)
+             CALL histdef(hist_id, 'PotEvapOld', 'Potential evapotranspiration old method', 'kg/m^2/s', &
+                  & iim,jjm, hori_id, 1, 1, 1, -99, 32, fluxop_scinsec(4), dt,dw)
+             CALL histdef(hist_id, 'ECanop', 'Interception evaporation', 'kg/m^2/s', &
+                  & iim,jjm, hori_id, 1, 1, 1, -99, 32, fluxop_scinsec(4), dt,dw)
+             CALL histdef(hist_id, 'TVeg', 'Transpiration', 'kg/m^2/s', &
+                  & iim,jjm, hori_id, 1, 1, 1, -99, 32, fluxop_scinsec(4), 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(4), dt,dw)
+             CALL histdef(hist_id, 'EWater', 'Open water evaporation', 'kg/m^2/s', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(4), dt,dw)
+             CALL histdef(hist_id, 'RootMoist','Root zone soil water', 'kg/m^2',  &
+                  & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
+             CALL histdef(hist_id, 'SubSnow','Snow sublimation','kg/m^2/s', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(4), dt,dw)
+             CALL histdef(hist_id, 'ACond', 'Aerodynamic conductance', 'm/s',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             IF ( control_flags%do_floodplains ) THEN
+                CALL histdef(hist_id, 'Qflood', 'Floodplain Evaporation', 'kg/m^2/s', &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(4), dt,dw)
+             ENDIF
+             !-
+             !- Surface turbulence
+             !-
+             CALL histdef(hist_id, 'Z0', 'Roughness height', 'm',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             CALL histdef(hist_id, 'EffectHeight', 'Effective displacement height (h-d)', 'm',  &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             !-
+             !-
+             !-  Cold Season Processes
+             !-
+             CALL histdef(hist_id, 'SAlbedo', 'Snow albedo', '1', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             CALL histdef(hist_id, 'SnowDepth', '3D snow depth', 'm', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             !-
+             !- Hydrologic variables
+             !-
+             CALL histdef(hist_id, 'SwampMap', 'Map of swamp areas', 'm^2', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, once(4), dt,dw)
+             CALL histdef(hist_id, 'Dis', 'Simulated River Discharge', 'm^3/s', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(4), dt,dw)
+             IF ( control_flags%do_irrigation ) THEN
+                CALL histdef(hist_id, 'IrrigationMap', 'Map of irrigated areas', 'm^2', &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, once(4), dt,dw)
+             ENDIF
+             IF ( control_flags%do_floodplains ) THEN
+                CALL histdef(hist_id, 'FloodplainsMap', 'Map of flooded areas', 'm^2', &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, once(4), dt,dw)
+                CALL histdef(hist_id, 'FloodFrac', 'Floodplain Fraction', '-', &
+                     & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             ENDIF
+             CALL histdef(hist_id, 'humrel', 'Soil moisture stress', '-',  &
+                  & 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(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(4), dt,dw)
+             ENDIF
+             !
+          ENDIF
+          !-
+          !- Forcing and grid information
+          !-
+          CALL histdef(hist_id, 'LandPoints', 'Land Points', '1', &
+               & iim,jjm, hori_id, 1,1,1, -99, 32, once(4), dt,dw)  
+          CALL histdef(hist_id, 'Areas', 'Mesh areas', 'm2', &
+               & iim,jjm, hori_id, 1,1,1, -99, 32, once(4), dt, dw)
+          CALL histdef(hist_id, 'Contfrac', 'Continental fraction', '1', &
+               & iim,jjm, hori_id, 1,1,1, -99, 32, once(4), dt, dw)
+          !-
+          ! Write the names of the pfts in the history files
+          global_attribute="PFT_name"
+          DO i=1,nvm
+             WRITE(global_attribute(9:10),"(I2.2)") i
+             CALL histglobal_attr(hist_id, global_attribute, PFT_name(i))
+          ENDDO
+          !-
+          CALL histend(hist_id)
+       ENDIF ! IF (is_omp_root)
+
+    END IF !IF ( dw == 0 )
+    
+    
+    
+    
+    
+    
+    !
+    !
+    ! Second SECHIBA hist file
+    !
+    !-
+    !Config Key   = SECHIBA_HISTFILE2
+    !Config Desc  = Flag to switch on histfile 2 for SECHIBA (hi-frequency ?)
+    !Config If    = OK_SECHIBA
+    !Config Def   = n
+    !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 Units = [FLAG]
+    !-
+    ok_histfile2=.FALSE.
+    CALL getin_p('SECHIBA_HISTFILE2', ok_histfile2)
+    WRITE(numout,*) 'SECHIBA_HISTFILE2 ', ok_histfile2
+    !
+    !-
+    !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 !
+    !Config Units = [seconds]
+    !-
+    dw2 = 1800.0
+    CALL getin_p('WRITE_STEP2', dw2)
+    
+    ! Deactivate sechiba_histfile2 if the frequency is set to zero
+    IF ( dw2 == 0 ) THEN
+       ok_histfile2=.FALSE.
+       WRITE(numout,*) 'WRITE_STEP2 was set to zero and therfore SECHIBA_HISTFILE2 is deactivated.'
+    ELSE IF ( hist_id < 0 ) THEN
+       ! Deactivate all history files if sechiba_history file is deactivated
+       ok_histfile2=.FALSE.
+       WRITE(numout,*) 'SECHIBA_HISTFILE2 will not be created because sechiba_history file is deactivated.'
+    END IF
+
+    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 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.
+       !Config Units = [FILE]
+       !-
+       histname2='sechiba_out_2.nc'
+       CALL getin_p('SECHIBA_OUTPUT_FILE2', histname2)
+       WRITE(numout,*) 'SECHIBA_OUTPUT_FILE2 ', histname2
+       !-
+       !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.
+       !Config Units = [-] 
+       !-
+       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
+          CALL ipslerr_p (3,'intersurf',&
+               '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(scatter(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(scatter(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(scatter(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(scatter(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 (is_omp_root) THEN
+          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, 'laiax', 'Nb LAI', '1', &
+                  &    nlai+1,   lai, laiax_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
+
+
+             !+++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! This is where we need to add all of our variables for
+             ! high frequency sechiba that we want to print out.  
+             ! For production,
+             ! we will use histlevel = 1.  For optimization, we will use
+             ! histlevel = 2.
+             ! How much do we really need at high frequency?
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+             ! Production (histlevel = 1)
+
+             ! Added by MJM
+             CALL histdef(hist2_id, 'alb_vis', 'Albedo visible', '1', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(1), dt,dw2)
+             CALL histdef(hist2_id, 'alb_nir', 'Albedo near infrared', '1', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(1), dt,dw2)
+             CALL histdef(hist2_id, 'snowfrac', 'Snow cover fraction', '',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), 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', 'm3/m3', &
+                        & iim,jjm, hori_id2, nslm, 1, nslm, solayax_id2, 32, avescatter2(1), 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(1), dt, dw2)
+
+                   ! var_name= "kfact_root_1" ... "kfact_root_3"
+                   WRITE (var_name,"('kfactroot_',i1)") jst
+                   CALL histdef(hist2_id, var_name, 'Root fraction profile for soil type', '%', &
+                        & iim,jjm, hori_id2, nslm, 1, nslm, solayax_id2, 32, avescatter2(1), dt,dw2)
+                ENDDO
+             ENDIF
+
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by SBL
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by JR
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by JO
+             !- Vegetation
+             !-
+             CALL histdef(hist2_id, 'vegetfrac', 'Fraction of vegetation', '1', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(1), dt,dw2)
+             CALL histdef(hist2_id, 'maxvegetfrac', 'Maximum fraction of vegetation', '1', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(1), dt,dw2)
+            ! CALL histdef(hist2_id, 'nobiofrac', 'Fraction of other surface types', '1', &
+            !      & iim,jjm, hori_id2, nnobio, 1, nnobio, nobioax_id2, 32, avescatter2(1), dt,dw2)
+            ! CALL histdef(hist2_id, 'treeFrac', "Tree Cover Fraction", "%", &
+            !      & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt,dw2)
+            ! CALL histdef(hist2_id, 'grassFrac', "Natural Grass Fraction", "%", &
+            !      & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt,dw2)
+            ! CALL histdef(hist2_id, 'cropFrac', "Crop Fraction", "%", &
+            !      & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt,dw2)
+            ! CALL histdef(hist2_id, 'baresoilFrac', "Bare Soil Fraction", "%", &
+            !      & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt,dw2)
+            ! CALL histdef(hist2_id, 'tot_bare_soil', "Total Bare Soil Fraction", "%", &
+            !      & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt,dw2)
+            ! CALL histdef(hist2_id, 'residualFrac', &
+            !      & "Fraction of Grid Cell that is Land but Neither Vegetation-Covered nor Bare Soil", "%", &
+            !      & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt,dw2)
+
+             !-  General energy balance
+             !-
+             CALL histdef(hist2_id, 'tair', 'Near surface air temperature at forcing level', 'K',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(1), dt,dw2)
+             CALL histdef(hist2_id, 'qair', 'Near surface specific humidity at forcing level', 'g/g',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(1), dt,dw2)
+             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)
+
+
+             ! Notice that it only makes sense reall to write sinang
+             ! to the HF file.  Otherwise it gets averaged over the full day, which
+             ! includes the night values that are zero.  The same is true for
+             ! the alb_pft values.  We treat the albedo values of the pixels
+             ! in a special way in intersurf to compensate for this.
+             CALL histdef(hist2_id, 'sinang', 'Zenith Angle', 'Degrees', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(1), dt, dw2)
+             CALL histdef(hist2_id, 'alb_vis_pft', 'Albedo visible per PFT', '', &
+                  & iim,jjm, hori_id2, nvm,1,nvm, vegax_id, 32, ave2(1), dt,dw2)
+             CALL histdef(hist2_id, 'alb_nir_pft', 'Albedo near infrared per PFT', '', &
+                  & iim,jjm, hori_id2, nvm,1,nvm, vegax_id, 32, ave2(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, 'swe', 'Snow Water Equivalent', 'kg/m^2', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt,dw2)    
+
+             !- Surface state
+             !-
+             
+
+             !-  Evaporation components
+             !-
+             CALL histdef(hist2_id, 'evap', 'Total Evapotranspiration', 'mm/d', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop(1), dt,dw2)
+             
+
+             !- Surface turbulence
+             !-
+             CALL histdef(hist2_id, 'z0', 'Roughness height', 'm',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt,dw2)
+            ! CALL histdef(hist2_id, 'effectheight', 'Effective displacement height (h-d)', 'm',  &
+            !      & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt,dw2)
+
+             !-  Cold Season Processes
+             !-
+             
+             CALL histdef(hist2_id, 'snowdepth', '3D snow depth', 'm', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt,dw2)
+             
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by KN
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+             ! Optimization (histlevel = 2)
+
+             ! Added by MJM
+             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)
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by SBL
+
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by JR   
+             CALL histdef(hist2_id, 'vbeta1', 'Beta for sublimation', '1',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(2), dt, dw2)
+             CALL histdef(hist2_id,'vbeta2','Beta for Interception loss','mm/d', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(2), dt, dw2)
+             CALL histdef(hist2_id, 'vbeta3', 'Beta for Transpiration', 'mm/d', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(2), dt, dw2)
+             CALL histdef(hist2_id, 'vbeta3pot', 'Beta for potential Transpiration', 'mm/d', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(2), dt, dw2)
+             CALL histdef(hist2_id, 'vbeta4', 'Beta for bare soil', '1',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(2), dt, dw2)
+             CALL histdef(hist2_id, 'vbeta5', 'Beta for floodplains', '1',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(2), dt, dw2)
+
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by JO
+             !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+             ! Added by YC
+             ! Energy componments for the Energy Budget
+             CALL histdef(hist2_id, 'fluxnet', 'Net Radiation Flux', 'W/m^2', &
+                  & iim, jjm, hori_id2, 1, 1, 1, -99, 32, ave2(2), dt, dw2)
+             CALL histdef(hist2_id, 'fluxsoil', 'Soil/Ground Heat Flux', 'W/m^2', &
+                  & iim, jjm, hori_id2, 1, 1, 1, -99, 32, ave2(2), dt, dw2)
+             
+            
+             !- SECHIBA_HISTLEVEL2 = 3
+             !-
+
+
+             CALL histdef(hist2_id, 'ptn', 'Deep ground temperature', 'K', &
+                  & iim,jjm, hori_id2, ngrnd, 1, ngrnd, solax_id2, 32, avescatter2(4),  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(4), dt,dw2)
+
+                CALL histdef(hist2_id, 'mrro', "Total Runoff", "kg m-2 s-1", &
+                     & iim,jjm, hori_id2, 1, 1, 1, -99, 32, fluxop_scinsec2(4), dt,dw2)
+!             ENDIF
+             !-
+             !- SECHIBA_HISTLEVEL2 = 4
+             !-
+             CALL histdef(hist2_id, 'cdrag', 'Drag coefficient for LE and SH', '?',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), 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(4), dt,dw2)
+             CALL histdef(hist2_id, 'soilalb_nir', 'Soil Albedo near infrared', '1', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt,dw2)
+             CALL histdef(hist2_id, 'vegalb_vis', 'Vegetation Albedo visible', '1', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt,dw2)
+             CALL histdef(hist2_id, 'vegalb_nir', 'Vegetation Albedo near infrared', '1', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt,dw2)
+             ! Fin ajouts Nathalie - Septembre 2008
+             CALL histdef(hist2_id, 'coastalflow', 'Diffuse coastal flow', 'm^3/s', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(4), 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(4), dt, dw2) 
+             CALL histdef(hist2_id, 'tsol_rad', 'Radiative surface temperature', 'C', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avecels2(4), dt, dw2)
+             IF ( control_flags%do_floodplains ) THEN
+                CALL histdef(hist2_id, 'floodout', 'Flow out of floodplains', 'mm/d', &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(4), dt,dw2)
+                CALL histdef(hist2_id, 'vevapflo', 'Floodplains evaporation', 'mm/d', &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(4), dt, dw2)
+                CALL histdef(hist2_id, 'flood_frac', 'Flooded fraction', '1', &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt,dw2)
+                CALL histdef(hist2_id, 'reinfiltration', 'Reinfiltration from floodplains', 'mm/d', &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(4), dt,dw2)
+             ENDIF
+             CALL histdef(hist2_id, 'vevapnu', 'Bare soil evaporation', 'mm/d', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(4), dt, dw2)
+             CALL histdef(hist2_id, 'temp_sol', 'New Surface Temperature', 'C', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avecels2(4), dt, dw2)
+             CALL histdef(hist2_id, 'qsurf', 'Near surface specific humidity', 'g/g',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(4), dt, dw2)
+             CALL histdef(hist2_id, 'emis', 'Surface emissivity', '1', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(4), dt, dw2)
+             !-
+             !
+             !-
+!             CALL histdef(hist2_id, 'rain', 'Rainfall', 'mm/d',  &
+!                  & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(4), dt, dw2)
+!             CALL histdef(hist2_id, 'netrad', 'Net radiation', 'W/m^2',  &
+!                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt, dw2)
+             CALL histdef(hist2_id, 'lai', 'Leaf Area Index', '1', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(4), dt, dw2)
+!!$             CALL histdef(hist2_id, 'sinang', 'Zenith Angle', 'Degrees', &
+!!$                  & iim,jjm, hori_id2, 1,1,1, -99, 32, tmincels(4), 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(4), 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(4), dt, dw2)  
+             ENDIF
+             IF (check_waterbal) THEN
+                CALL histdef(hist2_id, 'TotWater', 'Total amount of water at end of time step', 'mm/d', &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(4), dt, dw2)
+                CALL histdef(hist2_id, 'TotWaterFlux', 'Total water flux', 'mm/d', &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(4), dt, dw2)
+             ENDIF
+             CALL histdef(hist2_id, 'swi', 'Soil wetness index','1',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt,dw2)
+
+
+             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
+             !
+             ! 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, '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, 'transpir_supply', 'Transpiration supply','mm/d', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop2(4), dt, dw2)
+             CALL histdef(hist2_id, 'transpot', 'Potential transpiration', 'mm/d', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop2(4), dt,dw2)
+             CALL histdef(hist2_id, 'phi_soilroot', 'Sum of the soil water potential &
+                  & in each layer weighted by the relative share of the roots in the layer', 'MPa',&
+                  & iim,jjm,hori_id2, nvm, 1, nvm,vegax_id2, 32, ave(4), dt,dw)
+             CALL histdef(hist2_id, 'phi_soilroot2', 'Sum of the soil water potential &
+                  & in each layer weighted by the relative share of the roots in the layer', 'MPa',&
+                  & iim,jjm,hori_id2, nvm, 1, nvm,vegax_id2, 32, ave(4), dt,dw)
+             CALL histdef(hist2_id, 'transpir_supply_tzj', 'Water supply for transpiration','mm/dt', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id, 32, fluxop(4),dt,dw)
+             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', 'mm/day', &
+                  & 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)
+
+             !-
+             !- SECHIBA_HISTLEVEL2 = 6
+             !-
+             IF ( .NOT. control_flags%hydrol_cwrr ) THEN
+                CALL histdef(hist2_id, 'dss', 'Up-reservoir Height', 'm',  &
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id, 32, avescatter2(6), dt,dw2)
+                CALL histdef(hist2_id, 'gqsb', 'Upper Soil Moisture', 'Kg/m^2',  &
+                     & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(6), dt, dw2)
+                CALL histdef(hist2_id, 'bqsb', 'Lower Soil Moisture', 'Kg/m^2',  &
+                     & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(6), dt, dw2)
+             ELSE
+                CALL histdef(hist2_id, 'humtot', 'Total Soil Moisture', 'Kg/m^2', &
+                     & 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/m^2', &
+                     & iim,jjm, hori_id2, nstm, 1, nstm, soltax_id2, 32, avescatter2(6), dt, dw2)
+             ENDIF
+
+ CALL histdef(hist2_id, 'twbr', 'Total water balance residual', 'Kg/m^2', &
+                     & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
+
+             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(6), 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(6), 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(6), 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(6), 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(6), 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, '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)
+             !-
+             !- 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, 'floodr', 'Floodplains reservoir', 'kg/m^2', &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(8), dt,dw2)
+                CALL histdef(hist2_id, 'floodh', 'Floodplains height', 'mm', &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(8), dt,dw2)
+                CALL histdef(hist2_id, 'pondr', 'Ponds 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)
+                IF ( control_flags%do_irrigation ) THEN
+                   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
+                CALL histdef(hist2_id, 'floodmap', 'Map of floodplains', 'm^2', &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(8), dt,dw2)
+                CALL histdef(hist2_id, 'swampmap', 'Map of swamps', '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)
+             IF ( control_flags%ok_co2 ) THEN
+                CALL histdef(hist2_id, 'gsmean', 'mean stomatal conductance', 'umol/m2/s', &
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(9), dt, dw2)
+             ENDIF
+             IF (  control_flags%hydrol_cwrr ) THEN
+                CALL histdef(hist2_id, 'reinf_slope', 'Slope index for each grid box', '1', &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(9),  dt,dw2)
+                CALL histdef(hist2_id, 'soilindex', 'Soil index', '1', &
+                     & iim,jjm, hori_id2, 1, 1, 1, -99, 32, once2(9),  dt,dw2)
+             ENDIF
+             CALL histdef(hist2_id, 'humrel', 'Soil moisture stress', '-',  &
+                  & iim,jjm, hori_id2, nvm,1,nvm, vegax_id2, 32, avescatter2(9), dt, dw2)
+             !-
+             !- SECHIBA_HISTLEVEL2 = 10
+             !-
+             IF ( control_flags%ok_co2 ) THEN
+                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)
+             ENDIF
+             CALL histdef(hist2_id, 'rveget', 'Canopy resistance', 's/m', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt, dw2)
+             IF ( .NOT. control_flags%hydrol_cwrr ) THEN
+                CALL histdef(hist2_id, 'rsol', 'Soil resistance', 's/m',  &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(10), dt, dw2)
+             ENDIF
+             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)
+             ! 
+             IF ( control_flags%ok_inca ) THEN
+                CALL histdef(hist2_id, 'PAR', 'PAR', 'umol phot/m^2/s',  &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(10), dt,dw2)
+                IF ( control_flags%ok_radcanopy ) THEN
+                   CALL histdef(hist2_id, 'PARsun', 'Sunlit Leaf PAR', 'umol phot/m^2/s', &
+                        & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                   CALL histdef(hist2_id, 'PARsh', 'Shaded Leaf Area PAR', 'umol phot/m^2/s', &
+                        & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                   CALL histdef(hist2_id, 'laisun', 'Sunlit Leaf Area Index', '1', &
+                        & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                   CALL histdef(hist2_id, 'laish', 'Shaded Leaf Area Index', '1', &
+                        & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                   CALL histdef(hist2_id, 'Fdf', 'Fdf', '1',  &
+                        & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(10), dt,dw2)
+                   IF ( control_flags%ok_multilayer ) then 
+                      CALL histdef(hist2_id, 'PARsuntab', 'Sunlit Leaf PAR', 'umol phot/m^2/s', &
+                           & iim,jjm, hori_id2, nlai+1, 1, nlai+1, laiax_id2, 32, avescatter2(10), dt,dw2)
+                      CALL histdef(hist2_id, 'PARshtab', 'Shaded Leaf Area PAR', 'umol phot/m^2/s', &
+                           & iim,jjm, hori_id2, nlai+1, 1, nlai+1, laiax_id2, 32, avescatter2(10), dt,dw2)
+                   ENDIF
+                   CALL histdef(hist2_id, 'PARdf', 'PARdf', '1',  &
+                        & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(10), dt,dw2)
+                   CALL histdef(hist2_id, 'PARdr', 'PARdr', '1',  &
+                        & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(10), dt,dw2)
+                   CALL histdef(hist2_id, 'Trans', 'Trans', '1',  &
+                        & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(10), dt,dw2)
+                   CALL histdef(hist2_id, 'Day', 'Day', '1',  &
+                        & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(10), dt,dw2)
+                   CALL histdef(hist2_id, 'Year_length', 'Year_length', '1',  &
+                        & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(10), dt,dw2)
+                END IF
+
+                CALL histdef(hist2_id, 'flx_fertil_no', 'flx_fertil_no', 'ngN/m^2/s', &
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                CALL histdef(hist2_id, 'CRF', 'CRF', '1', &
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                CALL histdef(hist2_id, 'flx_co2_bbg_year', 'flx_co2_bbg_year', 'kgC/m^2/yr ', &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(10), dt,dw2)  
+                CALL histdef(hist2_id, 'N_qt_WRICE_year', 'N_qt_WRICE_year', 'kgN/yr ', &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(10), dt,dw2)  
+                CALL histdef(hist2_id, 'N_qt_OTHER_year', 'N_qt_OTHER_year', 'kgN/yr ', &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(10), dt,dw2)  
+                CALL histdef(hist2_id, 'ptnlev1', 'ptnlev1', 'K',  &
+                     & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(10), dt,dw2)
+                CALL histdef(hist2_id, 'flx_iso', 'flx_iso', 'kgC/m^2/s', &
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                CALL histdef(hist2_id, 'flx_mono', 'flx_mono', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                CALL histdef(hist2_id, 'flx_ORVOC', 'flx_ORVOC', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                CALL histdef(hist2_id, 'flx_MBO', 'flx_MBO', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                CALL histdef(hist2_id, 'flx_methanol', 'flx_methanol', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                CALL histdef(hist2_id, 'flx_acetone', 'flx_acetone', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                CALL histdef(hist2_id, 'flx_acetal', 'flx_acetal', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                CALL histdef(hist2_id, 'flx_formal', 'flx_formal', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                CALL histdef(hist2_id, 'flx_acetic', 'flx_acetic', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                CALL histdef(hist2_id, 'flx_formic', 'flx_formic', 'kgC/m^2/s',&
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                CALL histdef(hist2_id, 'flx_no_soil', 'flx_no_soil', 'ngN/m^2/s',&
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+                CALL histdef(hist2_id, 'flx_no', 'flx_no', 'ngN/m^2/s',&
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt,dw2)
+             ENDIF
+          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, diaglev(1:nslm), solayax_id2)
+             ENDIF
+             !-
+             !-  Vegetation
+             !-
+             CALL histdef(hist2_id, 'vegetfrac', 'Fraction of vegetation', '1', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(4), dt, dw2)
+             CALL histdef(hist2_id, 'maxvegetfrac', 'Maximum fraction of vegetation', '1', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(4), dt, dw2)
+             CALL histdef(hist2_id, 'nobiofrac', 'Fraction of other surface types', '1', &
+                  & iim,jjm, hori_id2, nnobio, 1, nnobio, nobioax_id2, 32, avescatter2(4), 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(4), dt, dw2)
+             CALL histdef(hist2_id, 'LWnet', 'Net longwave radiation', 'W/m^2',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt, dw2)
+             CALL histdef(hist2_id, 'Qh', 'Sensible heat flux', 'W/m^2',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(4), dt, dw2)
+             CALL histdef(hist2_id, 'Qle', 'Latent heat flux', 'W/m^2',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(4), dt, dw2)
+             CALL histdef(hist2_id, 'Qg', 'Ground heat flux', 'W/m^2',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt, dw2)
+             CALL histdef(hist2_id, 'Qf', 'Energy of fusion', 'W/m^2',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(5), dt, dw2)
+             CALL histdef(hist2_id, 'Qv', 'Energy of sublimation', 'W/m^2',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(5), 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(7), 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(7), 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(4), dt, dw2)
+             CALL histdef(hist2_id, 'Rainf', 'Rainfall rate', 'kg/m^2/s',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(4), dt, dw2)
+             CALL histdef(hist2_id, 'Evap', 'Total Evapotranspiration', 'kg/m^2/s', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(4), dt, dw2)
+             CALL histdef(hist2_id, 'Qs', 'Surface runoff', 'kg/m^2/s', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(4), 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(4), dt, dw2)
+             CALL histdef(hist2_id, 'Qsm', 'Snowmelt', 'kg/m^2/s', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(4), dt, dw2)
+             CALL histdef(hist2_id, 'DelSoilMoist', 'Change in soil moisture', 'kg/m^2',  &
+                  & iim,jjm, hori_id2, 1, 1, 1, -99, 32, sumscatter2(7), dt, dw2)
+             CALL histdef(hist2_id, 'DelSurfStor', 'Change in Surface Water Storage','kg/m^2',&
+                  & iim,jjm, hori_id2, 1, 1, 1, -99, 32, sumscatter2(7), dt,dw2)
+             CALL histdef(hist2_id, 'DelIntercept', 'Change in interception storage', 'kg/m^2',  &
+                  & iim,jjm, hori_id2, 1, 1, 1, -99, 32, sumscatter2(7), dt, dw2)
+             CALL histdef(hist2_id, 'DelSWE', 'Change in interception storage Snow Water Equivalent', 'kg/m^2',  &
+                  & iim,jjm, hori_id2, 1, 1, 1, -99, 32, sumscatter2(7), dt, dw2)
+             !-
+             !- Surface state
+             !-
+             CALL histdef(hist2_id, 'AvgSurfT', 'Average surface temperature', 'K', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(4), dt, dw2)
+             CALL histdef(hist2_id, 'RadT', 'Surface radiative temperature', 'K', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(5), dt, dw2)
+             CALL histdef(hist2_id, 'SWI', 'Soil wetness index','1',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt, dw2)
+             CALL histdef(hist2_id, 'SurfStor', 'Surface Water Storage','kg/m^2',  &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt, dw2)
+             CALL histdef(hist2_id, 'SWE', 'Snow Water Equivalent', 'kg/m^2', &
+                  & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+             ! Notice that this albedo is a merge of the individual spectral bands.
+             CALL histdef(hist2_id, 'Albedo', 'Albedo', '1', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(7), 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(7), 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(7), dt, dw2)
+             ENDIF
+             CALL histdef(hist2_id, 'SoilWet', 'Total soil wetness', '-',  &
+                  & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(4), dt, dw2)
+             CALL histdef(hist2_id, 'SoilTemp', '3D layer average soil temperature', 'K', &
+                  & iim,jjm, hori_id2, ngrnd, 1, ngrnd, solax_id2, 32, avescatter2(7), 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, 1, 1, 1, -99, 32, fluxop_scinsec2(1), dt, dw2)
+             CALL histdef(hist2_id, 'TVeg', 'Transpiration', 'kg/m^2/s', &
+                  & iim,jjm, hori_id2, 1, 1, 1, -99, 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, 'EWater', 'Open water 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, 'SAlbedo', 'Snow albedo', '1', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(7), dt, dw2)
+             CALL histdef(hist2_id, 'SnowDepth', '3D snow depth', 'm', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(7), 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(4), dt, dw2)
+             CALL histdef(hist2_id, 'FloodplainsMap', 'Map of flooded areas', 'm^2', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(4), dt,dw2)
+             CALL histdef(hist2_id, 'SwampMap', 'Map of swamp areas', 'm^2', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(4), dt,dw2)
+             CALL histdef(hist2_id, 'Dis', 'Simulated River Discharge', 'm^3/s', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(4), dt,dw2)
+             CALL histdef(hist2_id, 'humrel', 'Soil moisture stress', '-',  &
+                  & 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(4), 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(4), 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(4), 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(4), 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(4), 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(4), dt, dw2)
+             ENDIF
+             !
+          ENDIF
+          !-
+          CALL histdef(hist2_id, 'LandPoints', 'Land Points', '1', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(4), dt, dw2)  
+          CALL histdef(hist2_id, 'Areas', 'Mesh areas', 'm2', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(4), dt, dw2)
+          CALL histdef(hist2_id, 'Contfrac', 'Continental fraction', '1', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(4), dt, dw2)
+          !-
+          ! Write the names of the pfts in the high frequency sechiba history files
+          global_attribute="PFT_name"
+          DO i=1,nvm
+             WRITE(global_attribute(9:10),"(I2.2)") i
+             CALL histglobal_attr(hist2_id, global_attribute, PFT_name(i))
+          ENDDO
+          !-
+          CALL histend(hist2_id)
+       ENDIF
+    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 to be written
+       !Config If    = OK_STOMATE
+       !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.
+       !Config Units = [FILE]
+       !-
+       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
+       !Config If    = OK_STOMATE
+       !Config Def   = 10.
+       !Config Help  = Time step of the STOMATE history file
+       !Config Units = [days]
+       !-
+       hist_days_stom = 10.
+       CALL getin_p('STOMATE_HIST_DT', hist_days_stom)       
+
+       IF ( hist_id < 0 ) THEN
+          ! Deactivate all history files if sechiba_history file is deactivated
+          hist_dt_stom=0
+          WRITE(numout,*) 'STOMATE history file will not be created because sechiba_history file is deactivated.'
+       ELSE IF ( hist_days_stom == moins_un ) THEN
+          hist_dt_stom = moins_un
+          WRITE(numout,*) 'output frequency for STOMATE history file (d): one month.'
+       ELSE IF ( hist_days_stom == 0 ) THEN
+          ! Deactivate this file
+          hist_dt_stom=0
+          WRITE(numout,*) 'STOMATE history file will not be created'
+       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 .AND. hist_dt_stom/=0) THEN
+          IF (dt_slow_ > hist_dt_stom) THEN
+             WRITE(numout,*) "DT_SLOW = ",dt_slow_,"  , STOMATE_HIST_DT = ",hist_dt_stom
+             CALL ipslerr_p (3,'intsurf_history', &
+                  &          'Problem with DT_SLOW > STOMATE_HIST_DT','', &
+                  &          '(must be less or equal)')
+          ENDIF
+       ENDIF
+       !-
+       !- Initialize stomate_history file
+       IF ( hist_dt_stom == 0 ) THEN
+          ! Case hist_dt_stom=0 : No creation of stomate_history.nc file
+          ! Nothing will be done.
+          hist_id_stom=-1
+       ELSE
+          ! Initialise stomate_history file
+       IF (is_omp_root) THEN
+          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_short axis
+          hist_pool_s_axis = (/ ( REAL(i,r_std), i=1,nshort ) /)
+          !- declare this axis
+          CALL histvert (hist_id_stom, 'P_S', 'Short lived pool', &
+               & '1', nshort, hist_pool_s_axis, hist_pool_s_axis_id)
+
+          !- define Pool_medium axis
+          hist_pool_m_axis = (/ ( REAL(i,r_std), i=1,nmedium ) /)
+          !- declare this axis
+          CALL histvert (hist_id_stom, 'P_M', 'Medium lived pool', &
+               & '1', nmedium, hist_pool_m_axis, hist_pool_m_axis_id)
+          
+          !- define Pool_long axis
+          hist_pool_l_axis = (/ ( REAL(i,r_std), i=1,nlong ) /)
+          !- declare this axis
+          CALL histvert (hist_id_stom, 'P_L', 'Long lived pool', &
+               & '1', nlong, hist_pool_l_axis, hist_pool_l_axis_id)
+          
+          !- define Pool_ss axis
+          hist_pool_ss_axis = (/ ( REAL(i,r_std), i=1,nshort+1 ) /)
+          !- declare this axis
+          CALL histvert (hist_id_stom, 'P_SS', 'short lived pool years + 1', &
+               & '1', nshort+1, hist_pool_ss_axis, hist_pool_ss_axis_id)
+
+          !- define Pool_mm axis
+          hist_pool_mm_axis = (/ ( REAL(i,r_std), i=1,nmedium+1 ) /)
+          !- declare this axis
+          CALL histvert (hist_id_stom, 'P_MM', 'medium lived pool years + 1', &
+               & '1', nmedium+1, hist_pool_mm_axis, hist_pool_mm_axis_id)
+          
+          !- define Pool_ll axis
+          hist_pool_ll_axis = (/ ( REAL(i,r_std), i=1,nlong+1 ) /)
+          !- declare this axis
+          CALL histvert (hist_id_stom, 'P_LL', 'long lived pool  years + 1', &
+               & '1', nlong+1, hist_pool_ll_axis, hist_pool_ll_axis_id)
+
+          ! For the number of canopy levels
+          CALL histvert(hist_id_stom, 'canlevel', 'Canopy levels', 'm', &
+               &    nlevels,  z_level, canx_id)
+
+          ! For the number of canopy levels including all those used in photosynthesis.
+          ! Notice we cannot use the real heights here, since they can change every day
+          ! as the canopy develops.
+          DO ilev=1,nlevels_tot
+             z_levels_tot(ilev)=REAL(ilev,r_std)
+          ENDDO
+          CALL histvert(hist_id_stom, 'canleveltot', 'Total canopy levels', '-', &
+               &    nlevels_tot,  z_levels_tot, canx_tot_stom_id)
+
+       ENDIF
+       !- define STOMATE history file
+       CALL stom_define_history (hist_id_stom, nvm, control_flags, iim, jjm, &
+            & dt, hist_dt_stom, hori_id, hist_PFTaxis_id, &
+            & hist_pool_s_axis_id, hist_pool_m_axis_id, & 
+            & hist_pool_l_axis_id, hist_pool_ss_axis_id, &
+            & hist_pool_mm_axis_id, hist_pool_ll_axis_id, canx_id,&
+            canx_tot_stom_id)
+       
+       !- Write the names of the pfts in the stomate history files 
+       IF (is_omp_root) THEN
+          global_attribute="PFT_name"
+          DO i=1,nvm
+             WRITE(global_attribute(9:10),"(I2.2)") i
+             CALL histglobal_attr(hist_id_stom, global_attribute, PFT_name(i))
+          ENDDO
+
+       !- end definition
+          CALL histend(hist_id_stom)
+       ENDIF
+    END IF ! IF ( hist_dt_stom == 0 )
+
+       !-
+       !-
+       !-
+       ! STOMATE IPCC OUTPUTS IS ACTIVATED
+       !-
+       !Config Key   = STOMATE_IPCC_OUTPUT_FILE
+       !Config Desc  = Name of file in which STOMATE's output is going to be written
+       !Config If    = OK_STOMATE
+       !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.
+       !Config Units = [FILE]
+       !-
+       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
+       !Config If    = OK_STOMATE
+       !Config Def   = 0.
+       !Config Help  = Time step of the STOMATE IPCC history file
+       !Config Units = [days]
+       !-
+       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
+       
+       IF ( hist_dt_stom_ipcc /= 0 .AND. hist_id < 0 ) THEN
+          ! sechiba_history file is not created therefore STOMATE IPCC history file will be deactivated
+          hist_dt_stom_ipcc=0
+          hist_days_stom_ipcc=0
+          WRITE(numout,*) 'STOMATE IPCC history file is not created.'
+       END IF
+
+       ! 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_p (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 (is_omp_root) THEN
+             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)
+             
+             !- Write the names of the pfts in the stomate history files 
+             global_attribute="PFT_name"
+             DO i=1,nvm
+                WRITE(global_attribute(9:10),"(I2.2)") i
+                CALL histglobal_attr(hist_id_stom_IPCC, global_attribute, PFT_name(i))
+             ENDDO
+
+             !- end definition
+             CALL histend(hist_id_stom_IPCC)
+          ENDIF
+      ENDIF
+   ENDIF
+
+
+    RETURN
+
+  END SUBROUTINE intsurf_history
+
+!! ================================================================================================================================
+!! SUBROUTINE   : stom_define_history
+!!
+!>\BRIEF         Tell ioipsl which variables are to be written and on which grid they are defined.
+!!
+!! DESCRIPTION  : 
+!!                
+!!                
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!! - 
+!!
+!! FLOWCHART    : 
+!_ ================================================================================================================================
+
+  SUBROUTINE stom_define_history &
+       & (hist_id_stom, nvm, control_flags, iim, jjm, dt, &
+       &  hist_dt, hist_hori_id, hist_PFTaxis_id, &
+       &  hist_pool_s_axis_id, hist_pool_m_axis_id, &
+       &  hist_pool_l_axis_id, hist_pool_ss_axis_id, &
+       &  hist_pool_mm_axis_id, hist_pool_ll_axis_id,&
+       canx_id, canx_tot_stom_id)
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                   :: hist_id_stom            !! File id
+    INTEGER(i_std), INTENT(in)                   :: nvm                     !! number of PFTs
+    TYPE(control_type), INTENT(in)               :: control_flags           !! Flags that (de)activate parts of the model
+    INTEGER(i_std), INTENT(in)                   :: iim, jjm                !! Domain size
+    REAL(r_std), INTENT(in)                      :: dt                      !! Time step of STOMATE (seconds)
+    REAL(r_std), INTENT(in)                      :: hist_dt                 !! Time step of history file (s)
+    INTEGER(i_std), INTENT(in)                   :: hist_hori_id            !! id horizontal grid
+    INTEGER(i_std), INTENT(in)                   :: hist_PFTaxis_id         !! id of PFT axis
+    INTEGER(i_std), INTENT(in)                   :: hist_pool_s_axis_id     !! id of Deforestation axis
+    INTEGER(i_std), INTENT(in)                   :: hist_pool_m_axis_id     !! id of Deforestation axis
+    INTEGER(i_std), INTENT(in)                   :: hist_pool_l_axis_id
+    INTEGER(i_std), INTENT(in)                   :: hist_pool_ss_axis_id    !! id of Deforestation axis
+    INTEGER(i_std), INTENT(in)                   :: hist_pool_mm_axis_id    !! id of Deforestation axis
+    INTEGER(i_std), INTENT(in)                   :: hist_pool_ll_axis_id
+    INTEGER(i_std), INTENT(in)                   :: canx_id
+    INTEGER(i_std), INTENT(in)                   :: canx_tot_stom_id
+
+    !! 0.4 Local variables
+
+
+    INTEGER(i_std), PARAMETER                    :: max_hist_level = 10     !! maximum history level
+    INTEGER(i_std)                               :: hist_level              !! output level (between 0 and 10)
+                                                                            !!  ( 0:nothing is written, 10:everything is written)
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: ave, once, t_max, sumscatter        !! Character strings to define operations for histdef
+    INTEGER(i_std)                               :: idia,icut,ifm
+    CHARACTER(LEN=80)                                                   :: cut_name               !! To store variables names for I/O
+    CHARACTER(LEN=80)                                                   :: fm_name               !! To store variables names for I/O
+
+    !++++ TEMP ++++
+    CHARACTER(LEN=80)                            :: var_name           !! To store variables names
+    INTEGER :: icir,ivm
+!_ ================================================================================================================================
+
+    !=====================================================================
+    !- 1 history level
+    !=====================================================================
+    !- 1.1 define history levelx
+    !=====================================================================
+    !Config Key   = STOMATE_HISTLEVEL
+    !Config Desc  = STOMATE history output level (0..10)
+    !Config If    = OK_STOMATE
+    !Config Def   = 10
+    !Config Help  = 0: nothing is written; 10: everything is written
+    !Config Units = [-]
+    !-
+    hist_level = 1
+    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
+        CALL ipslerr_p (3,'intersurf',&
+               '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          '
+
+    t_max(1:hist_level) =  't_max(scatter(X))'
+    t_max(hist_level+1:max_hist_level) =  'never' 
+
+    once(1:max_hist_level) = 'once(scatter(X))'
+    once(hist_level+1:max_hist_level) = 'never'
+    
+    sumscatter(1:hist_level) = 't_sum(scatter(X))'
+    sumscatter(hist_level+1:max_hist_level) = 'never'
+
+    !=====================================================================
+    !- 2 surface fields (2d)
+    !- 3 PFT: 3rd dimension
+    !=====================================================================
+
+
+    IF (is_omp_root) THEN
+
+       ! +++++++++++ MJM   +++++++++++++++++++
+       ! I am going to do this a different way.  Instead of commenting
+       ! out the variables, I am going to change their hist_level.  I
+       ! also changed the default hist_level to be 1, so if a variable
+       ! below is declared with a hist level greater than one (for example,
+       ! ave(2) or once(10)) it should not be written out.  The number in
+       ! paranthesis in the ave statement is the histlevel of the variable.
+
+       ! All these are hist_level = 1, which means they should always be
+       ! written out.  hist_level = 1 are the variables used in
+       ! production and in optimization.  hist_level = 2 are those
+       ! only used in optimization.
+       
+       ! MJM put the following variables here
+       !++++++++++++++++++++++++++++++++++++
+       ! 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)
+       
+       ! 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)
+       
+       ! 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)
+
+       ! 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)
+
+       ! 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(1), 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(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(1), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("HET_RESP_SOIL            "), &
+            &               TRIM("heterotr. resp. from ground soil"), &
+            &               TRIM("gC/m^2 tot/pft/day  "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("HET_RESP_LITTER            "), &
+            &               TRIM("heterotr. resp. from ground litter"), &
+            &               TRIM("gC/m^2 tot/pft/day  "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), 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(1), 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(1), 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(1), 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(1), 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(1), 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(1), 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(1), 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(1), dt, hist_dt)
+
+       ! Labile pool                         
+       CALL histdef (hist_id_stom, &
+            &               TRIM("LABILE_M           "), &
+            &               TRIM("Labile carbon pool                                "), &
+            &               TRIM("gC/m^2              "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), 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(1), 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(1), 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(1), dt, hist_dt)
+       
+       !++++++++++++++++++++++++++++++++++++
+
+       ! SBL put the following variables here
+       !++++++++++++++++++++++++++++++++++++
+       ! height                                            
+       CALL histdef (hist_id_stom, &
+            &               TRIM("HEIGHT              "), &
+            &               TRIM("quadratic mean height                             "), &
+            &               TRIM("m                   "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
+
+       ! diameter
+       CALL histdef (hist_id_stom, &
+            &               TRIM("DIAMETER            "), &
+            &               TRIM("quadratic mean diameter                           "), &
+            &               TRIM("m                   "), 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(1), dt, hist_dt)
+        
+
+       ! Basal area
+       CALL histdef (hist_id_stom, &
+               &            TRIM("BA                 "), &
+               &            TRIM("Basal area of stand                               "), &
+               &            TRIM("m^2/ha             "), iim, jjm, hist_hori_id, &
+               &            nvm,1,nvm, hist_PFTaxis_id, 32, ave(1), dt, hist_dt)
+
+       ! on-site wood volume or standing volume
+       CALL histdef (hist_id_stom, &
+               &            TRIM("WOOD_VOL           "), &
+               &            TRIM("Standing wood volume                              "), &
+               &            TRIM("m^3/m^2             "), iim, jjm, hist_hori_id, &
+               &            nvm,1,nvm, hist_PFTaxis_id, 32, ave(1), dt, hist_dt)
+
+       ! Water stress in allocation
+       CALL histdef (hist_id_stom, &
+               &            TRIM("WSTRESS_SEASON     "), &
+               &            TRIM("water stress used in allocation                   "), &
+               &            TRIM("-                  "), iim, jjm, hist_hori_id, &
+               &            nvm,1,nvm, hist_PFTaxis_id, 32, ave(1), dt, hist_dt)
+       
+       CALL histdef (hist_id_stom, &
+               &            TRIM("WSTRESS_MONTH     "), &
+               &            TRIM("water stress used in allocation                   "), &
+               &            TRIM("-                  "), iim, jjm, hist_hori_id, &
+               &            nvm,1,nvm, hist_PFTaxis_id, 32, ave(1), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+               &            TRIM("WSTRESS_WEEK     "), &
+               &            TRIM("water stress used in allocation                   "), &
+               &            TRIM("-                  "), iim, jjm, hist_hori_id, &
+               &            nvm,1,nvm, hist_PFTaxis_id, 32, ave(1), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+               &            TRIM("WSTRESS_DAY       "), &
+               &            TRIM("water stress used in allocation                   "), &
+               &            TRIM("-                  "), iim, jjm, hist_hori_id, &
+               &            nvm,1,nvm, hist_PFTaxis_id, 32, ave(1), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+               &            TRIM("K_LATOSA_ADAPT     "), &
+               &            TRIM("Allocation factor adapted for wstress             "), &
+               &            TRIM("m                  "), iim, jjm, hist_hori_id, &
+               &            nvm,1,nvm, hist_PFTaxis_id, 32, ave(1), dt, hist_dt)
+
+       ! stand age
+       CALL histdef (hist_id_stom, &
+            &               TRIM("AGE_STAND "), &
+            &               TRIM("Age of stand "), &
+            &               TRIM("years "), iim, jjm, hist_hori_id, &
+            &               nvm, 1, nvm, hist_PFTaxis_id, 32, ave(1), dt, hist_dt)
+
+       ! Harvest components
+       CALL histdef (hist_id_stom, &
+            &               TRIM("HARVEST_POOL_C       "), &
+            &               TRIM("carbon contained in harvest pool                  "), &
+            &               TRIM("g C                  "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, t_max(1), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("HARVEST_TYPE         "), &
+            &               TRIM("Management type                                   "), &
+            &               TRIM("scale defined in constantes"), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("HARVEST_CUT         "), &
+            &               TRIM("Harvest type of cutting                           "), &
+            &               TRIM("scale defined in constantes"), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("HARVEST_AREA        "), &
+            &               TRIM("Harvest area                                      "), &
+            &               TRIM("m^2                 "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
+
+       ! 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(1), 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(1), 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(1), 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(1), dt, hist_dt)
+
+       ! Woody litter above ground
+       CALL histdef (hist_id_stom, &
+            &               TRIM("LITTER_WOD_AB"), &
+            &               TRIM("Woody litter above ground"), &
+            &               TRIM("gC/m^2 (n/a)"), iim, jjm, hist_hori_id, &
+            &               nvm, 1, nvm, hist_PFTaxis_id, 32, ave(1), dt, hist_dt)
+
+       ! Woody litter below ground
+       CALL histdef (hist_id_stom, &
+            &               TRIM("LITTER_WOD_BE "), &
+            &               TRIM("Woody litter below ground "), &
+            &               TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
+            &               nvm, 1, nvm, hist_PFTaxis_id, 32, ave(1), dt, hist_dt)
+
+       ! short-lived wood product pool                         
+       CALL histdef (hist_id_stom, &
+            &               TRIM("PROD_S              "), &
+            &               TRIM("short-lived wood product pool                     "), &
+            &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+            &               nshort+1,1,nshort+1, hist_pool_ss_axis_id,32, ave(1), dt, hist_dt)
+
+       ! medium-lived wood product pool                         
+       CALL histdef (hist_id_stom, &
+            &               TRIM("PROD_M              "), &
+            &               TRIM("medium-lived wood product pool                    "), &
+            &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+            &               nmedium+1,1,nmedium+1, hist_pool_mm_axis_id,32, ave(1), dt, hist_dt)
+
+       ! long lived wood product pool                        
+       CALL histdef (hist_id_stom, &
+            &               TRIM("PROD_L             "), &
+            &               TRIM("long-lived wood product pool                      "), &
+            &               TRIM("-                  "), iim,jjm, hist_hori_id, &
+            &               nlong+1,1,nlong+1, hist_pool_ll_axis_id,32, ave(1), dt, hist_dt)
+
+       !++++++++++++++++++++++++++++++++++++
+
+       ! JR put the following variables here
+       !++++++++++++++++++++++++++++++++++++
+       !++++++++++++++++++++++++++++++++++++
+
+       ! JO put the following variables here
+       !++++++++++++++++++++++++++++++++++++
+       !++++++++++++++++++++++++++++++++++++
+
+       ! KN put the following variables here
+       !++++++++++++++++++++++++++++++++++++
+
+       !++++++++++++++++++++++++++++++++++++
+
+
+       ! These next ones are hist_level = 2, which means they will be printed
+       ! out only for the optimization
+
+       ! MJM put the following variables here
+       !++++++++++++++++++++++++++++++++++++
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("FOREST_MANAGED "), &
+            &               TRIM("Forest management flag "), &
+            &               TRIM("- "), iim, jjm, hist_hori_id, &
+            &               nvm, 1, nvm, hist_PFTaxis_id, 32, ave(2), dt, hist_dt)
+       
+       CALL histdef (hist_id_stom, &
+            &               TRIM("LITTER_RAKE_FRAC "), &
+            &               TRIM("How much of the litter we've removed from forests "), &
+            &               TRIM("- "), iim, jjm, hist_hori_id, &
+            &               nvm, 1, nvm, hist_PFTaxis_id, 32, ave(2), dt, hist_dt)
+
+       !++++++++++++++++++++++++++++++++++++
+
+       ! SBL put the following variables here
+       !++++++++++++++++++++++++++++++++++++
+
+       DO icir=1,ncirc
+
+          ! trees per diameter class
+          WRITE (var_name,"('CCN_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("Number of trees in a circ class                             "), &
+               TRIM("-                   "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+
+          ! Basal area per diameter class
+          WRITE (var_name,"('CCBA_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("Basal area of a trees in a circ class                       "), &
+               TRIM("-                   "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+
+          ! Change in basal area per diameter class
+          WRITE (var_name,"('CCDELTABA_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("Change in basal area of a trees in a circ class             "), &
+               TRIM("-                   "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+          
+       ENDDO
+       
+       !++++++++++++++++++++++++++++++++++++
+        
+       ! NN put the following variables here
+       !++++++++++++++++++++++++++++++++++++
+
+       
+       DO icir=1,ncirc
+          WRITE (var_name,"('CCD_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("Mean diameter of trees in a circ class"), &
+               TRIM("m                   "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, ave(2), dt, hist_dt)  
+       ENDDO
+       
+        DO icir=1,ncirc     
+          WRITE (var_name,"('CCH_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("Mean height of trees in a circ class"), &
+               TRIM("m                   "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, ave(2), dt, hist_dt)  
+       ENDDO
+       
+       DO icir=1,ncirc   
+          WRITE (var_name,"('CCC_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("Mean crown area of trees in a circ class"), &
+               TRIM("m                   "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, ave(2), dt, hist_dt)  
+       ENDDO
+       
+       DO icir=1,ncirc    
+          WRITE (var_name,"('CCB_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("Mean total biomass in class                             "),&
+               TRIM("gC/m2                   "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, ave(2), dt, hist_dt)  
+       ENDDO
+       
+       DO icir=1,ncirc
+          WRITE (var_name,"('CCK_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("Number of killed trees"), &
+               TRIM("stems                   "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, sumscatter(2), dt, hist_dt)  
+       ENDDO
+
+
+       DO icir=1,ncirc
+          WRITE (var_name,"('counter_psi_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("Counter of the plc exceed threshold"), &
+               TRIM("counter days                  "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, sumscatter(2), dt, hist_dt)
+       ENDDO
+
+       DO icir=1,ncirc
+          WRITE (var_name,"('counter_2_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("Counter of the plc"), &
+               TRIM("counter days                  "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, sumscatter(2), dt, hist_dt)
+       ENDDO
+
+       DO icir=1,ncirc
+          WRITE (var_name,"('counter_0_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("Counter of the plc exceed threshold"), &
+               TRIM("counter days                  "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, sumscatter(2), dt, hist_dt)
+       ENDDO
+
+        DO icir=1,ncirc
+          WRITE (var_name,"('circ_class_litter_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("hydrol failure litter in each circ"), &
+               TRIM("gC/m2                  "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, sumscatter(2), dt, hist_dt)
+       ENDDO
+
+        DO icir=1,ncirc
+          WRITE (var_name,"('circ_class_st_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("litter mortality in each circ"), &
+               TRIM("gC/m2                  "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, sumscatter(2), dt, hist_dt)
+       ENDDO
+
+        DO icir=1,ncirc
+          WRITE (var_name,"('CC_leaflitter_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("leaf litter mortality in each circ"), &
+               TRIM("gC/m2                  "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, sumscatter(2), dt, hist_dt)
+       ENDDO
+
+       DO icir=1,ncirc
+          WRITE (var_name,"('CC_saplitter_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("sap litter mortality in each circ"), &
+               TRIM("gC/m2                  "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, sumscatter(2), dt, hist_dt)
+       ENDDO
+        
+        DO icir=1,ncirc
+          WRITE (var_name,"('CC_heartlitter_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("heart litter mortality in each circ"), &
+               TRIM("gC/m2                  "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, sumscatter(2), dt, hist_dt)
+       ENDDO
+
+
+        DO icir=1,ncirc
+          WRITE (var_name,"('circ_class_thin_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("st mortality in each circ"), &
+               TRIM("1/m2                  "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, sumscatter(2), dt, hist_dt)
+       ENDDO
+
+        DO icir=1,ncirc
+          WRITE (var_name,"('circ_class_mor_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("hydrol failure  mortality in each circ"), &
+               TRIM("1/m2                  "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, sumscatter(2), dt, hist_dt)
+       ENDDO
+
+
+       
+       DO icir=1,ncirc
+          WRITE (var_name,"('circ_class_abg_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("aboveground biomass  in each circ"), &
+               TRIM("gC/m2                  "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, sumscatter(2), dt, hist_dt)
+       ENDDO
+
+        DO icir=1,ncirc
+          WRITE (var_name,"('circ_class_gains_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("aboveground gains  in each circ"), &
+               TRIM("gC/m2                  "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, sumscatter(2), dt, hist_dt)
+       ENDDO
+
+         DO icir=1,ncirc
+          WRITE (var_name,"('CC_leafgains_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("leaf gains  in each circ"), &
+               TRIM("gC/m2                  "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, sumscatter(2), dt, hist_dt)
+       ENDDO
+
+         DO icir=1,ncirc
+          WRITE (var_name,"('CC_sapgains_',i3.3)") icir
+          CALL histdef (hist_id_stom, &
+               var_name, &
+               TRIM("sap gains  in each circ"), &
+               TRIM("gC/m2                  "), iim,jjm, hist_hori_id, &
+               nvm,1,nvm, hist_PFTaxis_id, 32, sumscatter(2), dt, hist_dt)
+       ENDDO
+
+
+       ! Relative Density Index (forest managemen)
+       CALL histdef (hist_id_stom, &
+            &               TRIM("RDI                 "), &
+            &               TRIM("Relative density index                            "), &
+            &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
+
+
+       !++++++++++++++++++++++++++++++++++++
+
+       ! JR put the following variables here
+       !++++++++++++++++++++++++++++++++++++
+       !++++++++++++++++++++++++++++++++++++
+
+       ! JO put the following variables here
+       !++++++++++++++++++++++++++++++++++++
+       !++++++++++++++++++++++++++++++++++++
+
+       ! KN put the following variables here
+       !++++++++++++++++++++++++++++++++++++
+
+       ! Mass balance error in LCC
+       CALL histdef (hist_id_stom, &
+            &               TRIM("MB_ERR_LCC         "), &
+            &               TRIM("Error in mass balance due to land cover change    "), &
+            &               TRIM("gC m-2 year-1"), iim,jjm, hist_hori_id, &
+            &               1,1,1, -99,32, ave(1), dt, hist_dt)
+
+       !++++++++++++++++++++++++++++++++++++
+
+       ! Debugging only - histlevel 3
+
+       ! rdi_target_upper and rdi_target_lower
+       CALL histdef (hist_id_stom, &
+            &               TRIM("RDI_TARGET_UPPER    "), &
+            &               TRIM("Upper limit of RDI                         "), &
+            &               TRIM("-                   "), iim,jjm, hist_hori_id,&
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("RDI_TARGET_LOWER    "), &
+            &               TRIM("Lower limit of RDI                         "), &
+            &               TRIM("-                   "), iim,jjm,hist_hori_id,&
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+
+       ! Long term 2 m temperature                           
+       CALL histdef (hist_id_stom, &
+            &               TRIM("TLONG_REF         "), &
+            &               TRIM("Corrected longterm 2 m temperature                "), &
+            &               TRIM("K                   "), iim,jjm, hist_hori_id, &
+            &               1,1,1, -99,32, ave(3), 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(3), 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(3), 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(3), 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(3), 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(3), 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(3), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("GDD_M5_DORMANCE     "), &
+            &               TRIM("Growing degree days, since dormance               "), &
+            &               TRIM("degK                "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), 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(3), 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(3), 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(3), dt, hist_dt)
+       
+       ! Radiation use efficieny but defined as GPP/radiation
+       CALL histdef (hist_id_stom, &
+            &               TRIM("RUE_LONGTERM        "), &
+            &               TRIM("Longterm radiation use efficieny                  "), &
+            &               TRIM(" gC m-2 day-1       "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+
+       ! Sapwood to leaf allocation factor
+       CALL histdef (hist_id_stom, &
+            &               TRIM("KF                 "), &
+            &               TRIM("Sapwood to leaf allocation factor                 "), &
+            &               TRIM("-                  "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("SIGMA "), &
+            &               TRIM("Circumference threshold for individual growth "), &
+            &               TRIM("m "), iim, jjm, hist_hori_id, & 
+            &               nvm, 1, nvm, hist_PFTaxis_id, 32, ave(3), dt, hist_dt)
+       
+       CALL histdef (hist_id_stom, &
+            &               TRIM("GAMMA "), &
+            &               TRIM("Slope for individual growth "), &
+            &               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(3), dt, hist_dt)
+
+       ! leaf age                                          
+       CALL histdef (hist_id_stom, &
+            &               TRIM("LEAFAGE            "), &
+            &               TRIM("leaf age                                          "), &
+            &               TRIM("days                "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+
+       ! Ligning composition of litter
+       CALL histdef (hist_id_stom, &
+            &               TRIM("LIGNIN_STRUC_AB     "), &
+            &               TRIM("Lignin fraction structural litter aboveground    "), &
+            &               TRIM("- "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+       CALL histdef (hist_id_stom, &
+            &               TRIM("LIGNIN_STRUC_BE     "), &
+            &               TRIM("Lignin fraction structural litter belowground    "), &
+            &               TRIM("- "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+       CALL histdef (hist_id_stom, &
+            &               TRIM("LIGNIN_WOOD_AB      "), &
+            &               TRIM("Lignin fraction woodtural litter aboveground    "), &
+            &               TRIM("- "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+       CALL histdef (hist_id_stom, &
+            &               TRIM("LIGNIN_WOOD_BE      "), &
+            &               TRIM("Lignin fraction woodtural litter belowground    "), &
+            &               TRIM("- "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+
+       ! Leaf Area Index per level 
+       ! I want to write this out as a function of canopy level
+       ! and not PFT, since it will make for easier plotting
+       DO ivm=1,nvm
+          
+          WRITE(var_name,'(A,I3.3)') 'LAI_PER_LEVEL_',ivm
+          CALL histdef (hist_id_stom, &
+               &               TRIM(var_name), &
+               &               TRIM("Leaf Area Index per level                         "), &
+               &               TRIM("m^2 m^{-2}       "), iim,jjm, hist_hori_id, &
+               &               nlevels_tot,1,nlevels_tot, canx_tot_stom_id, 32, ave(3), dt, hist_dt)
+
+          WRITE(var_name,'(A,I3.3)') 'CLEVEL_HEIGHT_',ivm
+          CALL histdef (hist_id_stom, &
+               &               TRIM(var_name), &
+               &               TRIM("Physical height of each canopy level above the soil "), &
+               &               TRIM("m                "), iim,jjm, hist_hori_id, &
+               &               nlevels_tot,1,nlevels_tot, canx_tot_stom_id, 32, ave(3), dt, hist_dt)
+
+       ENDDO
+
+       !++++++++++++++++++++++++++++++++++++++++++++++++++++
+       ! THese variables can be calculated by others in the output file.
+       ! On principle, we are trying to not print them out.  It's better
+       ! to redo the calculation from the prognostic variables, even
+       ! if in some cases it means a bit of a headache.
+       ! 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(3), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("ST_MORTALITY                 "), &
+            &               TRIM("SELF-THINNING mortality "), &
+            &               TRIM("gC/day/(m^2 tot)    "), iim,jjm, hist_hori_id,&
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+     
+       CALL histdef (hist_id_stom, &
+            &               TRIM("D_MORTALITY                 "), &
+            &               TRIM("total mortality "), &
+            &               TRIM("gC/day/(m^2 tot)    "), iim,jjm,hist_hori_id,&
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+
+       
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("KILL_ST                 "), &
+            &               TRIM("SELF-THINNING mortality number"), &
+            &               TRIM("1/m2   "), iim,jjm, hist_hori_id,&
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("KILL_D                 "), &
+            &               TRIM("total mortality number "), &
+            &               TRIM("1/m2    "), iim,jjm,hist_hori_id,&
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+       
+       CALL histdef (hist_id_stom, &
+            &               TRIM("NEW_IND                 "), &
+            &               TRIM("new individuals  "), &
+            &               TRIM("1/m2    "), 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(3), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("LAIPIX              "), &
+            &               TRIM("Leaf Area Index per pixel                         "), &
+            &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+            &               1,1,1,-99,32, ave(3), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("GPPPIX             "), &
+            &               TRIM("Gross Primary Production per pixel                "), &
+            &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+            &               1,1,1, -99,32, ave(3), dt, hist_dt)
+
+       ! total soil and litter carbon....right now this is not calculated, so you have
+       ! to fix this if you want to use total_soil_carb
+       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(10), dt, hist_dt)
+
+
+       !-------------------------------------------------
+       ! All variables below this line are not important to our simulations,
+       ! to the best of our knowledge.
+
+          
+       ! 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)
+       
+       
+       ! 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(10), 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(10), 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, ave(10), 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(10), dt, hist_dt)      
+
+       ! Adaptation to climate
+       CALL histdef (hist_id_stom, &
+            &               TRIM("ADAPTATION          "), &
+            &               TRIM("Adaptation to climate (DGVM)                      "), &
+            &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+    
+       ! Probability from regenerative
+       CALL histdef (hist_id_stom, &
+            &               TRIM("REGENERATION        "), &
+            &               TRIM("Probability from regenerative (DGVM)               "), &
+            &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+       
+       ! crown area of individuals (m**2)
+       CALL histdef (hist_id_stom, &
+            &               TRIM("CN_IND              "), &
+            &               TRIM("crown area of individuals                         "), &
+            &               TRIM("m^2                 "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+       ! woodmass of individuals (gC)
+       CALL histdef (hist_id_stom, &
+            &               TRIM("WOODMASS_IND        "), &
+            &               TRIM("Woodmass of individuals                           "), &
+            &               TRIM("gC/pft              "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), 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)
+       
+       ! 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)
+       
+       ! 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(4), dt, hist_dt)
+       ! daily moisture stress
+       CALL histdef (hist_id_stom, &
+            &               TRIM("MOISTRESS_daily           "), &
+            &               TRIM("daily moisture stress"), &
+            &               TRIM("-                   "), iim,jjm, hist_hori_id,&
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+
+       ! added by yitong yao above lines Feb 24 2020 17:52
+       ! 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)
+
+       ! Establish tree
+       CALL histdef (hist_id_stom, &
+            &               TRIM("ESTABTREE           "), &
+            &               TRIM("Rate of tree establishement                       "), &
+            &               TRIM("1/day               "), iim,jjm, hist_hori_id, &
+            &               1,1,1, -99,32, ave(6), dt, hist_dt)
+
+       ! Establish grass
+       CALL histdef (hist_id_stom, &
+            &               TRIM("ESTABGRASS          "), &
+            &               TRIM("Rate of grass establishement                      "), &
+            &               TRIM("1/day               "), iim,jjm, hist_hori_id, &
+            &               1,1,1, -99,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)
+
+      ! added by yitong yao 11 Feb 2020 9:04am 
+      CALL histdef (hist_id_stom, &
+            &               TRIM("MAINT_RESP_LEAF       "), &
+            &               TRIM("maint resp  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)
+
+      CALL histdef (hist_id_stom, &
+            &               TRIM("MAINT_RESP_SAP_AB       "), &
+            &               TRIM("maint resp  allocated to sapwood_AB       "), &
+            &               TRIM("gC/m**2/pft/dt      "), iim,jjm, hist_hori_id,&
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+      
+      CALL histdef (hist_id_stom, &
+            &               TRIM("MAINT_RESP_SAP_BE       "), &
+            &               TRIM("maint resp  allocated to sapwood_BE       "), &
+            &               TRIM("gC/m**2/pft/dt      "), iim,jjm,hist_hori_id,&
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+      
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("MAINT_RESP_HEART_AB   "), &
+            &               TRIM("maint resp allocated to heartwood above ground "), &
+            &               TRIM("gC/m**2/pft/dt      "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(10), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("MAINT_RESP_HEART_BE   "), &
+            &               TRIM("maint resp allocated to heartwood below ground "), &
+            &               TRIM("gC/m**2/pft/dt      "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(10), dt, hist_dt)
+
+      CALL histdef (hist_id_stom, &
+            &               TRIM("MAINT_RESP_FRUIT   "), &
+            &               TRIM("maint resp allocated to fruit"), &
+            &               TRIM("gC/m**2/pft/dt      "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(10), dt, hist_dt)
+
+       
+
+       ! maint resp  allocated to roots
+       CALL histdef (hist_id_stom, &
+            &               TRIM("MAINT_RESP_ROOT       "), &
+            &               TRIM("maint resp 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)
+
+
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("GROWTH_RESP_LEAF       "), &
+            &               TRIM("growth resp  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)
+
+      CALL histdef (hist_id_stom, &
+            &               TRIM("GROWTH_RESP_SAP_AB       "), &
+            &               TRIM("growth resp  allocated to sapwood_AB       "), &
+            &               TRIM("gC/m**2/pft/dt      "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("GROWTH_RESP_SAP_BE       "), &
+            &               TRIM("growth resp  allocated to sapwood_BE       "), &
+            &               TRIM("gC/m**2/pft/dt      "), iim,jjm,hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("GROWTH_RESP_HEART_AB   "), &
+            &               TRIM("growth resp allocated to heartwood above ground "), &
+            &               TRIM("gC/m**2/pft/dt      "), iim,jjm, hist_hori_id,&
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(10), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("GROWTH_RESP_HEART_BE   "), &
+            &               TRIM("growth resp allocated to heartwood below ground "), &
+            &               TRIM("gC/m**2/pft/dt      "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(10), dt, hist_dt)
+
+        
+       CALL histdef (hist_id_stom, &
+            &               TRIM("GROWTH_RESP_ROOT       "), &
+            &               TRIM("growth resp 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)
+
+       ! added by yitong yao 11 Feb 2020 9:16 above defs 
+       CALL histdef (hist_id_stom, &
+            &               TRIM("BM_ALLOC_TOT       "), &
+            &               TRIM("biomass allocated to all"), &
+            &               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 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)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("BM_ALLOC_HEART_AB   "), &
+            &               TRIM("biomass allocated to heartwood above ground         "), &
+            &               TRIM("gC/m**2/pft/dt      "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(10), dt, hist_dt)
+
+       CALL histdef (hist_id_stom, &
+            &               TRIM("BM_ALLOC_HEART_BE   "), &
+            &               TRIM("biomass allocated to heartwood below ground         "), &
+            &               TRIM("gC/m**2/pft/dt      "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(10), 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)
+       
+       CALL histdef (hist_id_stom, &
+            &               TRIM("BM_ALLOC_LABILE        "), &
+            &               TRIM("biomass allocated to labile "), &
+            &               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_LEAF   "), &
+            &               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)
+
+       ! turnover time for grass roots                    
+       CALL histdef (hist_id_stom, &
+            &               TRIM("TURNOVER_TIME_ROOT   "), &
+            &               TRIM("turnover time for grass roots                    "), &
+            &               TRIM("days                "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+       ! turnover time for grass fruitss                    
+       CALL histdef (hist_id_stom, &
+            &               TRIM("TURNOVER_TIME_FRUIT  "), &
+            &               TRIM("turnover time for grass fruits                   "), &
+            &               TRIM("days                "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+       ! turnover time for grass sap                    
+       CALL histdef (hist_id_stom, &
+            &               TRIM("TURNOVER_TIME_SAP    "), &
+            &               TRIM("turnover time for grass structural carbon - stem "), &
+            &               TRIM("days                "), iim,jjm, hist_hori_id, &
+            &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+       
+       !  annual flux from the medium-lived wood product pool    
+       CALL histdef (hist_id_stom, &
+            &               TRIM("FLUX_S             "), &
+            &               TRIM("annual flux for short-lived wood product pool     "), &
+            &               TRIM("-                  "), iim,jjm, hist_hori_id, &
+            &               nshort,1,nshort, hist_pool_s_axis_id,32, ave(5), dt, hist_dt)
+
+       !  annual flux from the medium-lived wood product pool    
+       CALL histdef (hist_id_stom, &
+            &               TRIM("FLUX_M              "), &
+            &               TRIM("annual flux for medium-lived wood product pool    "), &
+            &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+            &               nmedium,1,nmedium, hist_pool_m_axis_id,32, ave(5), dt, hist_dt)
+
+       ! annual flux for each 100 year wood product pool   
+       CALL histdef (hist_id_stom, &
+            &               TRIM("FLUX_L              "), &
+            &               TRIM("annual flux for the long-lived wood product pool  "), &
+            &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+            &               nlong,1,nlong, hist_pool_l_axis_id,32, ave(5), dt, hist_dt)
+
+       ! annual release right after deforestation          
+       CALL histdef (hist_id_stom, &
+            &               TRIM("CFLUX_PROD_S        "), &
+            &               TRIM("annual release right after deforestation          "), &
+            &               TRIM("-                   "), 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_PROD_M        "), &
+            &               TRIM("annual release from all 10 year wood product pools"), &
+            &               TRIM("-                   "), 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_PROD_L       "), &
+            &               TRIM("annual release from all 100year wood product pools"), &
+            &               TRIM("-                  "), 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("-                 "), 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, ave(1), dt, hist_dt)
+       CALL histdef(hist_id_stom, 'RESOLUTION_Y', 'N-S resolution', 'm', &
+            & iim,jjm, hist_hori_id, 1,1,1, -99, 32, ave(1), dt, hist_dt)
+       CALL histdef(hist_id_stom, 'CONTFRAC', 'Continental fraction', '1', &
+            & iim,jjm, hist_hori_id, 1,1,1, -99, 32, once(10), dt, hist_dt)
+       CALL histdef(hist_id_stom, 'Areas', 'Mesh areas', 'm2', &
+            & iim,jjm, hist_hori_id, 1,1,1, -99, 32, once(10), dt, hist_dt)
+       
+       
+       IF ( control_flags%forest_management .OR. control_flags%ok_functional_allocation) THEN
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("BM_SYNC       "), &
+               &               TRIM("The difference between biomass and circ_class_biomass"), &
+               &               TRIM("gC m^{-2} "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, ave(10), dt, hist_dt)
+          
+          CALL histdef (hist_id_stom, &
+               &               TRIM("LAI_MAX_LYEAR "), &
+               &               TRIM("Max of LAI over the year "), &
+               &               TRIM("m^2/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("TOTAL_M_BE "), &
+               &               TRIM("Total living belowground biomass "), &
+               &               TRIM("gC/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("TOTAL_M_AB "), &
+               &               TRIM("Total living aboveground biomass "), &
+               &               TRIM("gC/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("TOTAL_WOOD_BE "), &
+               &               TRIM("Total belowground wood "), &
+               &               TRIM("gC/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("TOTAL_WOOD_AB "), &
+               &               TRIM("Total aboveground wood "), &
+               &               TRIM("gC/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          ! Aboveground wood biomass loss to mortality and export (gC/(m**2)) 
+          CALL histdef (hist_id_stom, &
+               &               TRIM("WOOD_LOSS_AB "), &
+               &               TRIM("Aboveground wood biomass loss "), &
+               &               TRIM("gC/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+
+          ! Belowround wood biomass loss to mortality and export (gC/(m**2)) 
+          CALL histdef (hist_id_stom, &
+               &               TRIM("WOOD_LOSS_BE "), &
+               &               TRIM("Belowground wood biomass loss "), &
+               &               TRIM("gC/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("WOOD_LOSS_AB_EOY "), &
+               &               TRIM("Aboveground wood biomass loss "), &
+               &               TRIM("gC/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("MAI       "), &
+               &               TRIM("Mean annual increment "), &
+               &               TRIM("m^3/m^2/year "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, ave(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("PAI       "), &
+               &               TRIM("Period annual increment "), &
+               &               TRIM("m^3/m^2/year "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, ave(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("ROTATION_N "), &
+               &               TRIM("Rotation number "), &
+               &               TRIM("- "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("LAST_CUT "), &
+               &               TRIM("Number of years since last human intervention "), &
+               &               TRIM("years "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, ave(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("DOM_HEIGHT "), &
+               &               TRIM("Dominant height of stand "), &
+               &               TRIM("m "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("AV_HEIGHT "), &
+               &               TRIM("Average height of stand "), &
+               &               TRIM("m "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("MED_HEIGHT "), &
+               &               TRIM("Median height of stand "), &
+               &               TRIM("m "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("Q1_HEIGHT "), &
+               &               TRIM("First quartile height of stand "), &
+               &               TRIM("m "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("Q3_HEIGHT "), &
+               &               TRIM("Third quartile height of stand "), &
+               &               TRIM("m "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("DELTAVOL "), &
+               &               TRIM("Annual aboveground volume increment "), &
+               &               TRIM("m^3/ha/yr "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("HAR_VOL "), &
+               &               TRIM("Harvestable volum "), &
+               &               TRIM("m^3/ha "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("HAR_VOL_INC "), &
+               &               TRIM("Yearly increment in harvestable volume "), &
+               &               TRIM("m^3/ha/yr "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("EXPORTED_VOL_TH "), &
+               &               TRIM("Exported volume for thinnings "), &
+               &               TRIM("m^3/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("STANDING_AB_BM "), &
+               &               TRIM("Standing aboveground biomass "), &
+               &               TRIM("gC/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("STANDING_AB_VOL "), &
+               &               TRIM("Standing aboveground volume "), &
+               &               TRIM("m^3/ha "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("EXPORTED_BM "), &
+               &               TRIM("Exported biomass "), &
+               &               TRIM("gC/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("EXPORTED_VOL "), &
+               &               TRIM("Exported volume "), &
+               &               TRIM("m^3/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CIRC_MIN "), &
+               &               TRIM("Minimum circumference in the stand "), &
+               &               TRIM("m "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CIRC_MAX "), &
+               &               TRIM("Maximum circumference in the stand "), &
+               &               TRIM("m "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC02 "), &
+               &               TRIM("Density of circ ranging 0-0.2m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC04 "), &
+               &               TRIM("Density of circ ranging 0.2m-0.4m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC06 "), &
+               &               TRIM("Density of circ ranging 0.4m-0.6m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC08 "), &
+               &               TRIM("Density of circ ranging 0.6m-0.8m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC10 "), &
+               &               TRIM("Density of circ ranging 0.8m-1m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC12 "), &
+               &               TRIM("Density of circ ranging 1m-1.2m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC14 "), &
+               &               TRIM("Density of circ ranging 1.2m-1.4m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC16 "), &
+               &               TRIM("Density of circ ranging 1.4m-1.6m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC18 "), &
+               &               TRIM("Density of circ ranging 1.6m-1.8m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC20 "), &
+               &               TRIM("Density of circ ranging 1.8m-2m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC222 "), &
+               &               TRIM("Density of circ greater than 2m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CCPO "), &
+               &               TRIM("Density of circ ranging 0m-0.235m (poles) "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CCSW "), &
+               &               TRIM("Density of circ ranging 0.235m-0.705m (small wood) "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CCMW "), &
+               &               TRIM("Density of circ ranging 0.705m-1.175m (medium wood) "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CCLW "), &
+               &               TRIM("Density of circ greater than 1.175m (large wood) "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("IND_BT "), &
+               &               TRIM("Density of trees before thinning "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC02_BT "), &
+               &               TRIM("Before thinning density of circ ranging 0m-0.2m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC04_BT "), &
+               &               TRIM("Before thinning density of circ ranging 0.2m-0.4m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC06_BT "), &
+               &               TRIM("Before thinning density of circ ranging 0.4m-0.6m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC08_BT "), &
+               &               TRIM("Before thinning density of circ ranging 0.6m-0.8m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC10_BT "), &
+               &               TRIM("Before thinning density of circ ranging 0.8m-1m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC12_BT "), &
+               &               TRIM("Before thinning density of circ ranging 1m-1.2m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC14_BT "), &
+               &               TRIM("Before thinning density of circ ranging 1.2m-1.4m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC16_BT "), &
+               &               TRIM("Before thinning density of circ ranging 1.4m-1.6m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC18_BT "), &
+               &               TRIM("Before thinning density of circ ranging 1.6m-1.8m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC20_BT "), &
+               &               TRIM("Before thinning density of circ ranging 1.8m-2m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CC222_BT "), &
+               &               TRIM("Before thinning density of circ greater than 2m "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CCPO_BT "), &
+               &               TRIM("Before thinning density of circ ranging 0m-0.235m (poles) "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CCSW_BT "), &
+               &               TRIM("Before thinning density of circ ranging 0.235m-0.705m (small wood) "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CCMW_BT "), &
+               &               TRIM("Before thinning density of circ ranging 0.705m-1.175m (medium wood) "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+          CALL histdef (hist_id_stom, &
+               &               TRIM("CCLW_BT "), &
+               &               TRIM("Before thinning density of circ greater than 1.175m (large wood) "), &
+               &               TRIM("1/m^2 "), iim, jjm, hist_hori_id, &
+               &               nvm, 1, nvm, hist_PFTaxis_id, 32, once(10), dt, hist_dt)
+
+       END IF ! ( control_flags%forest_managemenent )
+
+    ENDIF
+
+  END SUBROUTINE stom_define_history
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : stom_IPCC_define_history
+!!
+!>\BRIEF         Tell ioipsl which variables are to be written and on which grid they are defined
+!!
+!! DESCRIPTION  : 
+!!                
+!!                
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!! - 
+!!
+!! FLOWCHART    : 
+!_ ================================================================================================================================
+
+  SUBROUTINE stom_IPCC_define_history &
+       & (hist_id_stom_IPCC, nvm, iim, jjm, dt, &
+       &  hist_dt, hist_hori_id, hist_PFTaxis_id)
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                   :: hist_id_stom_IPCC     !! File id
+    INTEGER(i_std), INTENT(in)                   :: nvm                   !! number of PFTs
+    INTEGER(i_std), INTENT(in)                   :: iim, jjm              !! Domain size
+    REAL(r_std), INTENT(in)                      :: dt                    !! Time step of STOMATE (seconds)
+    REAL(r_std), INTENT(in)                      :: hist_dt               !! Time step of history file (s)
+    INTEGER(i_std), INTENT(in)                   :: hist_hori_id          !! id horizontal grid
+    INTEGER(i_std), INTENT(in)                   :: hist_PFTaxis_id       !! id of PFT axis
+
+    !! 0.4 Local variables
+
+    CHARACTER(LEN=40), DIMENSION(max_hist_level) :: ave                   !! Character strings to define operations for histdef
+
+!_ ================================================================================================================================
+
+    !=====================================================================
+    !- 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)
+    ! Carbon Mass Variation
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("cMassVariation"), &
+         &               TRIM("Terrestrial Carbon Mass Variation"), &
+         &               TRIM("kg C m-2 s-1"), 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: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/minpack.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/minpack.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/minpack.f90	(revision 7236)
@@ -0,0 +1,5848 @@
+function dpmpar(i)
+integer i
+!     **********
+!
+!     Function dpmpar
+!
+!     This function provides double precision machine parameters
+!     when the appropriate set of data statements is activated (by
+!     removing the c from column 1) and all other data statements are
+!     rendered inactive. Most of the parameter values were obtained
+!     from the corresponding Bell Laboratories Port Library function.
+!
+!     The function statement is
+!
+!       double precision function dpmpar(i)
+!
+!     where
+!
+!       i is an integer input variable set to 1, 2, or 3 which
+!         selects the desired machine parameter. If the machine has
+!         t base b digits and its smallest and largest exponents are
+!         emin and emax, respectively, then these parameters are
+!
+!         dpmpar(1) = b**(1 - t), the machine precision,
+!
+!         dpmpar(2) = b**(emin - 1), the smallest magnitude,
+!
+!         dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude.
+!
+!     Argonne National Laboratory. MINPACK Project. November 1996.
+!     Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More'
+!
+!     **********
+      integer mcheps(4)
+      integer minmag(4)
+      integer maxmag(4)
+      double precision dmach(3)
+      real ( kind = 8 )   dpmpar
+      equivalence (dmach(1),mcheps(1))
+      equivalence (dmach(2),minmag(1))
+      equivalence (dmach(3),maxmag(1))
+!
+!     Machine constants for the IBM 360/370 series,
+!     the Amdahl 470/V6, the ICL 2900, the Itel AS/6,
+!     the Xerox Sigma 5/7/9 and the Sel systems 85/86.
+!
+!     data mcheps(1),mcheps(2) / z34100000, z00000000 /
+!     data minmag(1),minmag(2) / z00100000, z00000000 /
+!     data maxmag(1),maxmag(2) / z7fffffff, zffffffff /
+!
+!     Machine constants for the Honeywell 600/6000 series.
+!
+!     data mcheps(1),mcheps(2) / o606400000000, o000000000000 /
+!     data minmag(1),minmag(2) / o402400000000, o000000000000 /
+!     data maxmag(1),maxmag(2) / o376777777777, o777777777777 /
+!
+!     Machine constants for the CDC 6000/7000 series.
+!
+!     data mcheps(1) / 15614000000000000000b /
+!     data mcheps(2) / 15010000000000000000b /
+!
+!     data minmag(1) / 00604000000000000000b /
+!     data minmag(2) / 00000000000000000000b /
+!
+!     data maxmag(1) / 37767777777777777777b /
+!     data maxmag(2) / 37167777777777777777b /
+!
+!     Machine constants for the PDP-10 (KA processor).
+!
+!     data mcheps(1),mcheps(2) / "114400000000, "000000000000 /
+!     data minmag(1),minmag(2) / "033400000000, "000000000000 /
+!     data maxmag(1),maxmag(2) / "377777777777, "344777777777 /
+!
+!     Machine constants for the PDP-10 (KI processor).
+!
+!     data mcheps(1),mcheps(2) / "104400000000, "000000000000 /
+!     data minmag(1),minmag(2) / "000400000000, "000000000000 /
+!     data maxmag(1),maxmag(2) / "377777777777, "377777777777 /
+!
+!     Machine constants for the PDP-11. 
+!
+!     data mcheps(1),mcheps(2) /   9472,      0 /
+!     data mcheps(3),mcheps(4) /      0,      0 /
+!
+!     data minmag(1),minmag(2) /    128,      0 /
+!     data minmag(3),minmag(4) /      0,      0 /
+!
+!     data maxmag(1),maxmag(2) /  32767,     -1 /
+!     data maxmag(3),maxmag(4) /     -1,     -1 /
+!
+!     Machine constants for the Burroughs 6700/7700 systems.
+!
+!     data mcheps(1) / o1451000000000000 /
+!     data mcheps(2) / o0000000000000000 /
+!
+!     data minmag(1) / o1771000000000000 /
+!     data minmag(2) / o7770000000000000 /
+!
+!     data maxmag(1) / o0777777777777777 /
+!     data maxmag(2) / o7777777777777777 /
+!
+!     Machine constants for the Burroughs 5700 system.
+!
+!     data mcheps(1) / o1451000000000000 /
+!     data mcheps(2) / o0000000000000000 /
+!
+!     data minmag(1) / o1771000000000000 /
+!     data minmag(2) / o0000000000000000 /
+!
+!     data maxmag(1) / o0777777777777777 /
+!     data maxmag(2) / o0007777777777777 /
+!
+!     Machine constants for the Burroughs 1700 system.
+!
+!     data mcheps(1) / zcc6800000 /
+!     data mcheps(2) / z000000000 /
+!
+!     data minmag(1) / zc00800000 /
+!     data minmag(2) / z000000000 /
+!
+!     data maxmag(1) / zdffffffff /
+!     data maxmag(2) / zfffffffff /
+!
+!     Machine constants for the Univac 1100 series.
+!
+!     data mcheps(1),mcheps(2) / o170640000000, o000000000000 /
+!     data minmag(1),minmag(2) / o000040000000, o000000000000 /
+!     data maxmag(1),maxmag(2) / o377777777777, o777777777777 /
+!
+!     Machine constants for the Data General Eclipse S/200.
+!
+!     Note - it may be appropriate to include the following card -
+!     static dmach(3)
+!
+!     data minmag/20k,3*0/,maxmag/77777k,3*177777k/
+!     data mcheps/32020k,3*0/
+!
+!     Machine constants for the Harris 220.
+!
+!     data mcheps(1),mcheps(2) / '20000000, '00000334 /
+!     data minmag(1),minmag(2) / '20000000, '00000201 /
+!     data maxmag(1),maxmag(2) / '37777777, '37777577 /
+!
+!     Machine constants for the Cray-1.
+!
+!     data mcheps(1) / 0376424000000000000000b /
+!     data mcheps(2) / 0000000000000000000000b /
+!
+!     data minmag(1) / 0200034000000000000000b /
+!     data minmag(2) / 0000000000000000000000b /
+!
+!     data maxmag(1) / 0577777777777777777777b /
+!     data maxmag(2) / 0000007777777777777776b /
+!
+!     Machine constants for the Prime 400.
+!
+!     data mcheps(1),mcheps(2) / :10000000000, :00000000123 /
+!     data minmag(1),minmag(2) / :10000000000, :00000100000 /
+!     data maxmag(1),maxmag(2) / :17777777777, :37777677776 /
+!
+!     Machine constants for the VAX-11.
+!
+!     data mcheps(1),mcheps(2) /   9472,  0 /
+!     data minmag(1),minmag(2) /    128,  0 /
+!     data maxmag(1),maxmag(2) / -32769, -1 /
+!
+!     Machine constants for IEEE machines.
+!
+      data dmach(1) /2.22044604926d-16/
+      data dmach(2) /2.22507385852d-308/
+      data dmach(3) /1.79769313485d+308/
+!
+      dpmpar = dmach(i)
+      return
+!
+!     Last card of function dpmpar.
+!
+end function dpmpar
+function enorm ( n, x )
+
+!*****************************************************************************80
+!
+!! ENORM computes the Euclidean norm of a vector.
+!
+!  Discussion:
+!
+!    This is an extremely simplified version of the original ENORM
+!    routine, which has been renamed to "ENORM2".
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, is the length of the vector.
+!
+!    Input, real ( kind = 8 ) X(N), the vector whose norm is desired.
+!
+!    Output, real ( kind = 8 ) ENORM, the Euclidean norm of the vector.
+!
+  implicit none
+
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) x(n)
+  real ( kind = 8 ) enorm
+
+  enorm = sqrt ( sum ( x(1:n)**2 ))
+
+  return
+end function enorm
+function enorm2 ( n, x )
+
+!*****************************************************************************80
+!
+!! ENORM2 computes the Euclidean norm of a vector.
+!
+!  Discussion:
+!
+!    This routine was named ENORM.  It has been renamed "ENORM2",
+!    and a simplified routine has been substituted.
+!
+!    The Euclidean norm is computed by accumulating the sum of
+!    squares in three different sums.  The sums of squares for the
+!    small and large components are scaled so that no overflows
+!    occur.  Non-destructive underflows are permitted.  Underflows
+!    and overflows do not occur in the computation of the unscaled
+!    sum of squares for the intermediate components.
+!
+!    The definitions of small, intermediate and large components
+!    depend on two constants, RDWARF and RGIANT.  The main
+!    restrictions on these constants are that RDWARF**2 not
+!    underflow and RGIANT**2 not overflow.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1
+!    Argonne National Laboratory,
+!    Argonne, Illinois.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, is the length of the vector.
+!
+!    Input, real ( kind = 8 ) X(N), the vector whose norm is desired.
+!
+!    Output, real ( kind = 8 ) ENORM2, the Euclidean norm of the vector.
+!
+  implicit none
+
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) agiant
+  real ( kind = 8 ) enorm2
+  integer ( kind = 4 ) i
+  real ( kind = 8 ) rdwarf
+  real ( kind = 8 ) rgiant
+  real ( kind = 8 ) s1
+  real ( kind = 8 ) s2
+  real ( kind = 8 ) s3
+  real ( kind = 8 ) x(n)
+  real ( kind = 8 ) xabs
+  real ( kind = 8 ) x1max
+  real ( kind = 8 ) x3max
+
+  rdwarf = sqrt ( tiny ( rdwarf ) )
+  rgiant = sqrt ( huge ( rgiant ) )
+
+  s1 = 0.0D+00
+  s2 = 0.0D+00
+  s3 = 0.0D+00
+  x1max = 0.0D+00
+  x3max = 0.0D+00
+  agiant = rgiant / real ( n, kind = 8 )
+
+  do i = 1, n
+
+    xabs = abs ( x(i) )
+
+    if ( xabs <= rdwarf ) then
+
+      if ( x3max < xabs ) then
+        s3 = 1.0D+00 + s3 * ( x3max / xabs )**2
+        x3max = xabs
+      else if ( xabs /= 0.0D+00 ) then
+        s3 = s3 + ( xabs / x3max )**2
+      end if
+
+    else if ( agiant <= xabs ) then
+
+      if ( x1max < xabs ) then
+        s1 = 1.0D+00 + s1 * ( x1max / xabs )**2
+        x1max = xabs
+      else
+        s1 = s1 + ( xabs / x1max )**2
+      end if
+
+    else
+
+      s2 = s2 + xabs**2
+
+    end if
+
+  end do
+!
+!  Calculation of norm.
+!
+  if ( s1 /= 0.0D+00 ) then
+
+    enorm2 = x1max * sqrt ( s1 + ( s2 / x1max ) / x1max )
+
+  else if ( s2 /= 0.0D+00 ) then
+
+    if ( x3max <= s2 ) then
+      enorm2 = sqrt ( s2 * ( 1.0D+00 + ( x3max / s2 ) * ( x3max * s3 ) ) )
+    else
+      enorm2 = sqrt ( x3max * ( ( s2 / x3max ) + ( x3max * s3 ) ) )
+    end if
+
+  else
+
+    enorm2 = x3max * sqrt ( s3 )
+
+  end if
+
+  return
+end function enorm2
+subroutine chkder ( m, n, x, fvec, fjac, ldfjac, xp, fvecp, mode, err )
+
+!*****************************************************************************80
+!
+!! CHKDER checks the gradients of M functions of N variables.
+!
+!  Discussion:
+!
+!    CHKDER checks the gradients of M nonlinear functions in N variables,
+!    evaluated at a point X, for consistency with the functions themselves.
+!
+!    The user calls CHKDER twice, first with MODE = 1 and then with MODE = 2.
+!
+!    MODE = 1.
+!      On input,
+!        X contains the point of evaluation.
+!      On output,
+!        XP is set to a neighboring point.
+!
+!    Now the user must evaluate the function and gradients at X, and the
+!    function at XP.  Then the subroutine is called again:
+!
+!    MODE = 2.
+!      On input,
+!        FVEC contains the function values at X,
+!        FJAC contains the function gradients at X.
+!        FVECP contains the functions evaluated at XP.
+!      On output,
+!        ERR contains measures of correctness of the respective gradients.
+!
+!    The subroutine does not perform reliably if cancellation or
+!    rounding errors cause a severe loss of significance in the
+!    evaluation of a function.  Therefore, none of the components
+!    of X should be unusually small (in particular, zero) or any
+!    other value which may cause loss of significance.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) M, is the number of functions.
+!
+!    Input, integer ( kind = 4 ) N, is the number of variables.
+!
+!    Input, real ( kind = 8 ) X(N), the point at which the jacobian is to be
+!    evaluated.
+!
+!    Input, real ( kind = 8 ) FVEC(M), is used only when MODE = 2.
+!    In that case, it should contain the function values at X.
+!
+!    Input, real ( kind = 8 ) FJAC(LDFJAC,N), an M by N array.  When MODE = 2,
+!    FJAC(I,J) should contain the value of dF(I)/dX(J).
+!
+!    Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC.
+!    LDFJAC must be at least M.
+!
+!    Output, real ( kind = 8 ) XP(N), on output with MODE = 1, is a neighboring
+!    point of X, at which the function is to be evaluated.
+!
+!    Input, real ( kind = 8 ) FVECP(M), on input with MODE = 2, is the function
+!    value at XP.
+!
+!    Input, integer ( kind = 4 ) MODE, should be set to 1 on the first call, and
+!    2 on the second.
+!
+!    Output, real ( kind = 8 ) ERR(M).  On output when MODE = 2, ERR contains
+!    measures of correctness of the respective gradients.  If there is no
+!    severe loss of significance, then if ERR(I):
+!      = 1.0D+00, the I-th gradient is correct,
+!      = 0.0D+00, the I-th gradient is incorrect.
+!      > 0.5D+00, the I-th gradient is probably correct.
+!      < 0.5D+00, the I-th gradient is probably incorrect.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldfjac
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) eps
+  real ( kind = 8 ) epsf
+  real ( kind = 8 ) epslog
+  real ( kind = 8 ) epsmch
+  real ( kind = 8 ) err(m)
+  real ( kind = 8 ) fjac(ldfjac,n)
+  real ( kind = 8 ) fvec(m)
+  real ( kind = 8 ) fvecp(m)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) mode
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) x(n)
+  real ( kind = 8 ) xp(n)
+
+  epsmch = epsilon ( epsmch )
+  eps = sqrt ( epsmch )
+!
+!  MODE = 1.
+!
+  if ( mode == 1 ) then
+
+     do j = 1, n
+       temp = eps * abs ( x(j) )
+       if ( temp == 0.0D+00 ) then
+         temp = eps
+       end if
+       xp(j) = x(j) + temp
+     end do
+!
+!  MODE = 2.
+!
+  else if ( mode == 2 ) then
+
+     epsf = 100.0D+00 * epsmch
+     epslog = log10 ( eps )
+
+     err = 0.0D+00
+
+     do j = 1, n
+       temp = abs ( x(j) )
+       if ( temp == 0.0D+00 ) then
+         temp = 1.0D+00
+       end if
+       err(1:m) = err(1:m) + temp * fjac(1:m,j)
+     end do
+
+     do i = 1, m
+
+       temp = 1.0D+00
+
+       if ( fvec(i) /= 0.0D+00 .and. fvecp(i) /= 0.0D+00 .and. &
+         abs ( fvecp(i)-fvec(i)) >= epsf * abs ( fvec(i) ) ) then
+         temp = eps * abs ( (fvecp(i)-fvec(i)) / eps - err(i) ) &
+           / ( abs ( fvec(i) ) + abs ( fvecp(i) ) )
+       end if
+
+       err(i) = 1.0D+00
+
+       if ( epsmch < temp .and. temp < eps ) then
+         err(i) = ( log10 ( temp ) - epslog ) / epslog
+       end if
+
+       if ( eps <= temp ) then
+         err(i) = 0.0D+00
+       end if
+
+     end do
+
+  end if
+
+  return
+end subroutine chkder
+subroutine dogleg ( n, r, lr, diag, qtb, delta, x )
+
+!*****************************************************************************80
+!
+!! DOGLEG finds the minimizing combination of Gauss-Newton and gradient steps.
+!
+!  Discussion:
+!
+!    Given an M by N matrix A, an N by N nonsingular diagonal
+!    matrix D, an M-vector B, and a positive number DELTA, the
+!    problem is to determine the convex combination X of the
+!    Gauss-Newton and scaled gradient directions that minimizes
+!    (A*X - B) in the least squares sense, subject to the
+!    restriction that the euclidean norm of D*X be at most DELTA.
+!
+!    This subroutine completes the solution of the problem
+!    if it is provided with the necessary information from the
+!    QR factorization of A.  That is, if A = Q*R, where Q has
+!    orthogonal columns and R is an upper triangular matrix,
+!    then DOGLEG expects the full upper triangle of R and
+!    the first N components of Q'*B.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the order of the matrix R.
+!
+!    Input, real ( kind = 8 ) R(LR), the upper triangular matrix R stored
+!    by rows.
+!
+!    Input, integer ( kind = 4 ) LR, the size of the R array, which must be 
+!    no less than (N*(N+1))/2.
+!
+!    Input, real ( kind = 8 ) DIAG(N), the diagonal elements of the matrix D.
+!
+!    Input, real ( kind = 8 ) QTB(N), the first N elements of the vector Q'* B.
+!
+!    Input, real ( kind = 8 ) DELTA, is a positive upper bound on the
+!    euclidean norm of D*X(1:N).
+!
+!    Output, real ( kind = 8 ) X(N), the desired convex combination of the
+!    Gauss-Newton direction and the scaled gradient direction.
+!
+  implicit none
+
+  integer ( kind = 4 ) lr
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) alpha
+  real ( kind = 8 ) bnorm
+  real ( kind = 8 ) delta
+  real ( kind = 8 ) diag(n)
+  real ( kind = 8 ) enorm
+  real ( kind = 8 ) epsmch
+  real ( kind = 8 ) gnorm
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) jj
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) l
+  real ( kind = 8 ) qnorm
+  real ( kind = 8 ) qtb(n)
+  real ( kind = 8 ) r(lr)
+  real ( kind = 8 ) sgnorm
+  real ( kind = 8 ) sum2
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) wa1(n)
+  real ( kind = 8 ) wa2(n)
+  real ( kind = 8 ) x(n)
+
+  epsmch = epsilon ( epsmch )
+!
+!  Calculate the Gauss-Newton direction.
+!
+  jj = ( n * ( n + 1 ) ) / 2 + 1
+
+  do k = 1, n
+
+     j = n - k + 1
+     jj = jj - k
+     l = jj + 1
+     sum2 = 0.0D+00
+
+     do i = j + 1, n
+       sum2 = sum2 + r(l) * x(i)
+       l = l + 1
+     end do
+
+     temp = r(jj)
+
+     if ( temp == 0.0D+00 ) then
+
+       l = j
+       do i = 1, j
+         temp = max ( temp, abs ( r(l)) )
+         l = l + n - i
+       end do
+
+       if ( temp == 0.0D+00 ) then
+         temp = epsmch
+       else
+         temp = epsmch * temp
+       end if
+
+     end if
+
+     x(j) = ( qtb(j) - sum2 ) / temp
+
+  end do
+!
+!  Test whether the Gauss-Newton direction is acceptable.
+!
+  wa1(1:n) = 0.0D+00
+  wa2(1:n) = diag(1:n) * x(1:n)
+  qnorm = enorm ( n, wa2 )
+
+  if ( qnorm <= delta ) then
+    return
+  end if
+!
+!  The Gauss-Newton direction is not acceptable.
+!  Calculate the scaled gradient direction.
+!
+  l = 1
+  do j = 1, n
+     temp = qtb(j)
+     do i = j, n
+       wa1(i) = wa1(i) + r(l) * temp
+       l = l + 1
+     end do
+     wa1(j) = wa1(j) / diag(j)
+  end do
+!
+!  Calculate the norm of the scaled gradient.
+!  Test for the special case in which the scaled gradient is zero.
+!
+  gnorm = enorm ( n, wa1 )
+  sgnorm = 0.0D+00
+  alpha = delta / qnorm
+
+  if ( gnorm /= 0.0D+00 ) then
+!
+!  Calculate the point along the scaled gradient which minimizes the quadratic.
+!
+    wa1(1:n) = ( wa1(1:n) / gnorm ) / diag(1:n)
+
+    l = 1
+    do j = 1, n
+      sum2 = 0.0D+00
+      do i = j, n
+        sum2 = sum2 + r(l) * wa1(i)
+        l = l + 1
+      end do
+      wa2(j) = sum2
+    end do
+
+    temp = enorm ( n, wa2 )
+    sgnorm = ( gnorm / temp ) / temp
+!
+!  Test whether the scaled gradient direction is acceptable.
+!
+    alpha = 0.0D+00
+!
+!  The scaled gradient direction is not acceptable.
+!  Calculate the point along the dogleg at which the quadratic is minimized.
+!
+    if ( sgnorm < delta ) then
+
+      bnorm = enorm ( n, qtb )
+      temp = ( bnorm / gnorm ) * ( bnorm / qnorm ) * ( sgnorm / delta )
+      temp = temp - ( delta / qnorm ) * ( sgnorm / delta)**2 &
+        + sqrt ( ( temp - ( delta / qnorm ) )**2 &
+        + ( 1.0D+00 - ( delta / qnorm )**2 ) &
+        * ( 1.0D+00 - ( sgnorm / delta )**2 ) )
+
+      alpha = ( ( delta / qnorm ) * ( 1.0D+00 - ( sgnorm / delta )**2 ) ) / temp
+
+    end if
+
+  end if
+!
+!  Form appropriate convex combination of the Gauss-Newton
+!  direction and the scaled gradient direction.
+!
+  temp = ( 1.0D+00 - alpha ) * min ( sgnorm, delta )
+
+  x(1:n) = temp * wa1(1:n) + alpha * x(1:n)
+
+  return
+end subroutine dogleg
+subroutine fdjac1 ( fcn, n, x, m, pars, fvec, fjac, ldfjac, iflag, ml, mu, epsfcn )
+
+!*****************************************************************************80
+!
+!! FDJAC1 estimates an N by N jacobian matrix using forward differences.
+!
+!  Discussion:
+!
+!    This subroutine computes a forward-difference approximation
+!    to the N by N jacobian matrix associated with a specified
+!    problem of N functions in N variables. If the jacobian has
+!    a banded form, then function evaluations are saved by only
+!    approximating the nonzero terms.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, external FCN, the name of the user-supplied subroutine which
+!    calculates the functions.  The routine should have the form:
+!
+!      subroutine fcn ( n, x, fvec, iflag )
+!
+!      integer ( kind = 4 ) n
+!
+!      real fvec(n)
+!      integer ( kind = 4 ) iflag
+!      real x(n)
+!
+!    The value of IFLAG should not be changed by FCN unless
+!    the user wants to terminate execution of the routine.
+!    In this case set IFLAG to a negative integer.
+!
+!    Input, integer ( kind = 4 ) N, the number of functions and variables.
+!
+!    Input, real ( kind = 8 ) X(N), the point where the jacobian is evaluated.
+!
+!    Input, real ( kind = 8 ) FVEC(N), the functions evaluated at X.
+!
+!    Output, real ( kind = 8 ) FJAC(LDFJAC,N), the N by N approximate
+!    jacobian matrix.
+!
+!    Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC, which
+!    must not be less than N.
+!
+!    Output, integer ( kind = 4 ) IFLAG, is an error flag returned by FCN.  
+!    If FCN returns a nonzero value of IFLAG, then this routine returns 
+!    immediately to the calling program, with the value of IFLAG.
+!
+!    Input, integer ( kind = 4 ) ML, MU, specify the number of subdiagonals and
+!    superdiagonals within the band of the jacobian matrix.  If the
+!    jacobian is not banded, set ML and MU to N-1.
+!
+!    Input, real ( kind = 8 ) EPSFCN, is used in determining a suitable step
+!    length for the forward-difference approximation.  This approximation
+!    assumes that the relative errors in the functions are of the order of
+!    EPSFCN.  If EPSFCN is less than the machine precision, it is assumed that
+!    the relative errors in the functions are of the order of the machine
+!    precision.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldfjac
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) m
+
+  real ( kind = 8 ) eps
+  real ( kind = 8 ) epsfcn
+  real ( kind = 8 ) epsmch
+  external fcn
+  real ( kind = 8 ) fjac(ldfjac,n)
+  real ( kind = 8 ) fvec(n)
+  real ( kind = 8 ) h
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) iflag
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) ml
+  integer ( kind = 4 ) msum
+  integer ( kind = 4 ) mu
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) wa1(n)
+  real ( kind = 8 ) wa2(n)
+  real ( kind = 8 ) x(n)
+  real ( kind = 8 ) pars(m)
+
+  epsmch = epsilon ( epsmch )
+
+  eps = sqrt ( max ( epsfcn, epsmch ) )
+  msum = ml + mu + 1
+!
+!  Computation of dense approximate jacobian.
+!
+  if ( n <= msum ) then
+
+     do j = 1, n
+
+        temp = x(j)
+        h = eps * abs ( temp )
+        if ( h == 0.0D+00 ) then
+          h = eps
+        end if
+
+        x(j) = temp + h
+        call fcn ( n, x, m, pars, wa1, iflag )
+
+        if ( iflag < 0 ) then
+          exit
+        end if
+
+        x(j) = temp
+        fjac(1:n,j) = ( wa1(1:n) - fvec(1:n) ) / h
+
+     end do
+
+  else
+!
+!  Computation of banded approximate jacobian.
+!
+     do k = 1, msum
+
+        do j = k, n, msum
+          wa2(j) = x(j)
+          h = eps * abs ( wa2(j) )
+          if ( h == 0.0D+00 ) then
+            h = eps
+          end if
+          x(j) = wa2(j) + h
+        end do
+
+        call fcn ( n, x, m, pars, wa1, iflag )
+
+        if ( iflag < 0 ) then
+          exit
+        end if
+
+        do j = k, n, msum
+
+           x(j) = wa2(j)
+
+           h = eps * abs ( wa2(j) )
+           if ( h == 0.0D+00 ) then
+             h = eps
+           end if
+
+           fjac(1:n,j) = 0.0D+00
+
+           do i = 1, n
+             if ( j - mu <= i .and. i <= j + ml ) then
+               fjac(i,j) = ( wa1(i) - fvec(i) ) / h
+             end if
+           end do
+
+        end do
+
+     end do
+
+  end if
+
+  return
+end subroutine fdjac1
+subroutine fdjac2 ( fcn, m, n, x, fvec, fjac, ldfjac, iflag, epsfcn )
+
+!*****************************************************************************80
+!
+!! FDJAC2 estimates an M by N jacobian matrix using forward differences.
+!
+!  Discussion:
+!
+!    This subroutine computes a forward-difference approximation
+!    to the M by N jacobian matrix associated with a specified
+!    problem of M functions in N variables.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, external FCN, the name of the user-supplied subroutine which
+!    calculates the functions.  The routine should have the form:
+!
+!      subroutine fcn ( m, n, x, fvec, iflag )
+!      integer ( kind = 4 ) n
+!      real fvec(m)
+!      integer ( kind = 4 ) iflag
+!      real x(n)
+!
+!    The value of IFLAG should not be changed by FCN unless
+!    the user wants to terminate execution of the routine.
+!    In this case set IFLAG to a negative integer.
+!
+!    Input, integer ( kind = 4 ) M, is the number of functions.
+!
+!    Input, integer ( kind = 4 ) N, is the number of variables.  
+!    N must not exceed M.
+!
+!    Input, real ( kind = 8 ) X(N), the point where the jacobian is evaluated.
+!
+!    Input, real ( kind = 8 ) FVEC(M), the functions evaluated at X.
+!
+!    Output, real ( kind = 8 ) FJAC(LDFJAC,N), the M by N approximate
+!    jacobian matrix.
+!
+!    Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC, 
+!    which must not be less than M.
+!
+!    Output, integer ( kind = 4 ) IFLAG, is an error flag returned by FCN.  
+!    If FCN returns a nonzero value of IFLAG, then this routine returns 
+!    immediately to the calling program, with the value of IFLAG.
+!
+!    Input, real ( kind = 8 ) EPSFCN, is used in determining a suitable
+!    step length for the forward-difference approximation.  This approximation
+!    assumes that the relative errors in the functions are of the order of
+!    EPSFCN.  If EPSFCN is less than the machine precision, it is assumed that
+!    the relative errors in the functions are of the order of the machine
+!    precision.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldfjac
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) eps
+  real ( kind = 8 ) epsfcn
+  real ( kind = 8 ) epsmch
+  external fcn
+  real ( kind = 8 ) fjac(ldfjac,n)
+  real ( kind = 8 ) fvec(m)
+  real ( kind = 8 ) h
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) iflag
+  integer ( kind = 4 ) j
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) wa(m)
+  real ( kind = 8 ) x(n)
+
+  epsmch = epsilon ( epsmch )
+
+  eps = sqrt ( max ( epsfcn, epsmch ) )
+
+  do j = 1, n
+
+    temp = x(j)
+    h = eps * abs ( temp )
+    if ( h == 0.0D+00 ) then
+      h = eps
+    end if
+
+    x(j) = temp + h
+    call fcn ( m, n, x, wa, iflag )
+
+    if ( iflag < 0 ) then
+      exit
+    end if
+
+    x(j) = temp
+    fjac(1:m,j) = ( wa(1:m) - fvec(1:m) ) / h
+
+  end do
+
+  return
+end subroutine fdjac2
+subroutine hybrd ( fcn, n, x, m, pars, fvec, xtol, maxfev, ml, mu, epsfcn, diag, mode, &
+  factor, nprint, info, nfev, fjac, ldfjac, r, lr, qtf )
+
+!*****************************************************************************80
+!
+!! HYBRD seeks a zero of N nonlinear equations in N variables.
+!
+!  Discussion:
+!
+!    HYBRD finds a zero of a system of N nonlinear functions in N variables
+!    by a modification of the Powell hybrid method.  The user must provide a
+!    subroutine which calculates the functions.  The jacobian is
+!    then calculated by a forward-difference approximation.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, external FCN, the name of the user-supplied subroutine which
+!    calculates the functions.  The routine should have the form:
+!
+!      subroutine fcn ( n, x, fvec, iflag )
+!      integer ( kind = 4 ) n
+!      real fvec(n)
+!      integer ( kind = 4 ) iflag
+!      real x(n)
+!
+!    The value of IFLAG should not be changed by FCN unless
+!    the user wants to terminate execution of the routine.
+!    In this case set IFLAG to a negative integer.
+!
+!    Input, integer ( kind = 4 ) N, the number of functions and variables.
+!
+!    Input/output, real ( kind = 8 ) X(N).  On input, X must contain an initial
+!    estimate of the solution vector.  On output X contains the final
+!    estimate of the solution vector.
+!
+!    Output, real ( kind = 8 ) FVEC(N), the functions evaluated at the output X.
+!
+!    Input, real ( kind = 8 ) XTOL.  Termination occurs when the relative error
+!    between two consecutive iterates is at most XTOL.  XTOL should be
+!    nonnegative.
+!
+!    Input, integer ( kind = 4 ) MAXFEV.  Termination occurs when the number of
+!    calls to FCN is at least MAXFEV by the end of an iteration.
+!
+!    Input, integer ( kind = 4 ) ML, MU, specify the number of subdiagonals and
+!    superdiagonals within the band of the jacobian matrix.  If the jacobian
+!    is not banded, set ML and MU to at least n - 1.
+!
+!    Input, real ( kind = 8 ) EPSFCN, is used in determining a suitable step
+!    length for the forward-difference approximation.  This approximation
+!    assumes that the relative errors in the functions are of the order of
+!    EPSFCN.  If EPSFCN is less than the machine precision, it is assumed that
+!    the relative errors in the functions are of the order of the machine
+!    precision.
+!
+!    Input/output, real ( kind = 8 ) DIAG(N).  If MODE = 1, then DIAG is set
+!    internally.  If MODE = 2, then DIAG must contain positive entries that
+!    serve as multiplicative scale factors for the variables.
+!
+!    Input, integer ( kind = 4 ) MODE, scaling option.
+!    1, variables will be scaled internally.
+!    2, scaling is specified by the input DIAG vector.
+!
+!    Input, real ( kind = 8 ) FACTOR, determines the initial step bound.  This
+!    bound is set to the product of FACTOR and the euclidean norm of DIAG*X if
+!    nonzero, or else to FACTOR itself.  In most cases, FACTOR should lie
+!    in the interval (0.1, 100) with 100 the recommended value.
+!
+!    Input, integer ( kind = 4 ) NPRINT, enables controlled printing of
+!    iterates if it is positive.  In this case, FCN is called with IFLAG = 0 at
+!    the beginning of the first iteration and every NPRINT iterations thereafter
+!    and immediately prior to return, with X and FVEC available
+!    for printing.  If NPRINT is not positive, no special calls
+!    of FCN with IFLAG = 0 are made.
+!
+!    Output, integer ( kind = 4 ) INFO, error flag.  If the user has terminated
+!    execution, INFO is set to the (negative) value of IFLAG.
+!    See the description of FCN.
+!    Otherwise, INFO is set as follows:
+!    0, improper input parameters.
+!    1, relative error between two consecutive iterates is at most XTOL.
+!    2, number of calls to FCN has reached or exceeded MAXFEV.
+!    3, XTOL is too small.  No further improvement in the approximate
+!       solution X is possible.
+!    4, iteration is not making good progress, as measured by the improvement
+!       from the last five jacobian evaluations.
+!    5, iteration is not making good progress, as measured by the improvement
+!       from the last ten iterations.
+!
+!    Output, integer ( kind = 4 ) NFEV, the number of calls to FCN.
+!
+!    Output, real ( kind = 8 ) FJAC(LDFJAC,N), an N by N array which contains
+!    the orthogonal matrix Q produced by the QR factorization of the final
+!    approximate jacobian.
+!
+!    Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC.
+!    LDFJAC must be at least N.
+!
+!    Output, real ( kind = 8 ) R(LR), the upper triangular matrix produced by
+!    the QR factorization of the final approximate jacobian, stored rowwise.
+!
+!    Input, integer ( kind = 4 ) LR, the size of the R array, which must be no
+!    less than (N*(N+1))/2.
+!
+!    Output, real ( kind = 8 ) QTF(N), contains the vector Q'*FVEC.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldfjac
+  integer ( kind = 4 ) lr
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) m
+
+  real ( kind = 8 ) actred
+  real ( kind = 8 ) delta
+  real ( kind = 8 ) diag(n)
+  real ( kind = 8 ) enorm
+  real ( kind = 8 ) epsfcn
+  real ( kind = 8 ) epsmch
+  real ( kind = 8 ) factor
+  external fcn
+  real ( kind = 8 ) fjac(ldfjac,n)
+  real ( kind = 8 ) fnorm
+  real ( kind = 8 ) fnorm1
+  real ( kind = 8 ) fvec(n)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) iflag
+  integer ( kind = 4 ) info
+  integer ( kind = 4 ) iter
+  integer ( kind = 4 ) iwa(1)
+  integer ( kind = 4 ) j
+  logical jeval
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) maxfev
+  integer ( kind = 4 ) ml
+  integer ( kind = 4 ) mode
+  integer ( kind = 4 ) msum
+  integer ( kind = 4 ) mu
+  integer ( kind = 4 ) ncfail
+  integer ( kind = 4 ) nslow1
+  integer ( kind = 4 ) nslow2
+  integer ( kind = 4 ) ncsuc
+  integer ( kind = 4 ) nfev
+  integer ( kind = 4 ) nprint
+  real ( kind = 8 ) pnorm
+  real ( kind = 8 ) prered
+  real ( kind = 8 ) qtf(n)
+  real ( kind = 8 ) r(lr)
+  real ( kind = 8 ) ratio
+  logical sing
+  real ( kind = 8 ) sum2
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) wa1(n)
+  real ( kind = 8 ) wa2(n)
+  real ( kind = 8 ) wa3(n)
+  real ( kind = 8 ) wa4(n)
+  real ( kind = 8 ) x(n)
+  real ( kind = 8 ) xnorm
+  real ( kind = 8 ) xtol
+  real ( kind = 8 ) pars(m)
+
+  epsmch = epsilon ( epsmch )
+
+  info = 0
+  iflag = 0
+  nfev = 0
+!
+!  Check the input parameters for errors.
+!
+  if ( n <= 0 ) then
+    return
+  else if ( xtol < 0.0D+00 ) then
+    return
+  else if ( maxfev <= 0 ) then
+    return
+  else if ( ml < 0 ) then
+    return
+  else if ( mu < 0 ) then
+    return
+  else if ( factor <= 0.0D+00 ) then
+    return
+  else if ( ldfjac < n ) then
+    return
+  else if ( lr < ( n * (n + 1) ) / 2 ) then
+    return
+  end if
+
+  if ( mode == 2 ) then
+
+    do j = 1, n
+      if ( diag(j) <= 0.0D+00 ) then
+        go to 300
+      end if
+    end do
+
+  end if
+!
+!  Evaluate the function at the starting point
+!  and calculate its norm.
+!
+  iflag = 1
+  call fcn ( n, x, m, pars, fvec, iflag )
+  nfev = 1
+
+  if ( iflag < 0 ) then
+    go to 300
+  end if
+
+  fnorm = enorm ( n, fvec )
+!
+!  Determine the number of calls to FCN needed to compute the jacobian matrix.
+!
+  msum = min ( ml+mu+1, n )
+!
+!  Initialize iteration counter and monitors.
+!
+  iter = 1
+  ncsuc = 0
+  ncfail = 0
+  nslow1 = 0
+  nslow2 = 0
+!
+!  Beginning of the outer loop.
+!
+30 continue
+
+     jeval = .true.
+!
+!  Calculate the jacobian matrix.
+!
+     iflag = 2
+     call fdjac1 ( fcn, n, x, m, pars, fvec, fjac, ldfjac, iflag, ml, mu, epsfcn )
+
+     nfev = nfev + msum
+     if ( iflag < 0 ) go to 300
+!
+!  Compute the QR factorization of the jacobian.
+!
+     call qrfac ( n, n, fjac, ldfjac, .false., iwa, 1, wa1, wa2 )
+!
+!  On the first iteration, if MODE is 1, scale according
+!  to the norms of the columns of the initial jacobian.
+!
+    if ( iter == 1 ) then
+
+      if ( mode /= 2 ) then
+
+        diag(1:n) = wa2(1:n)
+        do j = 1, n
+          if ( wa2(j) == 0.0D+00 ) then
+            diag(j) = 1.0D+00
+          end if
+        end do
+
+      end if
+!
+!  On the first iteration, calculate the norm of the scaled X
+!  and initialize the step bound DELTA.
+!
+      wa3(1:n) = diag(1:n) * x(1:n)
+      xnorm = enorm ( n, wa3 )
+      delta = factor * xnorm
+      if ( delta == 0.0D+00 ) then
+        delta = factor
+      end if
+
+    end if
+!
+!  Form Q' * FVEC and store in QTF.
+!
+     qtf(1:n) = fvec(1:n)
+
+     do j = 1, n
+
+       if ( fjac(j,j) /= 0.0D+00 ) then
+         temp = - dot_product ( qtf(j:n), fjac(j:n,j) ) / fjac(j,j)
+         qtf(j:n) = qtf(j:n) + fjac(j:n,j) * temp
+       end if
+
+     end do
+!
+!  Copy the triangular factor of the QR factorization into R.
+!
+     sing = .false.
+
+     do j = 1, n
+        l = j
+        do i = 1, j - 1
+          r(l) = fjac(i,j)
+          l = l + n - i
+        end do
+        r(l) = wa1(j)
+        if ( wa1(j) == 0.0D+00 ) then
+          sing = .true.
+        end if
+     end do
+!
+!  Accumulate the orthogonal factor in FJAC.
+!
+     call qform ( n, n, fjac, ldfjac )
+!
+!  Rescale if necessary.
+!
+     if ( mode /= 2 ) then
+       do j = 1, n
+         diag(j) = max ( diag(j), wa2(j) )
+       end do
+     end if
+!
+!  Beginning of the inner loop.
+!
+180    continue
+!
+!  If requested, call FCN to enable printing of iterates.
+!
+        if ( 0 < nprint ) then
+          iflag = 0
+          if ( mod ( iter-1, nprint ) == 0) then
+            call fcn ( n, x, m, pars, fvec, iflag )
+          end if
+          if ( iflag < 0 ) then
+            go to 300
+          end if
+        end if
+!
+!  Determine the direction P.
+!
+        call dogleg ( n, r, lr, diag, qtf, delta, wa1 )
+!
+!  Store the direction P and X + P.
+!  Calculate the norm of P.
+!
+        wa1(1:n) = - wa1(1:n)
+        wa2(1:n) = x(1:n) + wa1(1:n)
+        wa3(1:n) = diag(1:n) * wa1(1:n)
+
+        pnorm = enorm ( n, wa3 )
+!
+!  On the first iteration, adjust the initial step bound.
+!
+        if ( iter == 1 ) then
+          delta = min ( delta, pnorm )
+        end if
+!
+!  Evaluate the function at X + P and calculate its norm.
+!
+        iflag = 1
+        call fcn ( n, wa2, m, pars, wa4, iflag )
+        nfev = nfev + 1
+
+        if ( iflag < 0 ) then
+          go to 300
+        end if
+
+        fnorm1 = enorm ( n, wa4 )
+!
+!  Compute the scaled actual reduction.
+!
+        actred = -1.0D+00
+        if ( fnorm1 < fnorm ) then
+          actred = 1.0D+00 - ( fnorm1 / fnorm )**2
+        endif
+!
+!  Compute the scaled predicted reduction.
+!
+        l = 1
+        do i = 1, n
+          sum2 = 0.0D+00
+          do j = i, n
+            sum2 = sum2 + r(l) * wa1(j)
+            l = l + 1
+          end do
+          wa3(i) = qtf(i) + sum2
+        end do
+
+        temp = enorm ( n, wa3 )
+        prered = 0.0D+00
+        if ( temp < fnorm ) then
+          prered = 1.0D+00 - ( temp / fnorm )**2
+        end if
+!
+!  Compute the ratio of the actual to the predicted reduction.
+!
+        ratio = 0.0D+00
+        if ( 0.0D+00 < prered ) then
+          ratio = actred / prered
+        end if
+!
+!  Update the step bound.
+!
+        if ( ratio < 0.1D+00 ) then
+
+          ncsuc = 0
+          ncfail = ncfail + 1
+          delta = 0.5D+00 * delta
+
+        else
+
+          ncfail = 0
+          ncsuc = ncsuc + 1
+
+          if ( 0.5D+00 <= ratio .or. 1 < ncsuc ) then
+            delta = max ( delta, pnorm / 0.5D+00 )
+          end if
+
+          if ( abs ( ratio - 1.0D+00 ) <= 0.1D+00 ) then
+            delta = pnorm / 0.5D+00
+          end if
+
+        end if
+!
+!  Test for successful iteration.
+!
+!  Successful iteration.
+!  Update X, FVEC, and their norms.
+!
+        if ( 0.0001D+00 <= ratio ) then
+          x(1:n) = wa2(1:n)
+          wa2(1:n) = diag(1:n) * x(1:n)
+          fvec(1:n) = wa4(1:n)
+          xnorm = enorm ( n, wa2 )
+          fnorm = fnorm1
+          iter = iter + 1
+        end if
+!
+!  Determine the progress of the iteration.
+!
+        nslow1 = nslow1 + 1
+        if ( 0.001D+00 <= actred ) then
+          nslow1 = 0
+        end if
+
+        if ( jeval ) then
+          nslow2 = nslow2 + 1
+        end if
+
+        if ( 0.1D+00 <= actred ) then
+          nslow2 = 0
+        end if
+!
+!  Test for convergence.
+!
+        if ( delta <= xtol * xnorm .or. fnorm == 0.0D+00 ) then
+          info = 1
+        end if
+
+        if ( info /= 0 ) then
+          go to 300
+        end if
+!
+!  Tests for termination and stringent tolerances.
+!
+        if ( maxfev <= nfev ) then
+          info = 2
+        end if
+
+        if ( 0.1D+00 * max ( 0.1D+00 * delta, pnorm ) <= epsmch * xnorm ) then
+          info = 3
+        end if
+
+        if ( nslow2 == 5 ) then
+          info = 4
+        end if
+
+        if ( nslow1 == 10 ) then
+          info = 5
+        end if
+
+        if ( info /= 0 ) then
+          go to 300
+        end if
+!
+!  Criterion for recalculating jacobian approximation
+!  by forward differences.
+!
+        if ( ncfail == 2 ) then
+          go to 290
+        end if
+!
+!  Calculate the rank one modification to the jacobian
+!  and update QTF if necessary.
+!
+        do j = 1, n
+          sum2 = dot_product ( wa4(1:n), fjac(1:n,j) )
+          wa2(j) = ( sum2 - wa3(j) ) / pnorm
+          wa1(j) = diag(j) * ( ( diag(j) * wa1(j) ) / pnorm )
+          if ( 0.0001D+00 <= ratio ) then
+            qtf(j) = sum2
+          end if
+        end do
+!
+!  Compute the QR factorization of the updated jacobian.
+!
+        call r1updt ( n, n, r, lr, wa1, wa2, wa3, sing )
+        call r1mpyq ( n, n, fjac, ldfjac, wa2, wa3 )
+        call r1mpyq ( 1, n, qtf, 1, wa2, wa3 )
+!
+!  End of the inner loop.
+!
+        jeval = .false.
+        go to 180
+
+  290   continue
+!
+!  End of the outer loop.
+!
+     go to 30
+
+  300 continue
+!
+!  Termination, either normal or user imposed.
+!
+  if ( iflag < 0 ) then
+    info = iflag
+  end if
+
+  iflag = 0
+
+  if ( 0 < nprint ) then
+    call fcn ( n, x, m, pars, fvec, iflag )
+  end if
+
+  return
+end subroutine hybrd
+subroutine hybrd1 ( fcn, n, x, m, pars, fvec, tol, info )
+
+!*****************************************************************************80
+!
+!! HYBRD1 seeks a zero of N nonlinear equations in N variables.
+!
+!  Discussion:
+!
+!    HYBRD1 finds a zero of a system of N nonlinear functions in N variables
+!    by a modification of the Powell hybrid method.  This is done by using the
+!    more general nonlinear equation solver HYBRD.  The user must provide a
+!    subroutine which calculates the functions.  The jacobian is then
+!    calculated by a forward-difference approximation.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, external FCN, the name of the user-supplied subroutine which
+!    calculates the functions.  The routine should have the form:
+!
+!      subroutine fcn ( n, x, fvec, iflag )
+!      integer ( kind = 4 ) n
+!      real fvec(n)
+!      integer ( kind = 4 ) iflag
+!      real x(n)
+!
+!    The value of IFLAG should not be changed by FCN unless
+!    the user wants to terminate execution of the routine.
+!    In this case set IFLAG to a negative integer.
+!
+!    Input, integer ( kind = 4 ) N, the number of functions and variables.
+!
+!    Input/output, real ( kind = 8 ) X(N).  On input, X must contain an initial
+!    estimate of the solution vector.  On output X contains the final
+!    estimate of the solution vector.
+!
+!    Output, real ( kind = 8 ) FVEC(N), the functions evaluated at the output X.
+!
+!    Input, real ( kind = 8 ) TOL.  Termination occurs when the algorithm
+!    estimates that the relative error between X and the solution is at
+!    most TOL.  TOL should be nonnegative.
+!
+!    Output, integer ( kind = 4 ) INFO, error flag.  If the user has terminated
+!    execution, INFO is set to the (negative) value of IFLAG. See the
+!    description of FCN.
+!    Otherwise, INFO is set as follows:
+!    0, improper input parameters.
+!    1, algorithm estimates that the relative error between X and the
+!       solution is at most TOL.
+!    2, number of calls to FCN has reached or exceeded 200*(N+1).
+!    3, TOL is too small.  No further improvement in the approximate
+!       solution X is possible.
+!    4, the iteration is not making good progress.
+!
+  implicit none
+
+  integer ( kind = 4 ) lwa
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) m
+
+  real ( kind = 8 ) diag(n)
+  real ( kind = 8 ) epsfcn
+  real ( kind = 8 ) factor
+  external fcn
+  real ( kind = 8 ) fjac(n,n)
+  real ( kind = 8 ) fvec(n)
+  integer ( kind = 4 ) info
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) ldfjac
+  integer ( kind = 4 ) lr
+  integer ( kind = 4 ) maxfev
+  integer ( kind = 4 ) ml
+  integer ( kind = 4 ) mode
+  integer ( kind = 4 ) mu
+  integer ( kind = 4 ) nfev
+  integer ( kind = 4 ) nprint
+  real ( kind = 8 ) qtf(n)
+  real ( kind = 8 ) r((n*(n+1))/2)
+  real ( kind = 8 ) tol
+  real ( kind = 8 ) x(n)
+  real ( kind = 8 ) xtol
+  real ( kind = 8 ) pars(m)
+
+  info = 0
+
+  if ( n <= 0 ) then
+    return
+  else if ( tol < 0.0D+00 ) then
+    return
+  end if
+
+  maxfev = 200 * ( n + 1 )
+  xtol = tol
+  ml = n - 1
+  mu = n - 1
+  epsfcn = 0.0D+00
+  mode = 2
+  diag(1:n) = 1.0D+00
+  nprint = 0
+  lr = ( n * ( n + 1 ) ) / 2
+  factor = 100.0D+00
+  ldfjac = n
+
+  call hybrd ( fcn, n, x, m, pars, fvec, xtol, maxfev, ml, mu, epsfcn, diag, mode, &
+    factor, nprint, info, nfev, fjac, ldfjac, r, lr, qtf )
+
+  if ( info == 5 ) then
+    info = 4
+  end if
+
+  return
+end subroutine hybrd1
+subroutine hybrj ( fcn, n, x, fvec, fjac, ldfjac, xtol, maxfev, diag, mode, &
+  factor, nprint, info, nfev, njev, r, lr, qtf )
+
+!*****************************************************************************80
+!
+!! HYBRJ seeks a zero of N nonlinear equations in N variables.
+!
+!  Discussion:
+!
+!    HYBRJ finds a zero of a system of N nonlinear functions in N variables
+!    by a modification of the Powell hybrid method.  The user must provide a
+!    subroutine which calculates the functions and the jacobian.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, external FCN, the name of the user-supplied subroutine which
+!    calculates the functions and the jacobian.  FCN should have the form:
+!
+!      subroutine fcn ( n, x, fvec, fjac, ldfjac, iflag )
+!      integer ( kind = 4 ) ldfjac
+!      integer ( kind = 4 ) n
+!      real fjac(ldfjac,n)
+!      real fvec(n)
+!      integer ( kind = 4 ) iflag
+!      real x(n)
+!
+!    If IFLAG = 1 on intput, FCN should calculate the functions at X and
+!    return this vector in FVEC.
+!    If IFLAG = 2 on input, FCN should calculate the jacobian at X and
+!    return this matrix in FJAC.
+!    To terminate the algorithm, the user may set IFLAG negative.
+!
+!    Input, integer ( kind = 4 ) N, the number of functions and variables.
+!
+!    Input/output, real ( kind = 8 ) X(N).  On input, X must contain an initial
+!    estimate of the solution vector.  On output X contains the final
+!    estimate of the solution vector.
+!
+!    Output, real ( kind = 8 ) FVEC(N), the functions evaluated at the output X.
+!
+!    Output, real ( kind = 8 ) FJAC(LDFJAC,N), an N by N matrix, containing
+!    the orthogonal matrix Q produced by the QR factorization
+!    of the final approximate jacobian.
+!
+!    Input, integer ( kind = 4 ) LDFJAC, the leading dimension of the
+!    array FJAC.  LDFJAC must be at least N.
+!
+!    Input, real ( kind = 8 ) XTOL.  Termination occurs when the relative error
+!    between two consecutive iterates is at most XTOL.  XTOL should be
+!    nonnegative.
+!
+!    Input, integer ( kind = 4 ) MAXFEV.  Termination occurs when the number of
+!    calls to FCN is at least MAXFEV by the end of an iteration.
+!
+!    Input/output, real ( kind = 8 ) DIAG(N).  If MODE = 1, then DIAG is set
+!    internally.  If MODE = 2, then DIAG must contain positive entries that
+!    serve as multiplicative scale factors for the variables.
+!
+!    Input, integer ( kind = 4 ) MODE, scaling option.
+!    1, variables will be scaled internally.
+!    2, scaling is specified by the input DIAG vector.
+!
+!    Input, real ( kind = 8 ) FACTOR, determines the initial step bound.  This
+!    bound is set to the product of FACTOR and the euclidean norm of DIAG*X if
+!    nonzero, or else to FACTOR itself.  In most cases, FACTOR should lie
+!    in the interval (0.1, 100) with 100 the recommended value.
+!
+!    Input, integer ( kind = 4 ) NPRINT, enables controlled printing of iterates
+!    if it is positive.  In this case, FCN is called with IFLAG = 0 at the
+!    beginning of the first iteration and every NPRINT iterations thereafter
+!    and immediately prior to return, with X and FVEC available
+!    for printing.  If NPRINT is not positive, no special calls
+!    of FCN with IFLAG = 0 are made.
+!
+!    Output, integer ( kind = 4 ) INFO, error flag.  If the user has terminated
+!    execution, INFO is set to the (negative) value of IFLAG.  
+!    See the description of FCN.  Otherwise, INFO is set as follows:
+!    0, improper input parameters.
+!    1, relative error between two consecutive iterates is at most XTOL.
+!    2, number of calls to FCN with IFLAG = 1 has reached MAXFEV.
+!    3, XTOL is too small.  No further improvement in
+!       the approximate solution X is possible.
+!    4, iteration is not making good progress, as measured by the
+!       improvement from the last five jacobian evaluations.
+!    5, iteration is not making good progress, as measured by the
+!       improvement from the last ten iterations.
+!
+!    Output, integer ( kind = 4 ) NFEV, the number of calls to FCN 
+!    with IFLAG = 1.
+!
+!    Output, integer ( kind = 4 ) NJEV, the number of calls to FCN 
+!    with IFLAG = 2.
+!
+!    Output, real ( kind = 8 ) R(LR), the upper triangular matrix produced
+!    by the QR factorization of the final approximate jacobian, stored rowwise.
+!
+!    Input, integer ( kind = 4 ) LR, the size of the R array, which must 
+!    be no less than (N*(N+1))/2.
+!
+!    Output, real ( kind = 8 ) QTF(N), contains the vector Q'*FVEC.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldfjac
+  integer ( kind = 4 ) lr
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) actred
+  real ( kind = 8 ) delta
+  real ( kind = 8 ) diag(n)
+  real ( kind = 8 ) enorm
+  real ( kind = 8 ) epsmch
+  real ( kind = 8 ) factor
+  external fcn
+  real ( kind = 8 ) fjac(ldfjac,n)
+  real ( kind = 8 ) fnorm
+  real ( kind = 8 ) fnorm1
+  real ( kind = 8 ) fvec(n)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) iflag
+  integer ( kind = 4 ) info
+  integer ( kind = 4 ) iter
+  integer ( kind = 4 ) iwa(1)
+  integer ( kind = 4 ) j
+  logical jeval
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) maxfev
+  integer ( kind = 4 ) mode
+  integer ( kind = 4 ) ncfail
+  integer ( kind = 4 ) nslow1
+  integer ( kind = 4 ) nslow2
+  integer ( kind = 4 ) ncsuc
+  integer ( kind = 4 ) nfev
+  integer ( kind = 4 ) njev
+  integer ( kind = 4 ) nprint
+  real ( kind = 8 ) pnorm
+  real ( kind = 8 ) prered
+  real ( kind = 8 ) qtf(n)
+  real ( kind = 8 ) r(lr)
+  real ( kind = 8 ) ratio
+  logical sing
+  real ( kind = 8 ) sum2
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) wa1(n)
+  real ( kind = 8 ) wa2(n)
+  real ( kind = 8 ) wa3(n)
+  real ( kind = 8 ) wa4(n)
+  real ( kind = 8 ) x(n)
+  real ( kind = 8 ) xnorm
+  real ( kind = 8 ) xtol
+
+  epsmch = epsilon ( epsmch )
+
+  info = 0
+  iflag = 0
+  nfev = 0
+  njev = 0
+!
+!  Check the input parameters for errors.
+!
+  if ( n <= 0 ) then
+    if ( iflag < 0 ) then
+      info = iflag
+    end if
+    iflag = 0
+    if ( 0 < nprint ) then
+      call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+    end if
+    return
+  end if
+
+  if ( ldfjac < n .or. &
+       xtol < 0.0D+00 .or. &
+       maxfev <= 0 .or. &
+       factor <= 0.0D+00 .or. &
+       lr < ( n * ( n + 1 ) ) / 2 ) then
+    if ( iflag < 0 ) then
+      info = iflag
+    end if
+    iflag = 0
+    if ( 0 < nprint ) then
+      call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+    end if
+    return
+  end if
+
+  if ( mode == 2 ) then
+    do j = 1, n
+      if ( diag(j) <= 0.0D+00 ) then
+        if ( iflag < 0 ) then
+          info = iflag
+        end if
+        iflag = 0
+        if ( 0 < nprint ) then
+          call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+        end if
+        return
+      end if
+    end do
+  end if
+!
+!  Evaluate the function at the starting point
+!  and calculate its norm.
+!
+  iflag = 1
+  call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+  nfev = 1
+
+  if ( iflag < 0 ) then
+    if ( iflag < 0 ) then
+      info = iflag
+    end if
+    iflag = 0
+    if ( 0 < nprint ) then
+      call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+    end if
+    return
+  end if
+
+  fnorm = enorm ( n, fvec )
+!
+!  Initialize iteration counter and monitors.
+!
+  iter = 1
+  ncsuc = 0
+  ncfail = 0
+  nslow1 = 0
+  nslow2 = 0
+!
+!  Beginning of the outer loop.
+!
+30 continue
+
+     jeval = .true.
+!
+!  Calculate the jacobian matrix.
+!
+     iflag = 2
+     call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+     njev = njev + 1
+     if ( iflag < 0 ) then
+       go to 300
+     end if
+!
+!  Compute the QR factorization of the jacobian.
+!
+     call qrfac ( n, n, fjac, ldfjac, .false., iwa, 1, wa1, wa2 )
+!
+!  On the first iteration, if MODE is 1, scale according
+!  to the norms of the columns of the initial jacobian.
+!
+     if ( iter == 1 ) then
+
+       if ( mode /= 2 ) then
+         diag(1:n) = wa2(1:n)
+         do j = 1, n
+           if ( wa2(j) == 0.0D+00 ) then
+             diag(j) = 1.0D+00
+           end if
+         end do
+       end if
+!
+!  On the first iteration, calculate the norm of the scaled X
+!  and initialize the step bound DELTA.
+!
+       wa3(1:n) = diag(1:n) * x(1:n)
+       xnorm = enorm ( n, wa3 )
+       delta = factor * xnorm
+       if ( delta == 0.0D+00 ) then
+         delta = factor
+       end if
+     end if
+!
+!  Form Q'*FVEC and store in QTF.
+!
+     qtf(1:n) = fvec(1:n)
+
+     do j = 1, n
+       if ( fjac(j,j) /= 0.0D+00 ) then
+         sum2 = 0.0D+00
+         do i = j, n
+           sum2 = sum2 + fjac(i,j) * qtf(i)
+         end do
+         temp = - sum2 / fjac(j,j)
+         do i = j, n
+           qtf(i) = qtf(i) + fjac(i,j) * temp
+         end do
+       end if
+     end do
+!
+!  Copy the triangular factor of the QR factorization into R.
+!
+     sing = .false.
+     do j = 1, n
+       l = j
+       do i = 1, j-1
+         r(l) = fjac(i,j)
+         l = l + n - i
+       end do
+       r(l) = wa1(j)
+       if ( wa1(j) == 0.0D+00 ) then
+         sing = .true.
+       end if
+     end do
+!
+!  Accumulate the orthogonal factor in FJAC.
+!
+     call qform ( n, n, fjac, ldfjac )
+!
+!  Rescale if necessary.
+!
+     if ( mode /= 2 ) then
+       do j = 1, n
+         diag(j) = max ( diag(j), wa2(j) )
+       end do
+     end if
+!
+!  Beginning of the inner loop.
+!
+  180    continue
+!
+!  If requested, call FCN to enable printing of iterates.
+!
+        if ( 0 < nprint ) then
+          iflag = 0
+          if ( mod ( iter-1, nprint ) == 0 ) then
+            call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+          end if
+          if ( iflag < 0 ) then
+            go to 300
+          end if
+        end if
+!
+!  Determine the direction P.
+!
+        call dogleg ( n, r, lr, diag, qtf, delta, wa1 )
+!
+!  Store the direction P and X + P.
+!  Calculate the norm of P.
+!
+        wa1(1:n) = - wa1(1:n)
+        wa2(1:n) = x(1:n) + wa1(1:n)
+        wa3(1:n) = diag(1:n) * wa1(1:n)
+        pnorm = enorm ( n, wa3 )
+!
+!  On the first iteration, adjust the initial step bound.
+!
+        if ( iter == 1 ) then
+          delta = min ( delta, pnorm )
+        end if
+!
+!  Evaluate the function at X + P and calculate its norm.
+!
+        iflag = 1
+        call fcn ( n, wa2, wa4, fjac, ldfjac, iflag )
+        nfev = nfev + 1
+        if ( iflag < 0 ) then
+          go to 300
+        end if
+        fnorm1 = enorm ( n, wa4 )
+!
+!  Compute the scaled actual reduction.
+!
+        actred = -1.0D+00
+        if ( fnorm1 < fnorm ) then
+          actred = 1.0D+00 - ( fnorm1 / fnorm )**2
+        end if
+!
+!  Compute the scaled predicted reduction.
+!
+        l = 1
+        do i = 1, n
+          sum2 = 0.0D+00
+          do j = i, n
+            sum2 = sum2 + r(l) * wa1(j)
+            l = l + 1
+          end do
+          wa3(i) = qtf(i) + sum2
+        end do
+
+        temp = enorm ( n, wa3 )
+        prered = 0.0D+00
+        if ( temp < fnorm ) then
+          prered = 1.0D+00 - ( temp / fnorm )**2
+        end if
+!
+!  Compute the ratio of the actual to the predicted reduction.
+!
+        if ( 0.0D+00 < prered ) then
+          ratio = actred / prered
+        else
+          ratio = 0.0D+00
+        end if
+!
+!  Update the step bound.
+!
+        if ( ratio < 0.1D+00 ) then
+          ncsuc = 0
+          ncfail = ncfail + 1
+          delta = 0.5D+00 * delta
+        else
+          ncfail = 0
+          ncsuc = ncsuc + 1
+
+          if ( 0.5D+00 <= ratio .or. 1 < ncsuc ) then
+            delta = max ( delta, pnorm / 0.5D+00 )
+          end if
+
+          if ( abs ( ratio - 1.0D+00 ) <= 0.1D+00 ) then
+            delta = pnorm / 0.5D+00
+          end if
+
+        end if
+!
+!  Test for successful iteration.
+!
+
+!
+!  Successful iteration.
+!  Update X, FVEC, and their norms.
+!
+        if ( 0.0001D+00 <= ratio ) then
+          x(1:n) = wa2(1:n)
+          wa2(1:n) = diag(1:n) * x(1:n)
+          fvec(1:n) = wa4(1:n)
+          xnorm = enorm ( n, wa2 )
+          fnorm = fnorm1
+          iter = iter + 1
+        end if
+!
+!  Determine the progress of the iteration.
+!
+        nslow1 = nslow1 + 1
+        if ( 0.001D+00 <= actred ) then
+          nslow1 = 0
+        end if
+
+        if ( jeval ) then
+          nslow2 = nslow2 + 1
+        end if
+
+        if ( 0.1D+00 <= actred ) then
+          nslow2 = 0
+        end if
+!
+!  Test for convergence.
+!
+        if ( delta <= xtol * xnorm .or. fnorm == 0.0D+00 ) then
+          info = 1
+        end if
+
+        if ( info /= 0 ) then
+          go to 300
+        end if
+!
+!  Tests for termination and stringent tolerances.
+!
+        if ( maxfev <= nfev ) then
+          info = 2
+        end if
+
+        if ( 0.1D+00 *max ( 0.1D+00 * delta, pnorm ) <= epsmch * xnorm ) then
+          info = 3
+        end if
+
+        if ( nslow2 == 5 ) then
+          info = 4
+        end if
+
+        if ( nslow1 == 10 ) then
+          info = 5
+        end if
+
+        if ( info /= 0 ) then
+          go to 300
+        end if
+!
+!  Criterion for recalculating jacobian.
+!
+        if ( ncfail == 2 ) then
+          go to 290
+        end if
+!
+!  Calculate the rank one modification to the jacobian
+!  and update QTF if necessary.
+!
+        do j = 1, n
+          sum2 = dot_product ( wa4(1:n), fjac(1:n,j) )
+          wa2(j) = ( sum2 - wa3(j) ) / pnorm
+          wa1(j) = diag(j) * ( ( diag(j) * wa1(j) ) / pnorm )
+          if ( 0.0001D+00 <= ratio ) then
+            qtf(j) = sum2
+          end if
+        end do
+!
+!  Compute the QR factorization of the updated jacobian.
+!
+        call r1updt ( n, n, r, lr, wa1, wa2, wa3, sing )
+        call r1mpyq ( n, n, fjac, ldfjac, wa2, wa3 )
+        call r1mpyq ( 1, n, qtf, 1, wa2, wa3 )
+!
+!  End of the inner loop.
+!
+        jeval = .false.
+        go to 180
+
+290     continue
+!
+!  End of the outer loop.
+!
+     go to 30
+
+  300 continue
+!
+!  Termination, either normal or user imposed.
+!
+  if ( iflag < 0 ) then
+    info = iflag
+  end if
+
+  iflag = 0
+
+  if ( 0 < nprint ) then
+    call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+  end if
+
+  return
+end subroutine hybrj
+subroutine hybrj1 ( fcn, n, x, fvec, fjac, ldfjac, tol, info )
+
+!*****************************************************************************80
+!
+!! HYBRJ1 seeks a zero of N equations in N variables by Powell's method.
+!
+!  Discussion:
+!
+!    HYBRJ1 finds a zero of a system of N nonlinear functions in N variables
+!    by a modification of the Powell hybrid method.  This is done by using the
+!    more general nonlinear equation solver HYBRJ.  The user
+!    must provide a subroutine which calculates the functions
+!    and the jacobian.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, external FCN, the name of the user-supplied subroutine which
+!    calculates the functions and the jacobian.  FCN should have the form:
+!
+!      subroutine fcn ( n, x, fvec, fjac, ldfjac, iflag )
+!      integer ( kind = 4 ) ldfjac
+!      integer ( kind = 4 ) n
+!      real fjac(ldfjac,n)
+!      real fvec(n)
+!      integer ( kind = 4 ) iflag
+!      real x(n)
+!
+!    If IFLAG = 1 on intput, FCN should calculate the functions at X and
+!    return this vector in FVEC.
+!    If IFLAG = 2 on input, FCN should calculate the jacobian at X and
+!    return this matrix in FJAC.
+!    To terminate the algorithm, the user may set IFLAG negative.
+!
+!    Input, integer ( kind = 4 ) N, the number of functions and variables.
+!
+!    Input/output, real ( kind = 8 ) X(N).  On input, X must contain an initial
+!    estimate of the solution vector.  On output X contains the final
+!    estimate of the solution vector.
+!
+!    Output, real ( kind = 8 ) FVEC(N), the functions evaluated at the output X.
+!
+!    Output, real ( kind = 8 ) FJAC(LDFJAC,N), an N by N array which contains
+!    the orthogonal matrix Q produced by the QR factorization of the final
+!    approximate jacobian.
+!
+!    Input, integer ( kind = 4 ) LDFJAC, the leading dimension of  FJAC.
+!    LDFJAC must be at least N.
+!
+!    Input, real ( kind = 8 ) TOL.  Termination occurs when the algorithm
+!    estimates that the relative error between X and the solution is at most
+!    TOL.  TOL should be nonnegative.
+!
+!    Output, integer ( kind = 4 ) INFO, error flag.  If the user has terminated
+!    execution, INFO is set to the (negative) value of IFLAG. See description
+!    of FCN.  Otherwise, INFO is set as follows:
+!    0, improper input parameters.
+!    1, algorithm estimates that the relative error between X and the
+!       solution is at most TOL.
+!    2, number of calls to FCN with IFLAG = 1 has reached 100*(N+1).
+!    3, TOL is too small.  No further improvement in the approximate
+!       solution X is possible.
+!    4, iteration is not making good progress.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldfjac
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) diag(n)
+  real ( kind = 8 ) factor
+  external fcn
+  real ( kind = 8 ) fjac(ldfjac,n)
+  real ( kind = 8 ) fvec(n)
+  integer ( kind = 4 ) info
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) lr
+  integer ( kind = 4 ) maxfev
+  integer ( kind = 4 ) mode
+  integer ( kind = 4 ) nfev
+  integer ( kind = 4 ) njev
+  integer ( kind = 4 ) nprint
+  real ( kind = 8 ) qtf(n)
+  real ( kind = 8 ) r((n*(n+1))/2)
+  real ( kind = 8 ) tol
+  real ( kind = 8 ) x(n)
+  real ( kind = 8 ) xtol
+
+  info = 0
+
+  if ( n <= 0 ) then
+    return
+  else if ( ldfjac < n ) then
+    return
+  else if ( tol < 0.0D+00 ) then
+    return
+  end if
+
+  maxfev = 100 * ( n + 1 )
+  xtol = tol
+  mode = 2
+  diag(1:n) = 1.0D+00
+  factor = 100.0D+00
+  nprint = 0
+  lr = ( n * ( n + 1 ) ) / 2
+
+  call hybrj ( fcn, n, x, fvec, fjac, ldfjac, xtol, maxfev, diag, mode, &
+    factor, nprint, info, nfev, njev, r, lr, qtf )
+
+  if ( info == 5 ) then
+    info = 4
+  end if
+
+  return
+end subroutine hybrj1
+subroutine lmder ( fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, &
+  diag, mode, factor, nprint, info, nfev, njev, ipvt, qtf )
+
+!*****************************************************************************80
+!
+!! LMDER minimizes M functions in N variables by the Levenberg-Marquardt method.
+!
+!  Discussion:
+!
+!    LMDER minimizes the sum of the squares of M nonlinear functions in
+!    N variables by a modification of the Levenberg-Marquardt algorithm.
+!    The user must provide a subroutine which calculates the functions
+!    and the jacobian.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, external FCN, the name of the user-supplied subroutine which
+!    calculates the functions and the jacobian.  FCN should have the form:
+!
+!      subroutine fcn ( m, n, x, fvec, fjac, ldfjac, iflag )
+!      integer ( kind = 4 ) ldfjac
+!      integer ( kind = 4 ) n
+!      real fjac(ldfjac,n)
+!      real fvec(m)
+!      integer ( kind = 4 ) iflag
+!      real x(n)
+!
+!    If IFLAG = 1 on intput, FCN should calculate the functions at X and
+!    return this vector in FVEC.
+!    If IFLAG = 2 on input, FCN should calculate the jacobian at X and
+!    return this matrix in FJAC.
+!    To terminate the algorithm, the user may set IFLAG negative.
+!
+!    Input, integer ( kind = 4 ) M, is the number of functions.
+!
+!    Input, integer ( kind = 4 ) N, is the number of variables.  
+!    N must not exceed M.
+!
+!    Input/output, real ( kind = 8 ) X(N).  On input, X must contain an initial
+!    estimate of the solution vector.  On output X contains the final
+!    estimate of the solution vector.
+!
+!    Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X.
+!
+!    Output, real ( kind = 8 ) FJAC(LDFJAC,N), an M by N array.  The upper
+!    N by N submatrix of FJAC contains an upper triangular matrix R with
+!    diagonal elements of nonincreasing magnitude such that
+!      P' * ( JAC' * JAC ) * P = R' * R,
+!    where P is a permutation matrix and JAC is the final calculated jacobian.
+!    Column J of P is column IPVT(J) of the identity matrix.  The lower
+!    trapezoidal part of FJAC contains information generated during
+!    the computation of R.
+!
+!    Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC.
+!    LDFJAC must be at least M.
+!
+!    Input, real ( kind = 8 ) FTOL.  Termination occurs when both the actual
+!    and predicted relative reductions in the sum of squares are at most FTOL.
+!    Therefore, FTOL measures the relative error desired in the sum of
+!    squares.  FTOL should be nonnegative.
+!
+!    Input, real ( kind = 8 ) XTOL.  Termination occurs when the relative error
+!    between two consecutive iterates is at most XTOL.  XTOL should be
+!    nonnegative.
+!
+!    Input, real ( kind = 8 ) GTOL.  Termination occurs when the cosine of the
+!    angle between FVEC and any column of the jacobian is at most GTOL in
+!    absolute value.  Therefore, GTOL measures the orthogonality desired
+!    between the function vector and the columns of the jacobian.  GTOL should
+!    be nonnegative.
+!
+!    Input, integer ( kind = 4 ) MAXFEV.  Termination occurs when the number of
+!    calls to FCN with IFLAG = 1 is at least MAXFEV by the end of an iteration.
+!
+!    Input/output, real ( kind = 8 ) DIAG(N).  If MODE = 1, then DIAG is set
+!    internally.  If MODE = 2, then DIAG must contain positive entries that
+!    serve as multiplicative scale factors for the variables.
+!
+!    Input, integer ( kind = 4 ) MODE, scaling option.
+!    1, variables will be scaled internally.
+!    2, scaling is specified by the input DIAG vector.
+!
+!    Input, real ( kind = 8 ) FACTOR, determines the initial step bound.  This
+!    bound is set to the product of FACTOR and the euclidean norm of DIAG*X if
+!    nonzero, or else to FACTOR itself.  In most cases, FACTOR should lie
+!    in the interval (0.1, 100) with 100 the recommended value.
+!
+!    Input, integer ( kind = 4 ) NPRINT, enables controlled printing of iterates
+!    if it is positive.  In this case, FCN is called with IFLAG = 0 at the
+!    beginning of the first iteration and every NPRINT iterations thereafter
+!    and immediately prior to return, with X and FVEC available
+!    for printing.  If NPRINT is not positive, no special calls
+!    of FCN with IFLAG = 0 are made.
+!
+!    Output, integer ( kind = 4 ) INFO, error flag.  If the user has terminated
+!    execution, INFO is set to the (negative) value of IFLAG. See description
+!    of FCN.  Otherwise, INFO is set as follows:
+!    0, improper input parameters.
+!    1, both actual and predicted relative reductions in the sum of
+!       squares are at most FTOL.
+!    2, relative error between two consecutive iterates is at most XTOL.
+!    3, conditions for INFO = 1 and INFO = 2 both hold.
+!    4, the cosine of the angle between FVEC and any column of the jacobian
+!       is at most GTOL in absolute value.
+!    5, number of calls to FCN with IFLAG = 1 has reached MAXFEV.
+!    6, FTOL is too small.  No further reduction in the sum of squares
+!       is possible.
+!    7, XTOL is too small.  No further improvement in the approximate
+!       solution X is possible.
+!    8, GTOL is too small.  FVEC is orthogonal to the columns of the
+!       jacobian to machine precision.
+!
+!    Output, integer ( kind = 4 ) NFEV, the number of calls to FCN with
+!    IFLAG = 1.
+!
+!    Output, integer ( kind = 4 ) NJEV, the number of calls to FCN with
+!    IFLAG = 2.
+!
+!    Output, integer ( kind = 4 ) IPVT(N), defines a permutation matrix P
+!    such that JAC*P = Q*R, where JAC is the final calculated jacobian, Q is
+!    orthogonal (not stored), and R is upper triangular with diagonal
+!    elements of nonincreasing magnitude.  Column J of P is column
+!    IPVT(J) of the identity matrix.
+!
+!    Output, real ( kind = 8 ) QTF(N), contains the first N elements of Q'*FVEC.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldfjac
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) actred
+  real ( kind = 8 ) delta
+  real ( kind = 8 ) diag(n)
+  real ( kind = 8 ) dirder
+  real ( kind = 8 ) enorm
+  real ( kind = 8 ) epsmch
+  real ( kind = 8 ) factor
+  external fcn
+  real ( kind = 8 ) fjac(ldfjac,n)
+  real ( kind = 8 ) fnorm
+  real ( kind = 8 ) fnorm1
+  real ( kind = 8 ) ftol
+  real ( kind = 8 ) fvec(m)
+  real ( kind = 8 ) gnorm
+  real ( kind = 8 ) gtol
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) iflag
+  integer ( kind = 4 ) info
+  integer ( kind = 4 ) ipvt(n)
+  integer ( kind = 4 ) iter
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) maxfev
+  integer ( kind = 4 ) mode
+  integer ( kind = 4 ) nfev
+  integer ( kind = 4 ) njev
+  integer ( kind = 4 ) nprint
+  real ( kind = 8 ) par
+  real ( kind = 8 ) pnorm
+  real ( kind = 8 ) prered
+  real ( kind = 8 ) qtf(n)
+  real ( kind = 8 ) ratio
+  real ( kind = 8 ) sum2
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) temp1
+  real ( kind = 8 ) temp2
+  real ( kind = 8 ) wa1(n)
+  real ( kind = 8 ) wa2(n)
+  real ( kind = 8 ) wa3(n)
+  real ( kind = 8 ) wa4(m)
+  real ( kind = 8 ) xnorm
+  real ( kind = 8 ) x(n)
+  real ( kind = 8 ) xtol
+
+  epsmch = epsilon ( epsmch )
+
+  info = 0
+  iflag = 0
+  nfev = 0
+  njev = 0
+!
+!  Check the input parameters for errors.
+!
+  if ( n <= 0 ) then
+    go to 300
+  end if
+
+  if ( m < n ) then
+    go to 300
+  end if
+
+  if ( ldfjac < m &
+    .or. ftol < 0.0D+00 .or. xtol < 0.0D+00 .or. gtol < 0.0D+00 &
+     .or. maxfev <= 0 .or. factor <= 0.0D+00 ) then
+    go to 300
+  end if
+
+  if ( mode == 2 ) then
+    do j = 1, n
+      if ( diag(j) <= 0.0D+00 ) then
+        go to 300
+      end if
+    end do
+  end if
+!
+!  Evaluate the function at the starting point and calculate its norm.
+!
+  iflag = 1
+  call fcn ( m, n, x, fvec, fjac, ldfjac, iflag )
+  nfev = 1
+  if ( iflag < 0 ) then
+    go to 300
+  end if
+
+  fnorm = enorm ( m, fvec )
+!
+!  Initialize Levenberg-Marquardt parameter and iteration counter.
+!
+  par = 0.0D+00
+  iter = 1
+!
+!  Beginning of the outer loop.
+!
+30   continue
+!
+!  Calculate the jacobian matrix.
+!
+    iflag = 2
+    call fcn ( m, n, x, fvec, fjac, ldfjac, iflag )
+
+    njev = njev + 1
+
+    if ( iflag < 0 ) then
+      go to 300
+    end if
+!
+!  If requested, call FCN to enable printing of iterates.
+!
+    if ( 0 < nprint ) then
+      iflag = 0
+      if ( mod ( iter-1, nprint ) == 0 ) then
+        call fcn ( m, n, x, fvec, fjac, ldfjac, iflag )
+      end if
+      if ( iflag < 0 ) then
+        go to 300
+      end if
+    end if
+!
+!  Compute the QR factorization of the jacobian.
+!
+    call qrfac ( m, n, fjac, ldfjac, .true., ipvt, n, wa1, wa2 )
+!
+!  On the first iteration and if mode is 1, scale according
+!  to the norms of the columns of the initial jacobian.
+!
+    if ( iter == 1 ) then
+
+      if ( mode /= 2 ) then
+        diag(1:n) = wa2(1:n)
+        do j = 1, n
+          if ( wa2(j) == 0.0D+00 ) then
+            diag(j) = 1.0D+00
+          end if
+        end do
+      end if
+!
+!  On the first iteration, calculate the norm of the scaled X
+!  and initialize the step bound DELTA.
+!
+      wa3(1:n) = diag(1:n) * x(1:n)
+
+      xnorm = enorm ( n, wa3 )
+      delta = factor * xnorm
+      if ( delta == 0.0D+00 ) then
+        delta = factor
+      end if
+    end if
+!
+!  Form Q'*FVEC and store the first N components in QTF.
+!
+    wa4(1:m) = fvec(1:m)
+
+    do j = 1, n
+
+      if ( fjac(j,j) /= 0.0D+00 ) then
+        sum2 = dot_product ( wa4(j:m), fjac(j:m,j) )
+        temp = - sum2 / fjac(j,j)
+        wa4(j:m) = wa4(j:m) + fjac(j:m,j) * temp
+      end if
+
+      fjac(j,j) = wa1(j)
+      qtf(j) = wa4(j)
+
+    end do
+!
+!  Compute the norm of the scaled gradient.
+!
+    gnorm = 0.0D+00
+
+    if ( fnorm /= 0.0D+00 ) then
+
+      do j = 1, n
+        l = ipvt(j)
+        if ( wa2(l) /= 0.0D+00 ) then
+          sum2 = dot_product ( qtf(1:j), fjac(1:j,j) ) / fnorm
+          gnorm = max ( gnorm, abs ( sum2 / wa2(l) ) )
+        end if
+      end do
+
+    end if
+!
+!  Test for convergence of the gradient norm.
+!
+    if ( gnorm <= gtol ) then
+      info = 4
+      go to 300
+    end if
+!
+!  Rescale if necessary.
+!
+    if ( mode /= 2 ) then
+      do j = 1, n
+        diag(j) = max ( diag(j), wa2(j) )
+      end do
+    end if
+!
+!  Beginning of the inner loop.
+!
+200    continue
+!
+!  Determine the Levenberg-Marquardt parameter.
+!
+    call lmpar ( n, fjac, ldfjac, ipvt, diag, qtf, delta, par, wa1, wa2 )
+!
+!  Store the direction p and x + p. calculate the norm of p.
+!
+    wa1(1:n) = - wa1(1:n)
+    wa2(1:n) = x(1:n) + wa1(1:n)
+    wa3(1:n) = diag(1:n) * wa1(1:n)
+
+    pnorm = enorm ( n, wa3 )
+!
+!  On the first iteration, adjust the initial step bound.
+!
+    if ( iter == 1 ) then
+      delta = min ( delta, pnorm )
+    end if
+!
+!  Evaluate the function at x + p and calculate its norm.
+!
+    iflag = 1
+    call fcn ( m, n, wa2, wa4, fjac, ldfjac, iflag )
+
+    nfev = nfev + 1
+
+    if ( iflag < 0 ) then
+      go to 300
+    end if
+
+    fnorm1 = enorm ( m, wa4 )
+!
+!  Compute the scaled actual reduction.
+!
+    actred = -1.0D+00
+    if ( 0.1D+00 * fnorm1 < fnorm ) then
+      actred = 1.0D+00 - ( fnorm1 / fnorm )**2
+    end if
+!
+!  Compute the scaled predicted reduction and
+!  the scaled directional derivative.
+!
+    do j = 1, n
+      wa3(j) = 0.0D+00
+      l = ipvt(j)
+      temp = wa1(l)
+      wa3(1:j) = wa3(1:j) + fjac(1:j,j) * temp
+    end do
+
+    temp1 = enorm ( n, wa3 ) / fnorm
+    temp2 = ( sqrt ( par ) * pnorm ) / fnorm
+    prered = temp1**2 + temp2**2 / 0.5D+00
+    dirder = - ( temp1**2 + temp2**2 )
+!
+!  Compute the ratio of the actual to the predicted reduction.
+!
+    if ( prered /= 0.0D+00 ) then
+      ratio = actred / prered
+    else
+      ratio = 0.0D+00
+    end if
+!
+!  Update the step bound.
+!
+    if ( ratio <= 0.25D+00 ) then
+
+      if ( 0.0D+00 <= actred ) then
+        temp = 0.5D+00
+      end if
+
+      if ( actred < 0.0D+00 ) then
+        temp = 0.5D+00 * dirder / ( dirder + 0.5D+00 * actred )
+      end if
+
+      if ( 0.1D+00 * fnorm1 >= fnorm .or. temp < 0.1D+00 ) then
+        temp = 0.1D+00
+      end if
+
+      delta = temp * min ( delta, pnorm / 0.1D+00 )
+      par = par / temp
+
+    else
+
+      if ( par == 0.0D+00 .or. ratio >= 0.75D+00 ) then
+        delta = 2.0D+00 * pnorm
+        par = 0.5D+00 * par
+      end if
+
+    end if
+!
+!  Successful iteration.
+!
+!  Update X, FVEC, and their norms.
+!
+    if ( ratio >= 0.0001D+00 ) then
+      x(1:n) = wa2(1:n)
+      wa2(1:n) = diag(1:n) * x(1:n)
+      fvec(1:m) = wa4(1:m)
+      xnorm = enorm ( n, wa2 )
+      fnorm = fnorm1
+      iter = iter + 1
+    end if
+!
+!  Tests for convergence.
+!
+    if ( abs ( actred) <= ftol .and. &
+      prered <= ftol .and. &
+      0.5D+00 * ratio <= 1.0D+00 ) then
+      info = 1
+    end if
+
+    if ( delta <= xtol * xnorm ) then
+      info = 2
+    end if
+
+    if ( abs ( actred) <= ftol .and. prered <= ftol &
+      .and. 0.5D+00 * ratio <= 1.0D+00 .and. info == 2 ) then
+      info = 3
+    end if
+
+    if ( info /= 0 ) then
+      go to 300
+    end if
+!
+!  Tests for termination and stringent tolerances.
+!
+    if ( nfev >= maxfev ) then
+      info = 5
+    end if
+
+    if ( abs ( actred ) <= epsmch .and. prered <= epsmch &
+      .and. 0.5D+00 * ratio <= 1.0D+00 ) then
+      info = 6
+    end if
+
+    if ( delta <= epsmch * xnorm ) then
+      info = 7
+    end if
+
+    if ( gnorm <= epsmch ) then
+      info = 8
+    end if
+
+    if ( info /= 0 ) then
+      go to 300
+    end if
+!
+!  End of the inner loop. repeat if iteration unsuccessful.
+!
+    if ( ratio < 0.0001D+00 ) then
+      go to 200
+    end if
+!
+!  End of the outer loop.
+!
+    go to 30
+
+  300 continue
+!
+!  Termination, either normal or user imposed.
+!
+  if ( iflag < 0 ) then
+    info = iflag
+  end if
+
+  iflag = 0
+
+  if ( 0 < nprint ) then
+    call fcn ( m, n, x, fvec, fjac, ldfjac, iflag )
+  end if
+
+  return
+end subroutine lmder
+subroutine lmder1 ( fcn, m, n, x, fvec, fjac, ldfjac, tol, info )
+
+!*****************************************************************************80
+!
+!! LMDER1 minimizes M functions in N variables by Levenberg-Marquardt method.
+!
+!  Discussion:
+!
+!    LMDER1 minimizes the sum of the squares of M nonlinear functions in
+!    N variables by a modification of the Levenberg-Marquardt algorithm.
+!    This is done by using the more general least-squares solver LMDER.
+!    The user must provide a subroutine which calculates the functions
+!    and the jacobian.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, external FCN, the name of the user-supplied subroutine which
+!    calculates the functions and the jacobian.  FCN should have the form:
+!
+!      subroutine fcn ( m, n, x, fvec, fjac, ldfjac, iflag )
+!      integer ( kind = 4 ) ldfjac
+!      integer ( kind = 4 ) n
+!      real fjac(ldfjac,n)
+!      real fvec(m)
+!      integer ( kind = 4 ) iflag
+!      real x(n)
+!
+!    If IFLAG = 1 on intput, FCN should calculate the functions at X and
+!    return this vector in FVEC.
+!    If IFLAG = 2 on input, FCN should calculate the jacobian at X and
+!    return this matrix in FJAC.
+!    To terminate the algorithm, the user may set IFLAG negative.
+!
+!    Input, integer ( kind = 4 ) M, the number of functions.
+!
+!    Input, integer ( kind = 4 ) N, is the number of variables.  
+!    N must not exceed M.
+!
+!    Input/output, real ( kind = 8 ) X(N).  On input, X must contain an initial
+!    estimate of the solution vector.  On output X contains the final
+!    estimate of the solution vector.
+!
+!    Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X.
+!
+!    Output, real ( kind = 8 ) FJAC(LDFJAC,N), an M by N array.  The upper
+!    N by N submatrix contains an upper triangular matrix R with
+!    diagonal elements of nonincreasing magnitude such that
+!      P' * ( JAC' * JAC ) * P = R' * R,
+!    where P is a permutation matrix and JAC is the final calculated
+!    jacobian.  Column J of P is column IPVT(J) of the identity matrix.
+!    The lower trapezoidal part of FJAC contains information generated during
+!    the computation of R.
+!
+!    Input, integer ( kind = 4 ) LDFJAC, is the leading dimension of FJAC,
+!    which must be no less than M.
+!
+!    Input, real ( kind = 8 ) TOL.  Termination occurs when the algorithm
+!    estimates either that the relative error in the sum of squares is at
+!    most TOL or that the relative error between X and the solution is at
+!    most TOL.
+!
+!    Output, integer ( kind = 4 ) INFO, error flag.  If the user has terminated
+!    execution, INFO is set to the (negative) value of IFLAG. See description
+!    of FCN.  Otherwise, INFO is set as follows:
+!    0, improper input parameters.
+!    1, algorithm estimates that the relative error in the sum of squares
+!       is at most TOL.
+!    2, algorithm estimates that the relative error between X and the
+!       solution is at most TOL.
+!    3, conditions for INFO = 1 and INFO = 2 both hold.
+!    4, FVEC is orthogonal to the columns of the jacobian to machine precision.
+!    5, number of calls to FCN with IFLAG = 1 has reached 100*(N+1).
+!    6, TOL is too small.  No further reduction in the sum of squares is
+!       possible.
+!    7, TOL is too small.  No further improvement in the approximate
+!       solution X is possible.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldfjac
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) diag(n)
+  real ( kind = 8 ) factor
+  external fcn
+  real ( kind = 8 ) fjac(ldfjac,n)
+  real ( kind = 8 ) ftol
+  real ( kind = 8 ) fvec(m)
+  real ( kind = 8 ) gtol
+  integer ( kind = 4 ) info
+  integer ( kind = 4 ) ipvt(n)
+  integer ( kind = 4 ) maxfev
+  integer ( kind = 4 ) mode
+  integer ( kind = 4 ) nfev
+  integer ( kind = 4 ) njev
+  integer ( kind = 4 ) nprint
+  real ( kind = 8 ) qtf(n)
+  real ( kind = 8 ) tol
+  real ( kind = 8 ) x(n)
+  real ( kind = 8 ) xtol
+
+  info = 0
+
+  if ( n <= 0 ) then
+    return
+  else if ( m < n ) then
+    return
+  else if ( ldfjac < m ) then
+    return
+  else if ( tol < 0.0D+00 ) then
+    return
+  end if
+
+  factor = 100.0D+00
+  maxfev = 100 * ( n + 1 )
+  ftol = tol
+  xtol = tol
+  gtol = 0.0D+00
+  mode = 1
+  nprint = 0
+
+  call lmder ( fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, &
+    diag, mode, factor, nprint, info, nfev, njev, ipvt, qtf )
+
+  if ( info == 8 ) then
+    info = 4
+  end if
+
+  return
+end subroutine lmder1
+subroutine lmdif ( fcn, m, n, x, fvec, ftol, xtol, gtol, maxfev, epsfcn, &
+  diag, mode, factor, nprint, info, nfev, fjac, ldfjac, ipvt, qtf )
+
+!*****************************************************************************80
+!
+!! LMDIF minimizes M functions in N variables by the Levenberg-Marquardt method.
+!
+!  Discussion:
+!
+!    LMDIF minimizes the sum of the squares of M nonlinear functions in
+!    N variables by a modification of the Levenberg-Marquardt algorithm.
+!    The user must provide a subroutine which calculates the functions.
+!    The jacobian is then calculated by a forward-difference approximation.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, external FCN, the name of the user-supplied subroutine which
+!    calculates the functions.  The routine should have the form:
+!
+!      subroutine fcn ( m, n, x, fvec, iflag )
+!      integer ( kind = 4 ) m
+!      integer ( kind = 4 ) n
+!
+!      real fvec(m)
+!      integer ( kind = 4 ) iflag
+!      real x(n)
+!
+!    The value of IFLAG should not be changed by FCN unless
+!    the user wants to terminate execution of the routine.
+!    In this case set IFLAG to a negative integer.
+!
+!    Input, integer ( kind = 4 ) M, the number of functions.
+!
+!    Input, integer ( kind = 4 ) N, the number of variables.  
+!    N must not exceed M.
+!
+!    Input/output, real ( kind = 8 ) X(N).  On input, X must contain an initial
+!    estimate of the solution vector.  On output X contains the final
+!    estimate of the solution vector.
+!
+!    Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X.
+!
+!    Input, real ( kind = 8 ) FTOL.  Termination occurs when both the actual
+!    and predicted relative reductions in the sum of squares are at most FTOL.
+!    Therefore, FTOL measures the relative error desired in the sum of
+!    squares.  FTOL should be nonnegative.
+!
+!    Input, real ( kind = 8 ) XTOL.  Termination occurs when the relative error
+!    between two consecutive iterates is at most XTOL.  Therefore, XTOL
+!    measures the relative error desired in the approximate solution.  XTOL
+!    should be nonnegative.
+!
+!    Input, real ( kind = 8 ) GTOL. termination occurs when the cosine of the
+!    angle between FVEC and any column of the jacobian is at most GTOL in
+!    absolute value.  Therefore, GTOL measures the orthogonality desired
+!    between the function vector and the columns of the jacobian.  GTOL should
+!    be nonnegative.
+!
+!    Input, integer ( kind = 4 ) MAXFEV.  Termination occurs when the number of
+!    calls to FCN is at least MAXFEV by the end of an iteration.
+!
+!    Input, real ( kind = 8 ) EPSFCN, is used in determining a suitable step 
+!    length for the forward-difference approximation.  This approximation 
+!    assumes that the relative errors in the functions are of the order of 
+!    EPSFCN.  If EPSFCN is less than the machine precision, it is assumed that
+!    the relative errors in the functions are of the order of the machine
+!    precision.
+!
+!    Input/output, real ( kind = 8 ) DIAG(N).  If MODE = 1, then DIAG is set
+!    internally.  If MODE = 2, then DIAG must contain positive entries that
+!    serve as multiplicative scale factors for the variables.
+!
+!    Input, integer ( kind = 4 ) MODE, scaling option.
+!    1, variables will be scaled internally.
+!    2, scaling is specified by the input DIAG vector.
+!
+!    Input, real ( kind = 8 ) FACTOR, determines the initial step bound.  
+!    This bound is set to the product of FACTOR and the euclidean norm of
+!    DIAG*X if nonzero, or else to FACTOR itself.  In most cases, FACTOR should 
+!    lie in the interval (0.1, 100) with 100 the recommended value.
+!
+!    Input, integer ( kind = 4 ) NPRINT, enables controlled printing of iterates
+!    if it is positive.  In this case, FCN is called with IFLAG = 0 at the
+!    beginning of the first iteration and every NPRINT iterations thereafter
+!    and immediately prior to return, with X and FVEC available
+!    for printing.  If NPRINT is not positive, no special calls
+!    of FCN with IFLAG = 0 are made.
+!
+!    Output, integer ( kind = 4 ) INFO, error flag.  If the user has terminated
+!    execution, INFO is set to the (negative) value of IFLAG. See description
+!    of FCN.  Otherwise, INFO is set as follows:
+!    0, improper input parameters.
+!    1, both actual and predicted relative reductions in the sum of squares
+!       are at most FTOL.
+!    2, relative error between two consecutive iterates is at most XTOL.
+!    3, conditions for INFO = 1 and INFO = 2 both hold.
+!    4, the cosine of the angle between FVEC and any column of the jacobian
+!       is at most GTOL in absolute value.
+!    5, number of calls to FCN has reached or exceeded MAXFEV.
+!    6, FTOL is too small.  No further reduction in the sum of squares
+!       is possible.
+!    7, XTOL is too small.  No further improvement in the approximate
+!       solution X is possible.
+!    8, GTOL is too small.  FVEC is orthogonal to the columns of the
+!       jacobian to machine precision.
+!
+!    Output, integer ( kind = 4 ) NFEV, the number of calls to FCN.
+!
+!    Output, real ( kind = 8 ) FJAC(LDFJAC,N), an M by N array.  The upper
+!    N by N submatrix of FJAC contains an upper triangular matrix R with
+!    diagonal elements of nonincreasing magnitude such that
+!
+!      P' * ( JAC' * JAC ) * P = R' * R,
+!
+!    where P is a permutation matrix and JAC is the final calculated jacobian.
+!    Column J of P is column IPVT(J) of the identity matrix.  The lower
+!    trapezoidal part of FJAC contains information generated during
+!    the computation of R.
+!
+!    Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC.
+!    LDFJAC must be at least M.
+!
+!    Output, integer ( kind = 4 ) IPVT(N), defines a permutation matrix P such
+!    that JAC * P = Q * R, where JAC is the final calculated jacobian, Q is
+!    orthogonal (not stored), and R is upper triangular with diagonal
+!    elements of nonincreasing magnitude.  Column J of P is column IPVT(J)
+!    of the identity matrix.
+!
+!    Output, real ( kind = 8 ) QTF(N), the first N elements of Q'*FVEC.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldfjac
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) actred
+  real ( kind = 8 ) delta
+  real ( kind = 8 ) diag(n)
+  real ( kind = 8 ) dirder
+  real ( kind = 8 ) enorm
+  real ( kind = 8 ) epsfcn
+  real ( kind = 8 ) epsmch
+  real ( kind = 8 ) factor
+  external fcn
+  real ( kind = 8 ) fjac(ldfjac,n)
+  real ( kind = 8 ) fnorm
+  real ( kind = 8 ) fnorm1
+  real ( kind = 8 ) ftol
+  real ( kind = 8 ) fvec(m)
+  real ( kind = 8 ) gnorm
+  real ( kind = 8 ) gtol
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) iflag
+  integer ( kind = 4 ) iter
+  integer ( kind = 4 ) info
+  integer ( kind = 4 ) ipvt(n)
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) maxfev
+  integer ( kind = 4 ) mode
+  integer ( kind = 4 ) nfev
+  integer ( kind = 4 ) nprint
+  real ( kind = 8 ) par
+  real ( kind = 8 ) pnorm
+  real ( kind = 8 ) prered
+  real ( kind = 8 ) qtf(n)
+  real ( kind = 8 ) ratio
+  real ( kind = 8 ) sum2
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) temp1
+  real ( kind = 8 ) temp2
+  real ( kind = 8 ) wa1(n)
+  real ( kind = 8 ) wa2(n)
+  real ( kind = 8 ) wa3(n)
+  real ( kind = 8 ) wa4(m)
+  real ( kind = 8 ) x(n)
+  real ( kind = 8 ) xnorm
+  real ( kind = 8 ) xtol
+
+  epsmch = epsilon ( epsmch )
+
+  info = 0
+  iflag = 0
+  nfev = 0
+
+  if ( n <= 0 ) then
+    go to 300
+  else if ( m < n ) then
+    go to 300
+  else if ( ldfjac < m ) then
+    go to 300
+  else if ( ftol < 0.0D+00 ) then
+    go to 300
+  else if ( xtol < 0.0D+00 ) then
+    go to 300
+  else if ( gtol < 0.0D+00 ) then
+    go to 300
+  else if ( maxfev <= 0 ) then
+    go to 300
+  else if ( factor <= 0.0D+00 ) then
+    go to 300
+  end if
+
+  if ( mode == 2 ) then
+    do j = 1, n
+      if ( diag(j) <= 0.0D+00 ) then
+        go to 300
+      end if
+    end do
+  end if
+!
+!  Evaluate the function at the starting point and calculate its norm.
+!
+  iflag = 1
+  call fcn ( m, n, x, fvec, iflag )
+  nfev = 1
+
+  if ( iflag < 0 ) then
+    go to 300
+  end if
+
+  fnorm = enorm ( m, fvec )
+!
+!  Initialize Levenberg-Marquardt parameter and iteration counter.
+!
+  par = 0.0D+00
+  iter = 1
+!
+!  Beginning of the outer loop.
+!
+30 continue
+!
+!  Calculate the jacobian matrix.
+!
+  iflag = 2
+  call fdjac2 ( fcn, m, n, x, fvec, fjac, ldfjac, iflag, epsfcn )
+  nfev = nfev + n
+
+  if ( iflag < 0 ) then
+    go to 300
+  end if
+!
+!  If requested, call FCN to enable printing of iterates.
+!
+     if ( 0 < nprint ) then
+       iflag = 0
+       if ( mod ( iter-1, nprint ) == 0 ) then
+         call fcn ( m, n, x, fvec, iflag )
+       end if
+       if ( iflag < 0 ) then
+         go to 300
+       end if
+     end if
+!
+!  Compute the QR factorization of the jacobian.
+!
+     call qrfac ( m, n, fjac, ldfjac, .true., ipvt, n, wa1, wa2 )
+!
+!  On the first iteration and if MODE is 1, scale according
+!  to the norms of the columns of the initial jacobian.
+!
+     if ( iter == 1 ) then
+
+       if ( mode /= 2 ) then
+         diag(1:n) = wa2(1:n)
+         do j = 1, n
+           if ( wa2(j) == 0.0D+00 ) then
+             diag(j) = 1.0D+00
+           end if
+         end do
+       end if
+!
+!  On the first iteration, calculate the norm of the scaled X
+!  and initialize the step bound DELTA.
+!
+       wa3(1:n) = diag(1:n) * x(1:n)
+       xnorm = enorm ( n, wa3 )
+       delta = factor * xnorm
+       if ( delta == 0.0D+00 ) then
+         delta = factor
+       end if
+     end if
+!
+!  Form Q' * FVEC and store the first N components in QTF.
+!
+     wa4(1:m) = fvec(1:m)
+
+     do j = 1, n
+
+       if ( fjac(j,j) /= 0.0D+00 ) then
+         sum2 = dot_product ( wa4(j:m), fjac(j:m,j) )
+         temp = - sum2 / fjac(j,j)
+         wa4(j:m) = wa4(j:m) + fjac(j:m,j) * temp
+       end if
+
+       fjac(j,j) = wa1(j)
+       qtf(j) = wa4(j)
+
+     end do
+!
+!  Compute the norm of the scaled gradient.
+!
+     gnorm = 0.0D+00
+
+     if ( fnorm /= 0.0D+00 ) then
+
+       do j = 1, n
+
+         l = ipvt(j)
+
+         if ( wa2(l) /= 0.0D+00 ) then
+           sum2 = 0.0D+00
+           do i = 1, j
+             sum2 = sum2 + fjac(i,j) * ( qtf(i) / fnorm )
+           end do
+           gnorm = max ( gnorm, abs ( sum2 / wa2(l) ) )
+         end if
+
+       end do
+
+     end if
+!
+!  Test for convergence of the gradient norm.
+!
+     if ( gnorm <= gtol ) then
+       info = 4
+       go to 300
+     end if
+!
+!  Rescale if necessary.
+!
+     if ( mode /= 2 ) then
+       do j = 1, n
+         diag(j) = max ( diag(j), wa2(j) )
+       end do
+     end if
+!
+!  Beginning of the inner loop.
+!
+200  continue
+!
+!  Determine the Levenberg-Marquardt parameter.
+!
+        call lmpar ( n, fjac, ldfjac, ipvt, diag, qtf, delta, par, wa1, wa2 )
+!
+!  Store the direction P and X + P.
+!  Calculate the norm of P.
+!
+        wa1(1:n) = -wa1(1:n)
+        wa2(1:n) = x(1:n) + wa1(1:n)
+        wa3(1:n) = diag(1:n) * wa1(1:n)
+
+        pnorm = enorm ( n, wa3 )
+!
+!  On the first iteration, adjust the initial step bound.
+!
+        if ( iter == 1 ) then
+          delta = min ( delta, pnorm )
+        end if
+!
+!  Evaluate the function at X + P and calculate its norm.
+!
+        iflag = 1
+        call fcn ( m, n, wa2, wa4, iflag )
+        nfev = nfev + 1
+        if ( iflag < 0 ) then
+          go to 300
+        end if
+        fnorm1 = enorm ( m, wa4 )
+!
+!  Compute the scaled actual reduction.
+!
+        if ( 0.1D+00 * fnorm1 < fnorm ) then
+          actred = 1.0D+00 - ( fnorm1 / fnorm )**2
+        else
+          actred = -1.0D+00
+        end if
+!
+!  Compute the scaled predicted reduction and the scaled directional derivative.
+!
+        do j = 1, n
+          wa3(j) = 0.0D+00
+          l = ipvt(j)
+          temp = wa1(l)
+          wa3(1:j) = wa3(1:j) + fjac(1:j,j) * temp
+        end do
+
+        temp1 = enorm ( n, wa3 ) / fnorm
+        temp2 = ( sqrt ( par ) * pnorm ) / fnorm
+        prered = temp1**2 + temp2**2 / 0.5D+00
+        dirder = - ( temp1**2 + temp2**2 )
+!
+!  Compute the ratio of the actual to the predicted reduction.
+!
+        ratio = 0.0D+00
+        if ( prered /= 0.0D+00 ) then
+          ratio = actred / prered
+        end if
+!
+!  Update the step bound.
+!
+        if ( ratio <= 0.25D+00 ) then
+
+           if ( actred >= 0.0D+00 ) then
+             temp = 0.5D+00
+           endif
+
+           if ( actred < 0.0D+00 ) then
+             temp = 0.5D+00 * dirder / ( dirder + 0.5D+00 * actred )
+           end if
+
+           if ( 0.1D+00 * fnorm1 >= fnorm .or. temp < 0.1D+00 ) then
+             temp = 0.1D+00
+           end if
+
+           delta = temp * min ( delta, pnorm / 0.1D+00  )
+           par = par / temp
+
+        else
+
+           if ( par == 0.0D+00 .or. ratio >= 0.75D+00 ) then
+             delta = 2.0D+00 * pnorm
+             par = 0.5D+00 * par
+           end if
+
+        end if
+!
+!  Test for successful iteration.
+!
+
+!
+!  Successful iteration. update X, FVEC, and their norms.
+!
+        if ( 0.0001D+00 <= ratio ) then
+          x(1:n) = wa2(1:n)
+          wa2(1:n) = diag(1:n) * x(1:n)
+          fvec(1:m) = wa4(1:m)
+          xnorm = enorm ( n, wa2 )
+          fnorm = fnorm1
+          iter = iter + 1
+        end if
+!
+!  Tests for convergence.
+!
+        if ( abs ( actred) <= ftol .and. prered <= ftol &
+          .and. 0.5D+00 * ratio <= 1.0D+00 ) then
+          info = 1
+        end if
+
+        if ( delta <= xtol * xnorm ) then
+          info = 2
+        end if
+
+        if ( abs ( actred) <= ftol .and. prered <= ftol &
+          .and. 0.5D+00 * ratio <= 1.0D+00 .and. info == 2 ) info = 3
+
+        if ( info /= 0 ) then
+          go to 300
+        end if
+!
+!  Tests for termination and stringent tolerances.
+!
+        if ( maxfev <= nfev ) then
+          info = 5
+        end if
+
+        if ( abs ( actred) <= epsmch .and. prered <= epsmch &
+          .and. 0.5D+00 * ratio <= 1.0D+00 ) then
+          info = 6
+        end if
+
+        if ( delta <= epsmch * xnorm ) then
+          info = 7
+        end if
+
+        if ( gnorm <= epsmch ) then
+          info = 8
+        end if
+
+        if ( info /= 0 ) then
+          go to 300
+        end if
+!
+!  End of the inner loop.  Repeat if iteration unsuccessful.
+!
+        if ( ratio < 0.0001D+00 ) then
+          go to 200
+        end if
+!
+!  End of the outer loop.
+!
+     go to 30
+
+300 continue
+!
+!  Termination, either normal or user imposed.
+!
+  if ( iflag < 0 ) then
+    info = iflag
+  end if
+
+  iflag = 0
+
+  if ( 0 < nprint ) then
+    call fcn ( m, n, x, fvec, iflag )
+  end if
+
+  return
+end subroutine lmdif
+subroutine lmdif1 ( fcn, m, n, x, fvec, tol, info )
+
+!*****************************************************************************80
+!
+!! LMDIF1 minimizes M functions in N variables using Levenberg-Marquardt method.
+!
+!  Discussion:
+!
+!    LMDIF1 minimizes the sum of the squares of M nonlinear functions in
+!    N variables by a modification of the Levenberg-Marquardt algorithm.
+!    This is done by using the more general least-squares solver LMDIF.
+!    The user must provide a subroutine which calculates the functions.
+!    The jacobian is then calculated by a forward-difference approximation.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, external FCN, the name of the user-supplied subroutine which
+!    calculates the functions.  The routine should have the form:
+!
+!      subroutine fcn ( m, n, x, fvec, iflag )
+!      integer ( kind = 4 ) n
+!      real fvec(m)
+!      integer ( kind = 4 ) iflag
+!      real x(n)
+!
+!    The value of IFLAG should not be changed by FCN unless
+!    the user wants to terminate execution of the routine.
+!    In this case set IFLAG to a negative integer.
+!
+!    Input, integer ( kind = 4 ) M, the number of functions.
+!
+!    Input, integer ( kind = 4 ) N, the number of variables.  
+!    N must not exceed M.
+!
+!    Input/output, real ( kind = 8 ) X(N).  On input, X must contain an initial
+!    estimate of the solution vector.  On output X contains the final
+!    estimate of the solution vector.
+!
+!    Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X.
+!
+!    Input, real ( kind = 8 ) TOL.  Termination occurs when the algorithm
+!    estimates either that the relative error in the sum of squares is at
+!    most TOL or that the relative error between X and the solution is at
+!    most TOL.  TOL should be nonnegative.
+!
+!    Output, integer ( kind = 4 ) INFO, error flag.  If the user has terminated
+!    execution, INFO is set to the (negative) value of IFLAG. See description
+!    of FCN.  Otherwise, INFO is set as follows:
+!    0, improper input parameters.
+!    1, algorithm estimates that the relative error in the sum of squares
+!       is at most TOL.
+!    2, algorithm estimates that the relative error between X and the
+!       solution is at most TOL.
+!    3, conditions for INFO = 1 and INFO = 2 both hold.
+!    4, FVEC is orthogonal to the columns of the jacobian to machine precision.
+!    5, number of calls to FCN has reached or exceeded 200*(N+1).
+!    6, TOL is too small.  No further reduction in the sum of squares
+!       is possible.
+!    7, TOL is too small.  No further improvement in the approximate
+!       solution X is possible.
+!
+  implicit none
+
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) diag(n)
+  real ( kind = 8 ) epsfcn
+  real ( kind = 8 ) factor
+  external fcn
+  real ( kind = 8 ) fjac(m,n)
+  real ( kind = 8 ) ftol
+  real ( kind = 8 ) fvec(m)
+  real ( kind = 8 ) gtol
+  integer ( kind = 4 ) info
+  integer ( kind = 4 ) ipvt(n)
+  integer ( kind = 4 ) ldfjac
+  integer ( kind = 4 ) maxfev
+  integer ( kind = 4 ) mode
+  integer ( kind = 4 ) nfev
+  integer ( kind = 4 ) nprint
+  real ( kind = 8 ) qtf(n)
+  real ( kind = 8 ) tol
+  real ( kind = 8 ) x(n)
+  real ( kind = 8 ) xtol
+
+  info = 0
+
+  if ( n <= 0 ) then
+    return
+  else if ( m < n ) then
+    return
+  else if ( tol < 0.0D+00 ) then
+    return
+  end if
+
+  factor = 100.0D+00
+  maxfev = 200 * ( n + 1 )
+  ftol = tol
+  xtol = tol
+  gtol = 0.0D+00
+  epsfcn = 0.0D+00
+  mode = 1
+  nprint = 0
+  ldfjac = m
+
+  call lmdif ( fcn, m, n, x, fvec, ftol, xtol, gtol, maxfev, epsfcn, &
+    diag, mode, factor, nprint, info, nfev, fjac, ldfjac, ipvt, qtf )
+
+  if ( info == 8 ) then
+    info = 4
+  end if
+
+  return
+end subroutine lmdif1
+subroutine lmpar ( n, r, ldr, ipvt, diag, qtb, delta, par, x, sdiag )
+
+!*****************************************************************************80
+!
+!! LMPAR computes a parameter for the Levenberg-Marquardt method.
+!
+!  Discussion:
+!
+!    Given an M by N matrix A, an N by N nonsingular diagonal
+!    matrix D, an M-vector B, and a positive number DELTA,
+!    the problem is to determine a value for the parameter
+!    PAR such that if X solves the system
+!
+!      A*X = B,
+!      sqrt ( PAR ) * D * X = 0,
+!
+!    in the least squares sense, and DXNORM is the euclidean
+!    norm of D*X, then either PAR is zero and
+!
+!      ( DXNORM - DELTA ) <= 0.1 * DELTA,
+!
+!    or PAR is positive and
+!
+!      abs ( DXNORM - DELTA) <= 0.1 * DELTA.
+!
+!    This subroutine completes the solution of the problem
+!    if it is provided with the necessary information from the
+!    QR factorization, with column pivoting, of A.  That is, if
+!    A*P = Q*R, where P is a permutation matrix, Q has orthogonal
+!    columns, and R is an upper triangular matrix with diagonal
+!    elements of nonincreasing magnitude, then LMPAR expects
+!    the full upper triangle of R, the permutation matrix P,
+!    and the first N components of Q'*B.  On output
+!    LMPAR also provides an upper triangular matrix S such that
+!
+!      P' * ( A' * A + PAR * D * D ) * P = S'* S.
+!
+!    S is employed within LMPAR and may be of separate interest.
+!
+!    Only a few iterations are generally needed for convergence
+!    of the algorithm.  If, however, the limit of 10 iterations
+!    is reached, then the output PAR will contain the best
+!    value obtained so far.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    24 January 2014
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the order of R.
+!
+!    Input/output, real ( kind = 8 ) R(LDR,N),the N by N matrix.  The full
+!    upper triangle must contain the full upper triangle of the matrix R.
+!    On output the full upper triangle is unaltered, and the strict lower
+!    triangle contains the strict upper triangle (transposed) of the upper
+!    triangular matrix S.
+!
+!    Input, integer ( kind = 4 ) LDR, the leading dimension of R.  LDR must be
+!    no less than N.
+!
+!    Input, integer ( kind = 4 ) IPVT(N), defines the permutation matrix P 
+!    such that A*P = Q*R.  Column J of P is column IPVT(J) of the 
+!    identity matrix.
+!
+!    Input, real ( kind = 8 ) DIAG(N), the diagonal elements of the matrix D.
+!
+!    Input, real ( kind = 8 ) QTB(N), the first N elements of the vector Q'*B.
+!
+!    Input, real ( kind = 8 ) DELTA, an upper bound on the euclidean norm
+!    of D*X.  DELTA should be positive.
+!
+!    Input/output, real ( kind = 8 ) PAR.  On input an initial estimate of the
+!    Levenberg-Marquardt parameter.  On output the final estimate.
+!    PAR should be nonnegative.
+!
+!    Output, real ( kind = 8 ) X(N), the least squares solution of the system
+!    A*X = B, sqrt(PAR)*D*X = 0, for the output value of PAR.
+!
+!    Output, real ( kind = 8 ) SDIAG(N), the diagonal elements of the upper
+!    triangular matrix S.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldr
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) delta
+  real ( kind = 8 ) diag(n)
+  real ( kind = 8 ) dwarf
+  real ( kind = 8 ) dxnorm
+  real ( kind = 8 ) enorm
+  real ( kind = 8 ) gnorm
+  real ( kind = 8 ) fp
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ipvt(n)
+  integer ( kind = 4 ) iter
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) nsing
+  real ( kind = 8 ) par
+  real ( kind = 8 ) parc
+  real ( kind = 8 ) parl
+  real ( kind = 8 ) paru
+  real ( kind = 8 ) qnorm
+  real ( kind = 8 ) qtb(n)
+  real ( kind = 8 ) r(ldr,n)
+  real ( kind = 8 ) sdiag(n)
+  real ( kind = 8 ) sum2
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) wa1(n)
+  real ( kind = 8 ) wa2(n)
+  real ( kind = 8 ) x(n)
+!
+!  DWARF is the smallest positive magnitude.
+!
+  dwarf = tiny ( dwarf )
+!
+!  Compute and store in X the Gauss-Newton direction.
+!
+!  If the jacobian is rank-deficient, obtain a least squares solution.
+!
+  nsing = n
+
+  do j = 1, n
+    wa1(j) = qtb(j)
+    if ( r(j,j) == 0.0D+00 .and. nsing == n ) then
+      nsing = j - 1
+    end if
+    if ( nsing < n ) then
+      wa1(j) = 0.0D+00
+    end if
+  end do
+
+  do k = 1, nsing
+    j = nsing - k + 1
+    wa1(j) = wa1(j) / r(j,j)
+    temp = wa1(j)
+    wa1(1:j-1) = wa1(1:j-1) - r(1:j-1,j) * temp
+  end do
+
+  do j = 1, n
+    l = ipvt(j)
+    x(l) = wa1(j)
+  end do
+!
+!  Initialize the iteration counter.
+!  Evaluate the function at the origin, and test
+!  for acceptance of the Gauss-Newton direction.
+!
+  iter = 0
+  wa2(1:n) = diag(1:n) * x(1:n)
+  dxnorm = enorm ( n, wa2 )
+  fp = dxnorm - delta
+
+  if ( fp <= 0.1D+00 * delta ) then
+    if ( iter == 0 ) then
+      par = 0.0D+00
+    end if
+    return
+  end if
+!
+!  If the jacobian is not rank deficient, the Newton
+!  step provides a lower bound, PARL, for the zero of
+!  the function.
+!
+!  Otherwise set this bound to zero.
+!
+  parl = 0.0D+00
+
+  if ( n <= nsing ) then
+
+    do j = 1, n
+      l = ipvt(j)
+      wa1(j) = diag(l) * ( wa2(l) / dxnorm )
+    end do
+
+    do j = 1, n
+      sum2 = dot_product ( wa1(1:j-1), r(1:j-1,j) )
+      wa1(j) = ( wa1(j) - sum2 ) / r(j,j)
+    end do
+
+    temp = enorm ( n, wa1 )
+    parl = ( ( fp / delta ) / temp ) / temp
+
+  end if
+!
+!  Calculate an upper bound, PARU, for the zero of the function.
+!
+  do j = 1, n
+    sum2 = dot_product ( qtb(1:j), r(1:j,j) )
+    l = ipvt(j)
+    wa1(j) = sum2 / diag(l)
+  end do
+
+  gnorm = enorm ( n, wa1 )
+  paru = gnorm / delta
+
+  if ( paru == 0.0D+00 ) then
+    paru = dwarf / min ( delta, 0.1D+00 )
+  end if
+!
+!  If the input PAR lies outside of the interval (PARL, PARU),
+!  set PAR to the closer endpoint.
+!
+  par = max ( par, parl )
+  par = min ( par, paru )
+  if ( par == 0.0D+00 ) then
+    par = gnorm / dxnorm
+  end if
+!
+!  Beginning of an iteration.
+!
+  do
+ 
+    iter = iter + 1
+!
+!  Evaluate the function at the current value of PAR.
+!
+    if ( par == 0.0D+00 ) then
+      par = max ( dwarf, 0.001D+00 * paru )
+    end if
+
+    wa1(1:n) = sqrt ( par ) * diag(1:n)
+
+    call qrsolv ( n, r, ldr, ipvt, wa1, qtb, x, sdiag )
+
+    wa2(1:n) = diag(1:n) * x(1:n)
+    dxnorm = enorm ( n, wa2 )
+    temp = fp
+    fp = dxnorm - delta
+!
+!  If the function is small enough, accept the current value of PAR.
+!
+    if ( abs ( fp ) <= 0.1D+00 * delta ) then
+      exit
+    end if
+!
+!  Test for the exceptional cases where PARL
+!  is zero or the number of iterations has reached 10.
+!
+    if ( parl == 0.0D+00 .and. fp <= temp .and. temp < 0.0D+00 ) then
+      exit
+    else if ( iter == 10 ) then
+      exit
+    end if
+!
+!  Compute the Newton correction.
+!
+    do j = 1, n
+      l = ipvt(j)
+      wa1(j) = diag(l) * ( wa2(l) / dxnorm )
+    end do
+
+    do j = 1, n
+      wa1(j) = wa1(j) / sdiag(j)
+      temp = wa1(j)
+      wa1(j+1:n) = wa1(j+1:n) - r(j+1:n,j) * temp
+    end do
+
+    temp = enorm ( n, wa1 )
+    parc = ( ( fp / delta ) / temp ) / temp
+!
+!  Depending on the sign of the function, update PARL or PARU.
+!
+    if ( 0.0D+00 < fp ) then
+      parl = max ( parl, par )
+    else if ( fp < 0.0D+00 ) then
+      paru = min ( paru, par )
+    end if
+!
+!  Compute an improved estimate for PAR.
+!
+    par = max ( parl, par + parc )
+!
+!  End of an iteration.
+!
+  end do
+!
+!  Termination.
+!
+  if ( iter == 0 ) then
+    par = 0.0D+00
+  end if
+
+  return
+end subroutine lmpar
+subroutine lmstr ( fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, &
+  diag, mode, factor, nprint, info, nfev, njev, ipvt, qtf )
+
+!*****************************************************************************80
+!
+!! LMSTR minimizes M functions in N variables using Levenberg-Marquardt method.
+!
+!  Discussion:
+!
+!    LMSTR minimizes the sum of the squares of M nonlinear functions in
+!    N variables by a modification of the Levenberg-Marquardt algorithm
+!    which uses minimal storage.
+!
+!    The user must provide a subroutine which calculates the functions and
+!    the rows of the jacobian.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, external FCN, the name of the user-supplied subroutine which
+!    calculates the functions and the rows of the jacobian.
+!    FCN should have the form:
+!
+!      subroutine fcn ( m, n, x, fvec, fjrow, iflag )
+!
+!      integer ( kind = 4 ) m
+!      integer ( kind = 4 ) n
+!
+!      real fjrow(n)
+!      real fvec(m)
+!      integer ( kind = 4 ) iflag
+!      real x(n)
+!
+!    If the input value of IFLAG is 1, calculate the functions at X and
+!    return this vector in FVEC.
+!    If the input value of IFLAG is I > 1, calculate the (I-1)-st row of
+!    the jacobian at X, and return this vector in FJROW.
+!    To terminate the algorithm, set the output value of IFLAG negative.
+!
+!    Input, integer ( kind = 4 ) M, the number of functions.
+!
+!    Input, integer ( kind = 4 ) N, the number of variables.  
+!    N must not exceed M.
+!
+!    Input/output, real ( kind = 8 ) X(N).  On input, X must contain an initial
+!    estimate of the solution vector.  On output X contains the final
+!    estimate of the solution vector.
+!
+!    Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X.
+!
+!    Output, real ( kind = 8 ) FJAC(LDFJAC,N), an N by N array.  The upper
+!    triangle of FJAC contains an upper triangular matrix R such that
+!
+!      P' * ( JAC' * JAC ) * P = R' * R,
+!
+!    where P is a permutation matrix and JAC is the final calculated jacobian.
+!    Column J of P is column IPVT(J) of the identity matrix.  The lower
+!    triangular part of FJAC contains information generated during
+!    the computation of R.
+!
+!    Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC.
+!    LDFJAC must be at least N.
+!
+!    Input, real ( kind = 8 ) FTOL.  Termination occurs when both the actual and
+!    predicted relative reductions in the sum of squares are at most FTOL.
+!    Therefore, FTOL measures the relative error desired in the sum of
+!    squares.  FTOL should be nonnegative.
+!
+!    Input, real ( kind = 8 ) XTOL.  Termination occurs when the relative error 
+!    between two consecutive iterates is at most XTOL.  XTOL should be 
+!    nonnegative.
+!
+!    Input, real ( kind = 8 ) GTOL. termination occurs when the cosine of the 
+!    angle between FVEC and any column of the jacobian is at most GTOL in 
+!    absolute value.  Therefore, GTOL measures the orthogonality desired 
+!    between the function vector and the columns of the jacobian.  GTOL should
+!    be nonnegative.
+!
+!    Input, integer ( kind = 4 ) MAXFEV.  Termination occurs when the number 
+!    of calls to FCN with IFLAG = 1 is at least MAXFEV by the end of 
+!    an iteration.
+!
+!    Input/output, real ( kind = 8 ) DIAG(N).  If MODE = 1, then DIAG is set 
+!    internally.  If MODE = 2, then DIAG must contain positive entries that 
+!    serve as multiplicative scale factors for the variables.
+!
+!    Input, integer ( kind = 4 ) MODE, scaling option.
+!    1, variables will be scaled internally.
+!    2, scaling is specified by the input DIAG vector.
+!
+!    Input, real ( kind = 8 ) FACTOR, determines the initial step bound.  This 
+!    bound is set to the product of FACTOR and the euclidean norm of DIAG*X if
+!    nonzero, or else to FACTOR itself.  In most cases, FACTOR should lie
+!    in the interval (0.1, 100) with 100 the recommended value.
+!
+!    Input, integer ( kind = 4 ) NPRINT, enables controlled printing of iterates
+!    if it is positive.  In this case, FCN is called with IFLAG = 0 at the
+!    beginning of the first iteration and every NPRINT iterations thereafter
+!    and immediately prior to return, with X and FVEC available
+!    for printing.  If NPRINT is not positive, no special calls
+!    of FCN with IFLAG = 0 are made.
+!
+!    Output, integer ( kind = 4 ) INFO, error flag.  If the user has terminated
+!    execution, INFO is set to the (negative) value of IFLAG. See the 
+!    description of FCN.  Otherwise, INFO is set as follows:
+!    0, improper input parameters.
+!    1, both actual and predicted relative reductions in the sum of squares
+!       are at most FTOL.
+!    2, relative error between two consecutive iterates is at most XTOL.
+!    3, conditions for INFO = 1 and INFO = 2 both hold.
+!    4, the cosine of the angle between FVEC and any column of the jacobian
+!       is at most GTOL in absolute value.
+!    5, number of calls to FCN with IFLAG = 1 has reached MAXFEV.
+!    6, FTOL is too small.  No further reduction in the sum of squares is
+!       possible.
+!    7, XTOL is too small.  No further improvement in the approximate
+!       solution X is possible.
+!    8, GTOL is too small.  FVEC is orthogonal to the columns of the
+!       jacobian to machine precision.
+!
+!    Output, integer ( kind = 4 ) NFEV, the number of calls to FCN 
+!    with IFLAG = 1.
+!
+!    Output, integer ( kind = 4 ) NJEV, the number of calls to FCN 
+!    with IFLAG = 2.
+!
+!    Output, integer ( kind = 4 ) IPVT(N), defines a permutation matrix P such
+!    that JAC * P = Q * R, where JAC is the final calculated jacobian, Q is
+!    orthogonal (not stored), and R is upper triangular.
+!    Column J of P is column IPVT(J) of the identity matrix.
+!
+!    Output, real ( kind = 8 ) QTF(N), contains the first N elements of Q'*FVEC.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldfjac
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) actred
+  real ( kind = 8 ) delta
+  real ( kind = 8 ) diag(n)
+  real ( kind = 8 ) dirder
+  real ( kind = 8 ) enorm
+  real ( kind = 8 ) epsmch
+  real ( kind = 8 ) factor
+  external fcn
+  real ( kind = 8 ) fjac(ldfjac,n)
+  real ( kind = 8 ) fnorm
+  real ( kind = 8 ) fnorm1
+  real ( kind = 8 ) ftol
+  real ( kind = 8 ) fvec(m)
+  real ( kind = 8 ) gnorm
+  real ( kind = 8 ) gtol
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) iflag
+  integer ( kind = 4 ) info
+  integer ( kind = 4 ) ipvt(n)
+  integer ( kind = 4 ) iter
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) maxfev
+  integer ( kind = 4 ) mode
+  integer ( kind = 4 ) nfev
+  integer ( kind = 4 ) njev
+  integer ( kind = 4 ) nprint
+  real ( kind = 8 ) par
+  real ( kind = 8 ) pnorm
+  real ( kind = 8 ) prered
+  real ( kind = 8 ) qtf(n)
+  real ( kind = 8 ) ratio
+  logical sing
+  real ( kind = 8 ) sum2
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) temp1
+  real ( kind = 8 ) temp2
+  real ( kind = 8 ) wa1(n)
+  real ( kind = 8 ) wa2(n)
+  real ( kind = 8 ) wa3(n)
+  real ( kind = 8 ) wa4(m)
+  real ( kind = 8 ) x(n)
+  real ( kind = 8 ) xnorm
+  real ( kind = 8 ) xtol
+
+  epsmch = epsilon ( epsmch )
+
+  info = 0
+  iflag = 0
+  nfev = 0
+  njev = 0
+!
+!  Check the input parameters for errors.
+!
+  if ( n <= 0 ) then
+    go to 340
+  else if ( m < n ) then
+    go to 340
+  else if ( ldfjac < n ) then
+    go to 340
+  else if ( ftol < 0.0D+00 ) then
+    go to 340
+  else if ( xtol < 0.0D+00 ) then
+    go to 340
+  else if ( gtol < 0.0D+00 ) then
+    go to 340
+  else if ( maxfev <= 0 ) then
+    go to 340
+  else if ( factor <= 0.0D+00 ) then
+    go to 340
+  end if
+
+  if ( mode == 2 ) then
+    do j = 1, n
+      if ( diag(j) <= 0.0D+00 ) then
+        go to 340
+      end if
+    end do
+  end if
+!
+!  Evaluate the function at the starting point and calculate its norm.
+!
+  iflag = 1
+  call fcn ( m, n, x, fvec, wa3, iflag )
+  nfev = 1
+
+  if ( iflag < 0 ) then
+    go to 340
+  end if
+
+  fnorm = enorm ( m, fvec )
+!
+!  Initialize Levenberg-Marquardt parameter and iteration counter.
+!
+  par = 0.0D+00
+  iter = 1
+!
+!  Beginning of the outer loop.
+!
+   30 continue
+!
+!  If requested, call FCN to enable printing of iterates.
+!
+     if ( 0 < nprint ) then
+       iflag = 0
+       if ( mod ( iter-1, nprint ) == 0 ) then
+         call fcn ( m, n, x, fvec, wa3, iflag )
+       end if
+       if ( iflag < 0 ) then
+         go to 340
+       end if
+     end if
+!
+!  Compute the QR factorization of the jacobian matrix calculated one row
+!  at a time, while simultaneously forming Q'* FVEC and storing
+!  the first N components in QTF.
+!
+     qtf(1:n) = 0.0D+00
+     fjac(1:n,1:n) = 0.0D+00
+     iflag = 2
+
+     do i = 1, m
+       call fcn ( m, n, x, fvec, wa3, iflag )
+       if ( iflag < 0 ) then
+         go to 340
+       end if
+       temp = fvec(i)
+       call rwupdt ( n, fjac, ldfjac, wa3, qtf, temp, wa1, wa2 )
+       iflag = iflag + 1
+     end do
+
+     njev = njev + 1
+!
+!  If the jacobian is rank deficient, call QRFAC to
+!  reorder its columns and update the components of QTF.
+!
+     sing = .false.
+     do j = 1, n
+       if ( fjac(j,j) == 0.0D+00 ) then
+         sing = .true.
+       end if
+       ipvt(j) = j
+       wa2(j) = enorm ( j, fjac(1,j) )
+     end do
+
+     if ( sing ) then
+
+       call qrfac ( n, n, fjac, ldfjac, .true., ipvt, n, wa1, wa2 )
+
+       do j = 1, n
+
+         if ( fjac(j,j) /= 0.0D+00 ) then
+
+           sum2 = dot_product ( qtf(j:n), fjac(j:n,j) )
+           temp = - sum2 / fjac(j,j)
+           qtf(j:n) = qtf(j:n) + fjac(j:n,j) * temp
+
+         end if
+
+         fjac(j,j) = wa1(j)
+
+       end do
+
+     end if
+!
+!  On the first iteration
+!    if mode is 1,
+!      scale according to the norms of the columns of the initial jacobian.
+!    calculate the norm of the scaled X,
+!    initialize the step bound delta.
+!
+     if ( iter == 1 ) then
+
+       if ( mode /= 2 ) then
+
+         diag(1:n) = wa2(1:n)
+         do j = 1, n
+           if ( wa2(j) == 0.0D+00 ) then
+             diag(j) = 1.0D+00
+           end if
+         end do
+
+       end if
+
+       wa3(1:n) = diag(1:n) * x(1:n)
+       xnorm = enorm ( n, wa3 )
+       delta = factor * xnorm
+       if ( delta == 0.0D+00 ) then
+         delta = factor
+       end if
+
+     end if
+!
+!  Compute the norm of the scaled gradient.
+!
+     gnorm = 0.0D+00
+
+     if ( fnorm /= 0.0D+00 ) then
+
+       do j = 1, n
+         l = ipvt(j)
+         if ( wa2(l) /= 0.0D+00 ) then
+           sum2 = dot_product ( qtf(1:j), fjac(1:j,j) ) / fnorm
+           gnorm = max ( gnorm, abs ( sum2 / wa2(l) ) )
+         end if
+       end do
+
+     end if
+!
+!  Test for convergence of the gradient norm.
+!
+     if ( gnorm <= gtol ) then
+       info = 4
+       go to 340
+     end if
+!
+!  Rescale if necessary.
+!
+     if ( mode /= 2 ) then
+       do j = 1, n
+         diag(j) = max ( diag(j), wa2(j) )
+       end do
+     end if
+!
+!  Beginning of the inner loop.
+!
+240    continue
+!
+!  Determine the Levenberg-Marquardt parameter.
+!
+        call lmpar ( n, fjac, ldfjac, ipvt, diag, qtf, delta, par, wa1, wa2 )
+!
+!  Store the direction P and X + P.
+!  Calculate the norm of P.
+!
+        wa1(1:n) = -wa1(1:n)
+        wa2(1:n) = x(1:n) + wa1(1:n)
+        wa3(1:n) = diag(1:n) * wa1(1:n)
+        pnorm = enorm ( n, wa3 )
+!
+!  On the first iteration, adjust the initial step bound.
+!
+        if ( iter == 1 ) then
+          delta = min ( delta, pnorm )
+        end if
+!
+!  Evaluate the function at X + P and calculate its norm.
+!
+        iflag = 1
+        call fcn ( m, n, wa2, wa4, wa3, iflag )
+        nfev = nfev + 1
+        if ( iflag < 0 ) then
+          go to 340
+        end if
+        fnorm1 = enorm ( m, wa4 )
+!
+!  Compute the scaled actual reduction.
+!
+        if ( 0.1D+00 * fnorm1 < fnorm ) then
+          actred = 1.0D+00 - ( fnorm1 / fnorm )**2
+        else
+          actred = -1.0D+00
+        end if
+!
+!  Compute the scaled predicted reduction and
+!  the scaled directional derivative.
+!
+        do j = 1, n
+          wa3(j) = 0.0D+00
+          l = ipvt(j)
+          temp = wa1(l)
+          wa3(1:j) = wa3(1:j) + fjac(1:j,j) * temp
+        end do
+
+        temp1 = enorm ( n, wa3 ) / fnorm
+        temp2 = ( sqrt(par) * pnorm ) / fnorm
+        prered = temp1**2 + temp2**2 / 0.5D+00
+        dirder = - ( temp1**2 + temp2**2 )
+!
+!  Compute the ratio of the actual to the predicted reduction.
+!
+        if ( prered /= 0.0D+00 ) then
+          ratio = actred / prered
+        else
+          ratio = 0.0D+00
+        end if
+!
+!  Update the step bound.
+!
+        if ( ratio <= 0.25D+00 ) then
+
+          if ( actred >= 0.0D+00 ) then
+            temp = 0.5D+00
+          else
+            temp = 0.5D+00 * dirder / ( dirder + 0.5D+00 * actred )
+          end if
+
+          if ( 0.1D+00 * fnorm1 >= fnorm .or. temp < 0.1D+00 ) then
+            temp = 0.1D+00
+          end if
+
+          delta = temp * min ( delta, pnorm / 0.1D+00 )
+          par = par / temp
+
+        else
+
+          if ( par == 0.0D+00 .or. ratio >= 0.75D+00 ) then
+            delta = pnorm / 0.5D+00
+            par = 0.5D+00 * par
+          end if
+
+        end if
+!
+!  Test for successful iteration.
+!
+        if ( ratio >= 0.0001D+00 ) then
+          x(1:n) = wa2(1:n)
+          wa2(1:n) = diag(1:n) * x(1:n)
+          fvec(1:m) = wa4(1:m)
+          xnorm = enorm ( n, wa2 )
+          fnorm = fnorm1
+          iter = iter + 1
+        end if
+!
+!  Tests for convergence, termination and stringent tolerances.
+!
+        if ( abs ( actred ) <= ftol .and. prered <= ftol &
+          .and. 0.5D+00 * ratio <= 1.0D+00 ) then
+          info = 1
+        end if
+
+        if ( delta <= xtol * xnorm ) then
+          info = 2
+        end if
+
+        if ( abs ( actred ) <= ftol .and. prered <= ftol &
+          .and. 0.5D+00 * ratio <= 1.0D+00 .and. info == 2 ) then
+          info = 3
+        end if
+
+        if ( info /= 0 ) then
+          go to 340
+        end if
+
+        if ( nfev >= maxfev) then
+          info = 5
+        end if
+
+        if ( abs ( actred ) <= epsmch .and. prered <= epsmch &
+          .and. 0.5D+00 * ratio <= 1.0D+00 ) then
+          info = 6
+        end if
+
+        if ( delta <= epsmch * xnorm ) then
+          info = 7
+        end if
+
+        if ( gnorm <= epsmch ) then
+          info = 8
+        end if
+
+        if ( info /= 0 ) then
+          go to 340
+        end if
+!
+!  End of the inner loop.  Repeat if iteration unsuccessful.
+!
+        if ( ratio < 0.0001D+00 ) then
+          go to 240
+        end if
+!
+!  End of the outer loop.
+!
+     go to 30
+
+  340 continue
+!
+!  Termination, either normal or user imposed.
+!
+  if ( iflag < 0 ) then
+    info = iflag
+  end if
+
+  iflag = 0
+
+  if ( nprint > 0 ) then
+    call fcn ( m, n, x, fvec, wa3, iflag )
+  end if
+
+  return
+end subroutine lmstr
+subroutine lmstr1 ( fcn, m, n, x, fvec, fjac, ldfjac, tol, info )
+
+!*****************************************************************************80
+!
+!! LMSTR1 minimizes M functions in N variables using Levenberg-Marquardt method.
+!
+!  Discussion:
+!
+!    LMSTR1 minimizes the sum of the squares of M nonlinear functions in
+!    N variables by a modification of the Levenberg-Marquardt algorithm
+!    which uses minimal storage.
+!
+!    This is done by using the more general least-squares solver
+!    LMSTR.  The user must provide a subroutine which calculates
+!    the functions and the rows of the jacobian.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, external FCN, the name of the user-supplied subroutine which
+!    calculates the functions and the rows of the jacobian.
+!    FCN should have the form:
+!
+!      subroutine fcn ( m, n, x, fvec, fjrow, iflag )
+!      integer ( kind = 4 ) m,n,iflag
+!      integer ( kind = 4 ) n
+!      real fjrow(n)
+!      real fvec(m)
+!      integer ( kind = 4 ) iflag
+!      real x(n)
+!
+!    If the input value of IFLAG is 1, calculate the functions at X and
+!    return this vector in FVEC.
+!    If the input value of IFLAG is I > 1, calculate the (I-1)-st row of
+!    the jacobian at X, and return this vector in FJROW.
+!    To terminate the algorithm, set the output value of IFLAG negative.
+!
+!    Input, integer ( kind = 4 ) M, the number of functions.
+!
+!    Input, integer ( kind = 4 ) N, the number of variables.  
+!    N must not exceed M.
+!
+!    Input/output, real ( kind = 8 ) X(N).  On input, X must contain an initial
+!    estimate of the solution vector.  On output X contains the final
+!    estimate of the solution vector.
+!
+!    Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X.
+!
+!    Output, real ( kind = 8 ) FJAC(LDFJAC,N), an N by N array.  The upper
+!    triangle contains an upper triangular matrix R such that
+!
+!      P' * ( JAC' * JAC ) * P = R' * R,
+!
+!    where P is a permutation matrix and JAC is the final calculated
+!    jacobian.  Column J of P is column IPVT(J) of the identity matrix.
+!    The lower triangular part of FJAC contains information generated
+!    during the computation of R.
+!
+!    Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC.
+!    LDFJAC must be at least N.
+!
+!    Input, real ( kind = 8 ) TOL. Termination occurs when the algorithm 
+!    estimates either that the relative error in the sum of squares is at 
+!    most TOL or that the relative error between X and the solution is at 
+!    most TOL.  TOL should be nonnegative.
+!
+!    Output, integer ( kind = 4 ) INFO, error flag.  If the user has terminated
+!    execution, INFO is set to the (negative) value of IFLAG. See description
+!    of FCN.  Otherwise, INFO is set as follows:
+!    0, improper input parameters.
+!    1, algorithm estimates that the relative error in the sum of squares
+!       is at most TOL.
+!    2, algorithm estimates that the relative error between X and the
+!       solution is at most TOL.
+!    3, conditions for INFO = 1 and INFO = 2 both hold.
+!    4, FVEC is orthogonal to the columns of the jacobian to machine precision.
+!    5, number of calls to FCN with IFLAG = 1 has reached 100*(N+1).
+!    6, TOL is too small.  No further reduction in the sum of squares
+!       is possible.
+!    7, TOL is too small.  No further improvement in the approximate
+!       solution X is possible.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldfjac
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) diag(n)
+  real ( kind = 8 ) factor
+  external fcn
+  real ( kind = 8 ) fjac(ldfjac,n)
+  real ( kind = 8 ) ftol
+  real ( kind = 8 ) fvec(m)
+  real ( kind = 8 ) gtol
+  integer ( kind = 4 ) info
+  integer ( kind = 4 ) ipvt(n)
+  integer ( kind = 4 ) maxfev
+  integer ( kind = 4 ) mode
+  integer ( kind = 4 ) nfev
+  integer ( kind = 4 ) njev
+  integer ( kind = 4 ) nprint
+  real ( kind = 8 ) qtf(n)
+  real ( kind = 8 ) tol
+  real ( kind = 8 ) x(n)
+  real ( kind = 8 ) xtol
+
+  info = 0
+
+  if ( n <= 0 ) then
+    return
+  else if ( m < n ) then
+    return
+  else if ( ldfjac < n ) then
+    return
+  else if ( tol < 0.0D+00 ) then
+    return
+  end if
+
+  factor = 100.0D+00
+  maxfev = 100 * ( n + 1 )
+  ftol = tol
+  xtol = tol
+  gtol = 0.0D+00
+  mode = 1
+  nprint = 0
+
+  call lmstr ( fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, &
+    diag, mode, factor, nprint, info, nfev, njev, ipvt, qtf )
+
+  if ( info == 8 ) then
+    info = 4
+  end if
+
+  return
+end subroutine lmstr1
+subroutine qform ( m, n, q, ldq )
+
+!*****************************************************************************80
+!
+!! QFORM produces the explicit QR factorization of a matrix.
+!
+!  Discussion:
+!
+!    The QR factorization of a matrix is usually accumulated in implicit
+!    form, that is, as a series of orthogonal transformations of the
+!    original matrix.  This routine carries out those transformations,
+!    to explicitly exhibit the factorization construced by QRFAC.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) M, is a positive integer input variable set
+!    to the number of rows of A and the order of Q.
+!
+!    Input, integer ( kind = 4 ) N, is a positive integer input variable set
+!    to the number of columns of A.
+!
+!    Input/output, real ( kind = 8 ) Q(LDQ,M).  Q is an M by M array.
+!    On input the full lower trapezoid in the first min(M,N) columns of Q
+!    contains the factored form.
+!    On output, Q has been accumulated into a square matrix.
+!
+!    Input, integer ( kind = 4 ) LDQ, is a positive integer input variable 
+!    not less than M which specifies the leading dimension of the array Q.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldq
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) minmn
+  real ( kind = 8 ) q(ldq,m)
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) wa(m)
+
+  minmn = min ( m, n )
+
+  do j = 2, minmn
+    q(1:j-1,j) = 0.0D+00
+  end do
+!
+!  Initialize remaining columns to those of the identity matrix.
+!
+  q(1:m,n+1:m) = 0.0D+00
+
+  do j = n+1, m
+    q(j,j) = 1.0D+00
+  end do
+!
+!  Accumulate Q from its factored form.
+!
+  do l = 1, minmn
+
+    k = minmn - l + 1
+
+    wa(k:m) = q(k:m,k)
+
+    q(k:m,k) = 0.0D+00
+    q(k,k) = 1.0D+00
+
+    if ( wa(k) /= 0.0D+00 ) then
+
+      do j = k, m
+        temp = dot_product ( wa(k:m), q(k:m,j) ) / wa(k)
+        q(k:m,j) = q(k:m,j) - temp * wa(k:m)
+      end do
+
+    end if
+
+  end do
+
+  return
+end subroutine qform
+subroutine qrfac ( m, n, a, lda, pivot, ipvt, lipvt, rdiag, acnorm )
+
+!*****************************************************************************80
+!
+!! QRFAC computes a QR factorization using Householder transformations.
+!
+!  Discussion:
+!
+!    This subroutine uses Householder transformations with column
+!    pivoting (optional) to compute a QR factorization of the
+!    M by N matrix A.  That is, QRFAC determines an orthogonal
+!    matrix Q, a permutation matrix P, and an upper trapezoidal
+!    matrix R with diagonal elements of nonincreasing magnitude,
+!    such that A*P = Q*R.  The Householder transformation for
+!    column K, K = 1,2,...,min(M,N), is of the form
+!
+!      I - ( 1 / U(K) ) * U * U'
+!
+!    where U has zeros in the first K-1 positions.  The form of
+!    this transformation and the method of pivoting first
+!    appeared in the corresponding LINPACK subroutine.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) M, the number of rows of A.
+!
+!    Input, integer ( kind = 4 ) N, the number of columns of A.
+!
+!    Input/output, real ( kind = 8 ) A(LDA,N), the M by N array.
+!    On input, A contains the matrix for which the QR factorization is to
+!    be computed.  On output, the strict upper trapezoidal part of A contains
+!    the strict upper trapezoidal part of R, and the lower trapezoidal
+!    part of A contains a factored form of Q (the non-trivial elements of
+!    the U vectors described above).
+!
+!    Input, integer ( kind = 4 ) LDA, the leading dimension of A, which must
+!    be no less than M.
+!
+!    Input, logical PIVOT, is TRUE if column pivoting is to be carried out.
+!
+!    Output, integer ( kind = 4 ) IPVT(LIPVT), defines the permutation matrix P 
+!    such that A*P = Q*R.  Column J of P is column IPVT(J) of the identity 
+!    matrix.  If PIVOT is false, IPVT is not referenced.
+!
+!    Input, integer ( kind = 4 ) LIPVT, the dimension of IPVT, which should 
+!    be N if pivoting is used.
+!
+!    Output, real ( kind = 8 ) RDIAG(N), contains the diagonal elements of R.
+!
+!    Output, real ( kind = 8 ) ACNORM(N), the norms of the corresponding
+!    columns of the input matrix A.  If this information is not needed,
+!    then ACNORM can coincide with RDIAG.
+!
+  implicit none
+
+  integer ( kind = 4 ) lda
+  integer ( kind = 4 ) lipvt
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) a(lda,n)
+  real ( kind = 8 ) acnorm(n)
+  real ( kind = 8 ) ajnorm
+  real ( kind = 8 ) enorm
+  real ( kind = 8 ) epsmch
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) i4_temp
+  integer ( kind = 4 ) ipvt(lipvt)
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kmax
+  integer ( kind = 4 ) minmn
+  logical pivot
+  real ( kind = 8 ) r8_temp(m)
+  real ( kind = 8 ) rdiag(n)
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) wa(n)
+
+  epsmch = epsilon ( epsmch )
+!
+!  Compute the initial column norms and initialize several arrays.
+!
+  do j = 1, n
+    acnorm(j) = enorm ( m, a(1:m,j) )
+  end do
+
+  rdiag(1:n) = acnorm(1:n)
+  wa(1:n) = acnorm(1:n)
+
+  if ( pivot ) then
+    do j = 1, n
+      ipvt(j) = j
+    end do
+  end if
+!
+!  Reduce A to R with Householder transformations.
+!
+  minmn = min ( m, n )
+
+  do j = 1, minmn
+!
+!  Bring the column of largest norm into the pivot position.
+!
+    if ( pivot ) then
+
+      kmax = j
+
+      do k = j, n
+        if ( rdiag(k) > rdiag(kmax) ) then
+          kmax = k
+        end if
+      end do
+
+      if ( kmax /= j ) then
+
+        r8_temp(1:m) = a(1:m,j)
+        a(1:m,j)     = a(1:m,kmax)
+        a(1:m,kmax)  = r8_temp(1:m)
+
+        rdiag(kmax) = rdiag(j)
+        wa(kmax) = wa(j)
+
+        i4_temp    = ipvt(j)
+        ipvt(j)    = ipvt(kmax)
+        ipvt(kmax) = i4_temp
+
+      end if
+
+    end if
+!
+!  Compute the Householder transformation to reduce the
+!  J-th column of A to a multiple of the J-th unit vector.
+!
+    ajnorm = enorm ( m-j+1, a(j,j) )
+
+    if ( ajnorm /= 0.0D+00 ) then
+
+      if ( a(j,j) < 0.0D+00 ) then
+        ajnorm = -ajnorm
+      end if
+
+      a(j:m,j) = a(j:m,j) / ajnorm
+      a(j,j) = a(j,j) + 1.0D+00
+!
+!  Apply the transformation to the remaining columns and update the norms.
+!
+      do k = j+1, n
+
+        temp = dot_product ( a(j:m,j), a(j:m,k) ) / a(j,j)
+
+        a(j:m,k) = a(j:m,k) - temp * a(j:m,j)
+
+        if ( pivot .and. rdiag(k) /= 0.0D+00 ) then
+
+          temp = a(j,k) / rdiag(k)
+          rdiag(k) = rdiag(k) * sqrt ( max ( 0.0D+00, 1.0D+00-temp**2 ) )
+
+          if ( 0.05D+00 * ( rdiag(k) / wa(k) )**2 <= epsmch ) then
+            rdiag(k) = enorm ( m-j, a(j+1,k) )
+            wa(k) = rdiag(k)
+          end if
+
+        end if
+
+      end do
+
+    end if
+
+    rdiag(j) = -ajnorm
+
+  end do
+
+  return
+end subroutine qrfac
+subroutine qrsolv ( n, r, ldr, ipvt, diag, qtb, x, sdiag )
+
+!*****************************************************************************80
+!
+!! QRSOLV solves a rectangular linear system A*x=b in the least squares sense.
+!
+!  Discussion:
+!
+!    Given an M by N matrix A, an N by N diagonal matrix D,
+!    and an M-vector B, the problem is to determine an X which
+!    solves the system
+!
+!      A*X = B
+!      D*X = 0
+!
+!    in the least squares sense.
+!
+!    This subroutine completes the solution of the problem
+!    if it is provided with the necessary information from the
+!    QR factorization, with column pivoting, of A.  That is, if
+!    Q*P = Q*R, where P is a permutation matrix, Q has orthogonal
+!    columns, and R is an upper triangular matrix with diagonal
+!    elements of nonincreasing magnitude, then QRSOLV expects
+!    the full upper triangle of R, the permutation matrix p,
+!    and the first N components of Q'*B.
+!
+!    The system is then equivalent to
+!
+!      R*Z = Q'*B
+!      P'*D*P*Z = 0
+!
+!    where X = P*Z.  If this system does not have full rank,
+!    then a least squares solution is obtained.  On output QRSOLV
+!    also provides an upper triangular matrix S such that
+!
+!      P'*(A'*A + D*D)*P = S'*S.
+!
+!    S is computed within QRSOLV and may be of separate interest.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the order of R.
+!
+!    Input/output, real ( kind = 8 ) R(LDR,N), the N by N matrix.
+!    On input the full upper triangle must contain the full upper triangle
+!    of the matrix R.  On output the full upper triangle is unaltered, and
+!    the strict lower triangle contains the strict upper triangle
+!    (transposed) of the upper triangular matrix S.
+!
+!    Input, integer ( kind = 4 ) LDR, the leading dimension of R, which must be
+!    at least N.
+!
+!    Input, integer ( kind = 4 ) IPVT(N), defines the permutation matrix P such 
+!    that A*P = Q*R.  Column J of P is column IPVT(J) of the identity matrix.
+!
+!    Input, real ( kind = 8 ) DIAG(N), the diagonal elements of the matrix D.
+!
+!    Input, real ( kind = 8 ) QTB(N), the first N elements of the vector Q'*B.
+!
+!    Output, real ( kind = 8 ) X(N), the least squares solution.
+!
+!    Output, real ( kind = 8 ) SDIAG(N), the diagonal elements of the upper
+!    triangular matrix S.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldr
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) c
+  real ( kind = 8 ) cotan
+  real ( kind = 8 ) diag(n)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ipvt(n)
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) nsing
+  real ( kind = 8 ) qtb(n)
+  real ( kind = 8 ) qtbpj
+  real ( kind = 8 ) r(ldr,n)
+  real ( kind = 8 ) s
+  real ( kind = 8 ) sdiag(n)
+  real ( kind = 8 ) sum2
+  real ( kind = 8 ) t
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) wa(n)
+  real ( kind = 8 ) x(n)
+!
+!  Copy R and Q'*B to preserve input and initialize S.
+!
+!  In particular, save the diagonal elements of R in X.
+!
+  do j = 1, n
+    r(j:n,j) = r(j,j:n)
+    x(j) = r(j,j)
+  end do
+
+  wa(1:n) = qtb(1:n)
+!
+!  Eliminate the diagonal matrix D using a Givens rotation.
+!
+  do j = 1, n
+!
+!  Prepare the row of D to be eliminated, locating the
+!  diagonal element using P from the QR factorization.
+!
+    l = ipvt(j)
+
+    if ( diag(l) /= 0.0D+00 ) then
+
+      sdiag(j:n) = 0.0D+00
+      sdiag(j) = diag(l)
+!
+!  The transformations to eliminate the row of D
+!  modify only a single element of Q'*B
+!  beyond the first N, which is initially zero.
+!
+      qtbpj = 0.0D+00
+
+      do k = j, n
+!
+!  Determine a Givens rotation which eliminates the
+!  appropriate element in the current row of D.
+!
+        if ( sdiag(k) /= 0.0D+00 ) then
+
+          if ( abs ( r(k,k) ) < abs ( sdiag(k) ) ) then
+            cotan = r(k,k) / sdiag(k)
+            s = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * cotan**2 )
+            c = s * cotan
+          else
+            t = sdiag(k) / r(k,k)
+            c = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * t**2 )
+            s = c * t
+          end if
+!
+!  Compute the modified diagonal element of R and
+!  the modified element of (Q'*B,0).
+!
+          r(k,k) = c * r(k,k) + s * sdiag(k)
+          temp = c * wa(k) + s * qtbpj
+          qtbpj = - s * wa(k) + c * qtbpj
+          wa(k) = temp
+!
+!  Accumulate the tranformation in the row of S.
+!
+          do i = k+1, n
+            temp = c * r(i,k) + s * sdiag(i)
+            sdiag(i) = - s * r(i,k) + c * sdiag(i)
+            r(i,k) = temp
+          end do
+
+        end if
+
+      end do
+
+    end if
+!
+!  Store the diagonal element of S and restore
+!  the corresponding diagonal element of R.
+!
+    sdiag(j) = r(j,j)
+    r(j,j) = x(j)
+
+  end do
+!
+!  Solve the triangular system for Z.  If the system is
+!  singular, then obtain a least squares solution.
+!
+  nsing = n
+
+  do j = 1, n
+
+    if ( sdiag(j) == 0.0D+00 .and. nsing == n ) then
+      nsing = j - 1
+    end if
+
+    if ( nsing < n ) then
+      wa(j) = 0.0D+00
+    end if
+
+  end do
+
+  do j = nsing, 1, -1
+    sum2 = dot_product ( wa(j+1:nsing), r(j+1:nsing,j) )
+    wa(j) = ( wa(j) - sum2 ) / sdiag(j)
+  end do
+!
+!  Permute the components of Z back to components of X.
+!
+  do j = 1, n
+    l = ipvt(j)
+    x(l) = wa(j)
+  end do
+
+  return
+end subroutine qrsolv
+subroutine r1mpyq ( m, n, a, lda, v, w )
+
+!*****************************************************************************80
+!
+!! R1MPYQ computes A*Q, where Q is the product of Householder transformations.
+!
+!  Discussion:
+!
+!    Given an M by N matrix A, this subroutine computes A*Q where
+!    Q is the product of 2*(N - 1) transformations
+!
+!      GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
+!
+!    and GV(I), GW(I) are Givens rotations in the (I,N) plane which
+!    eliminate elements in the I-th and N-th planes, respectively.
+!    Q itself is not given, rather the information to recover the
+!    GV, GW rotations is supplied.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) M, the number of rows of A.
+!
+!    Input, integer ( kind = 4 ) N, the number of columns of A.
+!
+!    Input/output, real ( kind = 8 ) A(LDA,N), the M by N array.
+!    On input, the matrix A to be postmultiplied by the orthogonal matrix Q.
+!    On output, the value of A*Q.
+!
+!    Input, integer ( kind = 4 ) LDA, the leading dimension of A, which must not
+!    be less than M.
+!
+!    Input, real ( kind = 8 ) V(N), W(N), contain the information necessary
+!    to recover the Givens rotations GV and GW.
+!
+  implicit none
+
+  integer ( kind = 4 ) lda
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) a(lda,n)
+  real ( kind = 8 ) c
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) j
+  real ( kind = 8 ) s
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) v(n)
+  real ( kind = 8 ) w(n)
+!
+!  Apply the first set of Givens rotations to A.
+!
+  do j = n-1, 1, -1
+
+     if ( 1.0D+00 < abs ( v(j) ) ) then
+       c = 1.0D+00 / v(j)
+       s = sqrt ( 1.0D+00 - c**2 )
+     else
+       s = v(j)
+       c = sqrt ( 1.0D+00 - s**2 )
+     end if
+
+     do i = 1, m
+        temp =   c * a(i,j) - s * a(i,n)
+        a(i,n) = s * a(i,j) + c * a(i,n)
+        a(i,j) = temp
+     end do
+
+  end do
+!
+!  Apply the second set of Givens rotations to A.
+!
+  do j = 1, n-1
+
+     if ( abs ( w(j) ) > 1.0D+00 ) then
+       c = 1.0D+00 / w(j)
+       s = sqrt ( 1.0D+00 - c**2 )
+     else
+       s = w(j)
+       c = sqrt ( 1.0D+00 - s**2 )
+     end if
+
+     do i = 1, m
+        temp =     c * a(i,j) + s * a(i,n)
+        a(i,n) = - s * a(i,j) + c * a(i,n)
+        a(i,j) = temp
+     end do
+
+  end do
+
+  return
+end subroutine r1mpyq
+subroutine r1updt ( m, n, s, ls, u, v, w, sing )
+
+!*****************************************************************************80
+!
+!! R1UPDT re-triangularizes a matrix after a rank one update.
+!
+!  Discussion:
+!
+!    Given an M by N lower trapezoidal matrix S, an M-vector U, and an
+!    N-vector V, the problem is to determine an orthogonal matrix Q such that
+!
+!      (S + U * V' ) * Q
+!
+!    is again lower trapezoidal.
+!
+!    This subroutine determines Q as the product of 2 * (N - 1)
+!    transformations
+!
+!      GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
+!
+!    where GV(I), GW(I) are Givens rotations in the (I,N) plane
+!    which eliminate elements in the I-th and N-th planes,
+!    respectively.  Q itself is not accumulated, rather the
+!    information to recover the GV and GW rotations is returned.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) M, the number of rows of S.
+!
+!    Input, integer ( kind = 4 ) N, the number of columns of S.  
+!    N must not exceed M.
+!
+!    Input/output, real ( kind = 8 ) S(LS).  On input, the lower trapezoidal
+!    matrix S stored by columns.  On output S contains the lower trapezoidal
+!    matrix produced as described above.
+!
+!    Input, integer ( kind = 4 ) LS, the length of the S array.  LS must be at
+!    least (N*(2*M-N+1))/2.
+!
+!    Input, real ( kind = 8 ) U(M), the U vector.
+!
+!    Input/output, real ( kind = 8 ) V(N).  On input, V must contain the 
+!    vector V.  On output V contains the information necessary to recover the
+!    Givens rotations GV described above.
+!
+!    Output, real ( kind = 8 ) W(M), contains information necessary to
+!    recover the Givens rotations GW described above.
+!
+!    Output, logical SING, is set to TRUE if any of the diagonal elements
+!    of the output S are zero.  Otherwise SING is set FALSE.
+!
+  implicit none
+
+  integer ( kind = 4 ) ls
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) cos
+  real ( kind = 8 ) cotan
+  real ( kind = 8 ) giant
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) jj
+  integer ( kind = 4 ) l
+  real ( kind = 8 ) s(ls)
+  real ( kind = 8 ) sin
+  logical sing
+  real ( kind = 8 ) tan
+  real ( kind = 8 ) tau
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) u(m)
+  real ( kind = 8 ) v(n)
+  real ( kind = 8 ) w(m)
+!
+!  GIANT is the largest magnitude.
+!
+  giant = huge ( giant )
+!
+!  Initialize the diagonal element pointer.
+!
+  jj = ( n * ( 2 * m - n + 1 ) ) / 2 - ( m - n )
+!
+!  Move the nontrivial part of the last column of S into W.
+!
+  l = jj
+  do i = n, m
+    w(i) = s(l)
+    l = l + 1
+  end do
+!
+!  Rotate the vector V into a multiple of the N-th unit vector
+!  in such a way that a spike is introduced into W.
+!
+  do j = n-1, 1, -1
+
+    jj = jj - ( m - j + 1 )
+    w(j) = 0.0D+00
+
+    if ( v(j) /= 0.0D+00 ) then
+!
+!  Determine a Givens rotation which eliminates the
+!  J-th element of V.
+!
+      if ( abs ( v(n) ) < abs ( v(j) ) ) then
+        cotan = v(n) / v(j)
+        sin = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * cotan**2 )
+        cos = sin * cotan
+        tau = 1.0D+00
+        if ( abs ( cos ) * giant > 1.0D+00 ) then
+          tau = 1.0D+00 / cos
+        end if
+      else
+        tan = v(j) / v(n)
+        cos = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * tan**2 )
+        sin = cos * tan
+        tau = sin
+      end if
+!
+!  Apply the transformation to V and store the information
+!  necessary to recover the Givens rotation.
+!
+      v(n) = sin * v(j) + cos * v(n)
+      v(j) = tau
+!
+!  Apply the transformation to S and extend the spike in W.
+!
+      l = jj
+      do i = j, m
+        temp = cos * s(l) - sin * w(i)
+        w(i) = sin * s(l) + cos * w(i)
+        s(l) = temp
+        l = l + 1
+      end do
+
+    end if
+
+  end do
+!
+!  Add the spike from the rank 1 update to W.
+!
+   w(1:m) = w(1:m) + v(n) * u(1:m)
+!
+!  Eliminate the spike.
+!
+  sing = .false.
+
+  do j = 1, n-1
+
+    if ( w(j) /= 0.0D+00 ) then
+!
+!  Determine a Givens rotation which eliminates the
+!  J-th element of the spike.
+!
+      if ( abs ( s(jj) ) < abs ( w(j) ) ) then
+
+        cotan = s(jj) / w(j)
+        sin = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * cotan**2 )
+        cos = sin * cotan
+
+        if ( 1.0D+00 < abs ( cos ) * giant ) then
+          tau = 1.0D+00 / cos
+        else
+          tau = 1.0D+00
+        end if
+
+      else
+
+        tan = w(j) / s(jj)
+        cos = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * tan**2 )
+        sin = cos * tan
+        tau = sin
+
+      end if
+!
+!  Apply the transformation to S and reduce the spike in W.
+!
+      l = jj
+      do i = j, m
+        temp = cos * s(l) + sin * w(i)
+        w(i) = - sin * s(l) + cos * w(i)
+        s(l) = temp
+        l = l + 1
+      end do
+!
+!  Store the information necessary to recover the Givens rotation.
+!
+      w(j) = tau
+
+    end if
+!
+!  Test for zero diagonal elements in the output S.
+!
+    if ( s(jj) == 0.0D+00 ) then
+      sing = .true.
+    end if
+
+    jj = jj + ( m - j + 1 )
+
+  end do
+!
+!  Move W back into the last column of the output S.
+!
+  l = jj
+  do i = n, m
+    s(l) = w(i)
+    l = l + 1
+  end do
+
+  if ( s(jj) == 0.0D+00 ) then
+    sing = .true.
+  end if
+
+  return
+end subroutine r1updt
+subroutine r8vec_print ( n, a, title )
+
+!*****************************************************************************80
+!
+!! R8VEC_PRINT prints an R8VEC.
+!
+!  Discussion:
+!
+!    An R8VEC is a vector of R8's.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    22 August 2000
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the number of components of the vector.
+!
+!    Input, real ( kind = 8 ) A(N), the vector to be printed.
+!
+!    Input, character ( len = * ) TITLE, a title.
+!
+  implicit none
+
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) a(n)
+  integer ( kind = 4 ) i
+  character ( len = * ) title
+
+  write ( *, '(a)' ) ' '
+  write ( *, '(a)' ) trim ( title )
+  write ( *, '(a)' ) ' '
+  do i = 1, n
+    write ( *, '(2x,i8,2x,g16.8)' ) i, a(i)
+  end do
+
+  return
+end subroutine r8vec_print
+subroutine rwupdt ( n, r, ldr, w, b, alpha, c, s )
+
+!*****************************************************************************80
+!
+!! RWUPDT computes the decomposition of triangular matrix augmented by one row.
+!
+!  Discussion:
+!
+!    Given an N by N upper triangular matrix R, this subroutine
+!    computes the QR decomposition of the matrix formed when a row
+!    is added to R.  If the row is specified by the vector W, then
+!    RWUPDT determines an orthogonal matrix Q such that when the
+!    N+1 by N matrix composed of R augmented by W is premultiplied
+!    by Q', the resulting matrix is upper trapezoidal.
+!    The matrix Q' is the product of N transformations
+!
+!      G(N)*G(N-1)* ... *G(1)
+!
+!    where G(I) is a Givens rotation in the (I,N+1) plane which eliminates
+!    elements in the (N+1)-st plane.  RWUPDT also computes the product
+!    Q'*C where C is the (N+1)-vector (B,ALPHA).  Q itself is not
+!    accumulated, rather the information to recover the G rotations is
+!    supplied.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    06 April 2010
+!
+!  Author:
+!
+!    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    Jorge More, Burton Garbow, Kenneth Hillstrom,
+!    User Guide for MINPACK-1,
+!    Technical Report ANL-80-74,
+!    Argonne National Laboratory, 1980.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the order of R.
+!
+!    Input/output, real ( kind = 8 ) R(LDR,N).  On input the upper triangular
+!    part of R must contain the matrix to be updated.  On output R contains the
+!    updated triangular matrix.
+!
+!    Input, integer ( kind = 4 ) LDR, the leading dimension of the array R.
+!    LDR must not be less than N.
+!
+!    Input, real ( kind = 8 ) W(N), the row vector to be added to R.
+!
+!    Input/output, real ( kind = 8 ) B(N).  On input, the first N elements
+!    of the vector C.  On output the first N elements of the vector Q'*C.
+!
+!    Input/output, real ( kind = 8 ) ALPHA.  On input, the (N+1)-st element
+!    of the vector C.  On output the (N+1)-st element of the vector Q'*C.
+!
+!    Output, real ( kind = 8 ) C(N), S(N), the cosines and sines of the
+!    transforming Givens rotations.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldr
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) alpha
+  real ( kind = 8 ) b(n)
+  real ( kind = 8 ) c(n)
+  real ( kind = 8 ) cotan
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) j
+  real ( kind = 8 ) r(ldr,n)
+  real ( kind = 8 ) rowj
+  real ( kind = 8 ) s(n)
+  real ( kind = 8 ) tan
+  real ( kind = 8 ) temp
+  real ( kind = 8 ) w(n)
+
+  do j = 1, n
+
+    rowj = w(j)
+!
+!  Apply the previous transformations to R(I,J), I=1,2,...,J-1, and to W(J).
+!
+    do i = 1, j - 1
+      temp =   c(i) * r(i,j) + s(i) * rowj
+      rowj = - s(i) * r(i,j) + c(i) * rowj
+      r(i,j) = temp
+    end do
+!
+!  Determine a Givens rotation which eliminates W(J).
+!
+    c(j) = 1.0D+00
+    s(j) = 0.0D+00
+
+    if ( rowj /= 0.0D+00 ) then
+
+      if ( abs ( r(j,j) ) < abs ( rowj ) ) then
+        cotan = r(j,j) / rowj
+        s(j) = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * cotan**2 )
+        c(j) = s(j) * cotan
+      else
+        tan = rowj / r(j,j)
+        c(j) = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * tan**2 )
+        s(j) = c(j) * tan
+      end if
+!
+!  Apply the current transformation to R(J,J), B(J), and ALPHA.
+!
+      r(j,j) =  c(j) * r(j,j) + s(j) * rowj
+      temp =    c(j) * b(j)   + s(j) * alpha
+      alpha = - s(j) * b(j)   + c(j) * alpha
+      b(j) = temp
+
+    end if
+
+  end do
+
+  return
+end subroutine rwupdt
+subroutine timestamp ( )
+
+!*****************************************************************************80
+!
+!! TIMESTAMP prints the current YMDHMS date as a time stamp.
+!
+!  Example:
+!
+!    31 May 2001   9:45:54.872 AM
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    18 May 2013
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    None
+!
+  implicit none
+
+  character ( len = 8 ) ampm
+  integer ( kind = 4 ) d
+  integer ( kind = 4 ) h
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) mm
+  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
+    'January  ', 'February ', 'March    ', 'April    ', &
+    'May      ', 'June     ', 'July     ', 'August   ', &
+    'September', 'October  ', 'November ', 'December ' /)
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) s
+  integer ( kind = 4 ) values(8)
+  integer ( kind = 4 ) y
+
+  call date_and_time ( values = values )
+
+  y = values(1)
+  m = values(2)
+  d = values(3)
+  h = values(5)
+  n = values(6)
+  s = values(7)
+  mm = values(8)
+
+  if ( h < 12 ) then
+    ampm = 'AM'
+  else if ( h == 12 ) then
+    if ( n == 0 .and. s == 0 ) then
+      ampm = 'Noon'
+    else
+      ampm = 'PM'
+    end if
+  else
+    h = h - 12
+    if ( h < 12 ) then
+      ampm = 'PM'
+    else if ( h == 12 ) then
+      if ( n == 0 .and. s == 0 ) then
+        ampm = 'Midnight'
+      else
+        ampm = 'AM'
+      end if
+    end if
+  end if
+
+  write ( *, '(i2.2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
+    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )
+
+  return
+end subroutine timestamp
Index: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/qsat_moisture.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/qsat_moisture.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/qsat_moisture.f90	(revision 7236)
@@ -0,0 +1,602 @@
+! =================================================================================================================================
+! MODULE 	: qsat_moisture
+!
+! CONTACT       : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE       : IPSL (2011)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         "qsat_moisture" module contains public tools functions like qsat, dev_qsat.   
+!!
+!!\n DESCRIPTION: This module is the result of the splitting of constantes_veg.\n
+!!                As the subroutines qsatcalc, dev_qsatcalc are used only by enerbil and diffuco, they are part of SECHIBA 
+!!                component. 
+!!
+!! REFERENCE(S)	: 
+!!
+!! SVN          :
+!! $HeadURL: $
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE qsat_moisture
+
+  USE defprec
+  USE constantes
+  USE IOIPSL
+
+!-
+  IMPLICIT NONE
+!-
+
+  LOGICAL,SAVE :: l_qsat_first=.TRUE.                !! First call to qsat subroutines and functions (true/false)
+!$OMP THREADPRIVATE(l_qsat_first)
+
+
+  INTEGER(i_std),PARAMETER :: max_temp=370           !! Maximum temperature for saturated humidity (K) and also used as 
+                                                     !! the size of local array to keep saturated humidity (unitless)
+
+  INTEGER(i_std),PARAMETER :: min_temp=100           !! Minimum temperature for saturated humidity (K)
+
+  REAL(r_std),DIMENSION(max_temp),SAVE :: qsfrict    !! Array to keep saturated humidity at each temperature level 
+                                                     !! (kg of water/kg of air)
+!$OMP THREADPRIVATE(qsfrict)
+
+  CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: qsatcalc
+!! 
+!>\BRIEF          This routine calculates the saturated humidity using the pressure
+!!                and the temperature for all pixels. 
+!!
+!! DESCRIPTION : This routine interpolates qsat between temperatures by the following formula :
+!!               \latexonly
+!!               \input{qsatcalc.tex}
+!!               \endlatexonly
+!!               \n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S) : qsat_out
+!!
+!! REFERENCE(S)	: None
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+
+    SUBROUTINE qsatcalc (kjpindex,temp_in,pres_in,qsat_out)
+
+      IMPLICIT NONE
+
+      !! 0. Variables and parameters declaration
+      
+      !! 0.1 Input variables
+      
+      INTEGER(i_std),INTENT(in) :: kjpindex                   !! Domain size (unitless)
+      REAL(r_std),DIMENSION(kjpindex),INTENT(in)  :: temp_in  !! Temperature in degre Kelvin (K)
+      REAL(r_std),DIMENSION(kjpindex),INTENT(in)  :: pres_in  !! Pressure (Pa)
+      
+      !! 0.2 Output variables 
+      
+      REAL(r_std),DIMENSION(kjpindex),INTENT(out) :: qsat_out !! Saturated humidity at the surface (kg of water/kg of air)
+      
+      !! 0.4 Local variables
+      
+      INTEGER(i_std)                      :: i
+      INTEGER(i_std), DIMENSION(kjpindex) :: jt               !! Temporary array stocking the truncated temperatures in Kelvin 
+                                                              !!(converted into integers)
+      INTEGER(i_std)                      :: ji               !! indices (unitless)
+      REAL(r_std),DIMENSION(kjpindex)     :: zz_a, zz_b, zz_f !! Temporary variables
+      INTEGER(i_std)                      :: nbad             !! Number of points where the temperature is too high or too low
+      INTEGER(i_std),DIMENSION(1)         :: lo               !! Temporary vector to mark the position of the highest temperature
+                                                              !! or the lowest temperature over all the pixels in jt (unitless)
+!_ ================================================================================================================================
+
+      !-
+      !! 1.Initialize qsfrict array if needed
+      !-
+      IF (l_qsat_first) THEN
+         !-
+         CALL qsfrict_init
+         l_qsat_first = .FALSE.
+         !-
+      ENDIF !(l_qsat_first)
+
+      ! DO i = 1, kjpindex
+      !    WRITE(*,*) '181113 test, in qsatcalc, i is: ', i, 'temp_in(i) is: ', temp_in(i)     
+      ! END DO ! i = 1, kjpindex
+
+      ! WRITE(*,*) 'temp_in is: ', temp_in     
+
+      !-
+      !! 2. Computes qsat interpolation into two successive temperature
+      !-
+      jt = INT(temp_in(:))
+       
+      !! 2.1 Diagnostic pixels where the temperature is too high 
+      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_p(2,'qsatcalc','diffuco', '', &
+                 &                     'temperature incorect.') ! Warning message
+         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 !(.NOT.diag_qsat)
+         !-
+      ENDIF ! (nbad > 0)
+ 
+      
+      !! 2.2 Diagnostic pixels where the temperature is too low
+      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_p(2,'qsatcalc','diffuco', '', &
+                 &                   'temperature incorect.') ! Warning message
+         ELSE
+            lo = MINLOC(temp_in(:))
+            WRITE(numout,*) &
+                 &     'Minimum temperature ( ',MINVAL(temp_in),') found at ',lo(1)
+            WHERE (jt(:) <= min_temp)   jt(:) = min_temp
+         ENDIF !(.NOT.diag_qsat)
+         !-
+      ENDIF! (nbad > 0)
+ 
+      !! 2.3 Temporary variables needed for interpolation
+      DO ji = 1, kjpindex ! Loop over # pixels
+         
+         zz_f(ji) = temp_in(ji)-FLOAT(jt(ji))
+         zz_a(ji) = qsfrict(jt(ji))
+         zz_b(ji) = qsfrict(jt(ji)+1)
+         
+      ENDDO ! Loop over # pixels
+      
+      !-
+      !! 3. Interpolation between these two values
+      !-
+      DO ji = 1, kjpindex ! Loop over # pixels
+         
+         qsat_out(ji) = ((zz_b(ji)-zz_a(ji))*zz_f(ji)+zz_a(ji))/pres_in(ji)
+         
+      ENDDO  ! Loop over # pixels
+
+
+    END SUBROUTINE qsatcalc
+ 
+!! ================================================================================================================================
+!! FUNCTION 	: [DISPENSABLE] qsat
+!!
+!>\BRIEF         This function computes deviation the saturated humidity with the pressure
+!! and the temperature for a scalar. 
+!!
+!! DESCRIPTION : This routine is obsolete : replaced by the subroutine qsatcalc. \n
+!!               qsat is interpolated by : \n
+!!               \latexonly
+!!               \input{qsat.tex}
+!!               \endlatexonly
+!!
+!! RECENT CHANGE(S): None\n
+!!
+!! RETURN VALUE : qsat_result
+!!
+!! REFERENCE(S)	: None
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================    
+
+    FUNCTION qsat (temp_in,pres_in) RESULT (qsat_result)
+
+      IMPLICIT NONE
+
+      !! 0. Variables and parameters declaration
+
+      !! 0.1 Input variables
+
+      REAL(r_std),INTENT(in) :: temp_in   !! Temperature (K)
+      REAL(r_std),INTENT(in) :: pres_in   !! Pressure    (Pa)
+
+      !! 0.2 Result
+      
+      REAL(r_std) :: qsat_result          !! Saturated humidity calculated at the surface (kg/kg)
+      
+      !! 0.4 Local variables
+      
+      INTEGER(i_std)   :: jt              !! Temporary scalar stocking the truncated temperature in Kelvin 
+                                          !! (converted into integer)
+      REAL(r_std)      :: zz_a,zz_b,zz_f  !! Temporary scalar variables      
+ 
+!_ ================================================================================================================================
+
+      !-
+      !! 1.Initialize qsfrict array if needed
+      !-
+      IF (l_qsat_first) THEN
+         !-
+         CALL qsfrict_init
+         l_qsat_first = .FALSE.
+         !-
+      ENDIF
+
+      !-
+      !! 2. Computes qsat interpolation into two successive temperatures
+      !-
+      jt = INT(temp_in)
+
+      !! 2.1 Is the temperature too high ?
+      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_p(2,'qsat','', '',&
+                 &                   'temperature incorect.') ! Warning message
+         ELSE
+            qsat_result = 999999.
+            RETURN
+         ENDIF !(.NOT.diag_qsat)
+         !-
+      ENDIF !(jt >= max_temp-1)
+
+      !! 2.2 Is the temperature too low ?
+      IF (jt <= min_temp ) THEN
+         WRITE(numout,*) &
+              &   ' We stop. temperature too SMALL : ',temp_in, &
+              &   ' approximation for : ',jt
+         !-
+         IF (.NOT.diag_qsat) THEN
+            CALL ipslerr_p(2,'qsat','', '',&
+                 &                   'temperature incorect.')
+         ELSE
+            qsat_result = -999999.
+            RETURN
+         ENDIF!(.NOT.diag_qsat)
+         !-
+      ENDIF !(jt <= min_temp )
+
+      !! 2.3 Temporary variables needed for interpolation
+      zz_f = temp_in-FLOAT(jt)
+      zz_a = qsfrict(jt)
+      zz_b = qsfrict(jt+1)
+
+      !! 3. Interpolates between these two values
+
+      qsat_result = ((zz_b-zz_a)*zz_f+zz_a)/pres_in
+
+
+    END FUNCTION qsat
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: dev_qsatcalc
+!!
+!>\BRIEF         This routine calculates the deviation of the saturated humidity qsat.
+!!
+!! DESCRIPTION : The deviation of qsat is calculated by :
+!!               \latexonly
+!!               \input{dev_qsatcalc.tex}
+!!               \endlatexonly
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S) : dev_qsat_out
+!!
+!! REFERENCE(S)	: None
+!!
+!! FLOWCHART	: None
+!!
+!! FLOWCHART    :
+!! \latexonly
+!! \includegraphics[scale = 1]{pheno_moigdd.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================ 
+
+    SUBROUTINE dev_qsatcalc (kjpindex,temp_in,pres_in,dev_qsat_out)
+
+      IMPLICIT NONE
+
+      !! 0. Variables and parameters declaration
+      
+      !! 0.1 Input variables
+
+      INTEGER(i_std),INTENT(in)                   :: kjpindex       !! Domain size (unitless)
+      REAL(r_std),DIMENSION(kjpindex),INTENT(in)  :: temp_in        !! Temperature (K)
+      REAL(r_std),DIMENSION(kjpindex),INTENT(in)  :: pres_in        !! Pressure
+
+
+      !! 0.2 Output variables 
+      
+      REAL(r_std),DIMENSION(kjpindex),INTENT(out) :: dev_qsat_out   !! Result (??units??) 
+
+      
+      !! 0.4 Local variables
+      
+      INTEGER(i_std),DIMENSION(kjpindex) :: jt                      !! Temporary array stocking the truncated temperatures
+                                                                    !! in Kelvin (converted into integers) 
+      INTEGER(i_std)                     :: ji                      !! Indice (unitless)
+      REAL(r_std),DIMENSION(kjpindex)    :: zz_a, zz_b, zz_c, zz_f  !! Temporary vector variables
+      INTEGER(i_std)                     :: nbad                    !! Number of points where the temperature is too high or too low
+
+!_ ================================================================================================================================
+
+      !-
+      !! 1.Initialize qsfrict array if needed
+      !-
+      IF (l_qsat_first) THEN
+         !-
+         CALL qsfrict_init
+         l_qsat_first = .FALSE.
+         !-
+      ENDIF
+
+      !-
+      !! 2. Compute qsat interpolation into two successive temperature
+      !-
+      jt = INT(temp_in(:)+undemi)
+      
+      !! 2.1 Pixels where the temperature is too high 
+      nbad = COUNT( jt(:) >= max_temp-1 )
+      
+
+      ! error checking code, temporary
+      DO ji = 1, kjpindex
+          IF ( jt(ji) >= max_temp-1 ) THEN
+              WRITE(numout,*) 'temperature is too high at point ', ji, ' it is: ', jt(ji)
+              ! STOP
+          END IF
+      END DO
+      
+
+
+      IF (nbad > 0) THEN
+         WRITE(numout,*) &
+              &   ' dev_qsatcalc: temperature too high at ',nbad,' points.'
+         !-
+         IF (.NOT.diag_qsat) THEN
+            CALL ipslerr_p(3,'dev_qsatcalc','', '', &
+                 &                   'temperature incorect.') ! Fatal error
+         ELSE
+            WHERE (jt(:) >= max_temp-1)   jt(:) = max_temp-1
+         ENDIF !(.NOT.diag_qsat)
+         !-
+      ENDIF !(nbad > 0)
+      
+      !! 2.2 Pixels where the temperature is too low
+      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_p(3,'dev_qsatcalc', '', '',&
+                 &                   'temperature incorect.') ! Fatal error
+         ELSE
+            WHERE (jt(:) <= min_temp)   jt(:) = min_temp
+         ENDIF !(.NOT.diag_qsat)
+         !-
+      ENDIF !(nbad > 0)
+
+      !! 2.3 Temporary variables needed for interpolation
+      DO ji=1,kjpindex  ! Loop over # pixels
+         
+         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 ! Loop over # pixels
+      
+      !-
+      !! 3. Interpolates between these two values
+      !-
+      DO ji = 1, kjpindex ! Loop over # pixels
+         
+         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 ! Loop over # pixels
+
+
+    END SUBROUTINE dev_qsatcalc
+
+!! ================================================================================================================================
+!! FUNCTION 	: [DISPENSABLE] dev_qsat
+!!
+!>\BRIEF         This function computes deviation of qsat. 
+!!
+!! DESCRIPTION : The deviation of qsat is calculated by :
+!!               \latexonly
+!!               \input{dev_qsat.tex}
+!!               \endlatexonly
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : dev_qsat_result
+!!
+!! REFERENCE(S)	: None
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+
+    FUNCTION dev_qsat (temp_in,pres_in) RESULT (dev_qsat_result)
+
+      IMPLICIT NONE
+
+      !! 0. Variables and parameters declaration 
+   
+      !! 0.1 Input variables
+
+      REAL(r_std),INTENT(in)  :: pres_in          !! Pressure (Pa)
+      REAL(r_std),INTENT(in)  :: temp_in          !! Temperture (K)
+      
+      !! 0.2 Result
+
+      REAL(r_std) :: dev_qsat_result              !! (??units??) !!
+      
+      !! 0.4 Local variables
+
+      INTEGER(i_std)  :: jt                       !! Index (unitless)
+      REAL(r_std)     :: zz_a, zz_b, zz_c, zz_f   !! Temporary scalars   
+
+!_ ================================================================================================================================
+ 
+      !-
+      !! 1.Initialize qsfrict array if needed
+      !-
+      IF (l_qsat_first) THEN
+         !-
+         CALL qsfrict_init
+         l_qsat_first = .FALSE.
+         !-
+      ENDIF
+
+      !-
+      !! 2. computes qsat deviation interpolation
+      !!    into two successive temperature
+      !-
+      jt = INT(temp_in+undemi)
+
+      !! 2.1 Is the temperature too high ?
+      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_p(3,'dev_qsat','', '',&
+                 &                   'temperature incorect.') ! Fatal error
+         ELSE
+            dev_qsat_result = 999999.
+            RETURN
+         ENDIF !(.NOT.diag_qsat)
+         !-
+      ENDIF !(jt >= max_temp-1)
+      !-
+      !! 2.2 Is the temperature too low ?
+      IF (jt <= min_temp ) THEN
+         WRITE(numout,*) &
+              &   ' We stop. temperature too LOW : ',temp_in, &
+              &   ' approximation for : ',jt
+         !-
+         IF (.NOT.diag_qsat) THEN
+            CALL ipslerr_p(3,'dev_qsat','', '',&
+                 &                    'temperature incorect.')
+         ELSE
+            dev_qsat_result = -999999.
+            RETURN
+         ENDIF !(.NOT.diag_qsat)
+         !-
+      ENDIF !(jt <= min_temp )
+
+      !! 2.3  Temporary variables for interpolation
+      zz_f = temp_in+undemi-FLOAT(jt)
+      zz_a = qsfrict(jt-1)
+      zz_b = qsfrict(jt)
+      zz_c = qsfrict(jt+1)
+
+      !-
+      !! 3. Interpolate
+      !-
+      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
+!!
+!>\BRIEF         The qsfrict_init routine initialises qsfrict array to store 
+!!               precalculated values for qsat by using Goff-Gratch equations.  
+!!
+!! DESCRIPTION : This routine calculates the specific humidity qsat as a function of temperature in 
+!!               Kelvin by using the modified Goff-Gratch equations(1946): \n
+!!               \latexonly
+!!               \input{goff_gratch.tex}
+!!               \endlatexonly
+!!               qsfrict is initialized by the following formulas : \n
+!!               \latexonly
+!!               \input{qsfrict_init.tex}
+!!               \endlatexonly
+!!               These values are used by the subroutines qsatcalc, dev_qsat. \n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::qsfrict
+!!
+!! REFERENCE(S)	:
+!! - Algorithme d'un ensemble de paramÃ©trisation physique (1998), 
+!! Note de Laurent Li dÃ©crivant les paramÃ©trisations physiques incluses dans le modÃšle (pdf),
+!! http://lmdz.lmd.jussieu.fr/developpeurs/notes-techniques 
+!! - Goff, J. A., and S. Gratch (1946) Low-pressure properties of water from â160 to 212 Â°F, in Transactions of the
+!! American Society of Heating and Ventilating Engineers, pp 95â122, presented at the 52nd annual meeting of the
+!! American Society of Heating and Ventilating Engineers, New York, 1946.
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+
+    SUBROUTINE qsfrict_init
+      
+      IMPLICIT NONE
+
+      !! 0. Variables and parameters declaration
+      
+      !! 0.4 Local variables
+
+      INTEGER(i_std) :: ji                             !! Indice(unitless)
+      REAL(r_std)    :: zrapp,zcorr,ztemperature,zqsat !! Temporary vector variables      
+
+!_ ================================================================================================================================
+
+      !! 1. Initialisation
+      zrapp = msmlr_h2o/msmlr_air
+      zcorr = 0.00320991_r_std
+      
+      !! 2. Computes saturated humidity one time and store in qsfrict local array
+      DO ji=100,max_temp ! Loop over size(qsfrict) : each position of qsfrict matches a temperature 
+         
+         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)) ! Equilibrium water vapor - solid
+         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)) ! Equilibrium water vapor - liquid
+         ENDIF !(ztemperature < 273._r_std)
+         !-
+         qsfrict (ji) = zqsat
+         
+      ENDDO ! Loop over size(qsfrict) 
+
+      !! 3. Set to zero the non-computed values
+      qsfrict(1:100) = zero 
+      !-
+      IF (long_print) WRITE (numout,*) ' qsfrict_init done'
+
+
+    END SUBROUTINE qsfrict_init
+
+
+END MODULE qsat_moisture
Index: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/routing.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/routing.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/routing.f90	(revision 7236)
@@ -0,0 +1,8048 @@
+! =================================================================================================================================
+! MODULE       : routing
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       This module routes the water over the continents into the oceans and computes the water
+!!             stored in floodplains or taken for irrigation.
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	:
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+! 
+!
+! 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
+!
+
+
+MODULE routing
+  !
+  !
+  ! routines called : restput, restget
+  !
+  USE ioipsl   
+  USE xios_orchidee
+  USE ioipsl_para 
+  USE constantes
+  USE constantes_soil
+  USE pft_parameters
+  USE sechiba_io
+  USE interpol_help
+  USE grid
+  USE mod_orchidee_para
+
+  !
+  IMPLICIT NONE
+  !
+  ! public routines :
+  !
+  PRIVATE
+  PUBLIC :: routing_main, routing_clear
+  !
+  ! variables used inside hydrol module : declaration and initialisation
+  !
+  LOGICAL, SAVE                                              :: l_first_routing=.TRUE.      !! Logical to initialize the routine. Initialisation has to be done one time (true/false)
+!$OMP THREADPRIVATE(l_first_routing)
+
+  !
+!! PARAMETERS
+  INTEGER(i_std), PARAMETER                                  :: nbasmax=7                   !! The maximum number of basins we wish to have per grid box (truncation of the model) (unitless)
+  INTEGER(i_std), SAVE                                       :: nbvmax                      !! The maximum number of basins we can handle at any time during the generation of the maps (unitless)
+!$OMP THREADPRIVATE(nbvmax)
+  !
+  REAL(r_std), PARAMETER                                     :: slow_tcst_cwrr = 25.0        !! Property of the slow reservoir, when CWRR hydrology is activated (day/m)
+  REAL(r_std), PARAMETER                                     :: fast_tcst_cwrr = 3.0        !! Property of the fast reservoir, when CWRR hydrology is activated (day/m)
+  REAL(r_std), PARAMETER                                     :: stream_tcst_cwrr = 0.24     !! Property of the stream reservoir, when CWRR hydrology is activated (day/m)
+  REAL(r_std), PARAMETER                                     :: flood_tcst_cwrr = 4.0       !! Property of the floodplains reservoir, when CWRR hydrology is activated (day/m)
+  REAL(r_std), PARAMETER                                     :: swamp_cst_cwrr = 0.2        !! Fraction of the river transport that flows to the swamps, when CWRR hydrology is activated (unitless;0-1)
+  !
+  REAL(r_std), PARAMETER                                     :: slow_tcst_chois = 25.0      !! Property of the slow reservoir, when Choisnel hydrology is activated (day/m)
+  REAL(r_std), PARAMETER                                     :: fast_tcst_chois = 3.0       !! Property of the fast reservoir, when Choisnel hydrology is activated (day/m)
+  REAL(r_std), PARAMETER                                     :: stream_tcst_chois = 0.24    !! Property of the stream reservoir, when Choisnel hydrology is activated (day/m)
+  REAL(r_std), PARAMETER                                     :: flood_tcst_chois = 4.0      !! Property of the floodplains reservoir, when Choisnel hydrology is activated (day/m)
+  REAL(r_std), PARAMETER                                     :: swamp_cst_chois = 0.2       !! Fraction of the river transport that flows to the swamps, when Choisnel hydrology is activated (unitless;0-1)
+  !
+  REAL(r_std), SAVE                                          :: fast_tcst                   !! Property of the fast reservoir, (day/m)
+!$OMP THREADPRIVATE(fast_tcst)
+  REAL(r_std), SAVE                                          :: slow_tcst                   !! Property of the slow reservoir, (day/m)
+!$OMP THREADPRIVATE(slow_tcst)
+  REAL(r_std), SAVE                                          :: stream_tcst                 !! Property of the stream reservoir, (day/m)
+!$OMP THREADPRIVATE(stream_tcst)
+  REAL(r_std), SAVE                                          :: flood_tcst                  !! Property of the floodplains reservoir, (day/m)
+!$OMP THREADPRIVATE(flood_tcst)
+  REAL(r_std), SAVE                                          :: swamp_cst                   !! Fraction of the river transport that flows to the swamps (unitless;0-1)
+!$OMP THREADPRIVATE(swamp_cst)
+  !
+  !  Relation between volume and fraction of floodplains
+  !
+  REAL(r_std), SAVE                                          :: beta = 2.0                  !! Parameter to fix the shape of the floodplain (>1 for convex edges, <1 for concave edges) (unitless)
+!$OMP THREADPRIVATE(beta)
+  REAL(r_std), SAVE                                          :: betap = 0.5                 !! Ratio of the basin surface intercepted by ponds and the maximum surface of ponds (unitless;0-1)
+!$OMP THREADPRIVATE(betap)
+  REAL(r_std), SAVE                                          :: floodcri = 2000.0           !! Potential height for which all the basin is flooded (mm)
+!$OMP THREADPRIVATE(floodcri)
+  !
+  !  Relation between maximum surface of ponds and basin surface, and drainage (mm/j) to the slow_res
+  !
+  REAL(r_std), PARAMETER                                     :: pond_bas = 50.0             !! [DISPENSABLE] - not used
+  REAL(r_std), SAVE                                          :: pondcri = 2000.0            !! Potential height for which all the basin is a pond (mm)
+!$OMP THREADPRIVATE(pondcri)
+  !
+  REAL(r_std), PARAMETER                                     :: maxevap_lake = 7.5/86400.   !! Maximum evaporation rate from lakes (kg/m^2/s)
+  !
+  REAL(r_std),SAVE                                           :: dt_routing                  !! Routing time step (s)
+!$OMP THREADPRIVATE(dt_routing)
+  !
+  INTEGER(i_std), SAVE                                       :: diagunit = 87               !! Diagnostic file unit (unitless)
+!$OMP THREADPRIVATE(diagunit)
+  !
+  ! Logicals to control model configuration
+  !
+  LOGICAL, SAVE                                              :: doirrigation = .FALSE.      !! Logical to choose if irrigation is activated or not (true/false)
+!$OMP THREADPRIVATE(doirrigation)
+  LOGICAL, SAVE                                              :: dofloodplains = .FALSE.     !! Logical to choose if floodplains are activated or not (true/false)
+!$OMP THREADPRIVATE(dofloodplains)
+  LOGICAL, SAVE                                              :: dofloodinfilt = .FALSE.     !! Logical to choose if floodplains infiltration is activated or not (true/false)
+!$OMP THREADPRIVATE(dofloodinfilt)
+  LOGICAL, SAVE                                              :: doswamps = .FALSE.          !! Logical to choose if swamps are activated or not (true/false)
+!$OMP THREADPRIVATE(doswamps)
+  LOGICAL, SAVE                                              :: doponds = .FALSE.           !! Logical to choose if ponds are activated or not (true/false)
+!$OMP THREADPRIVATE(doponds)
+  !
+  ! The variables describing the basins and their routing, need to be in the restart file.
+  !
+  INTEGER(i_std), SAVE                                       :: num_largest                 !! Number of largest river basins which should be treated as independently as rivers
+                                                                                            !! (not flow into ocean as diffusion coastal flow) (unitless)
+!$OMP THREADPRIVATE(num_largest)
+  REAL(r_std), SAVE                                          :: time_counter                !! Time counter (s)
+!$OMP THREADPRIVATE(time_counter)
+  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)     :: routing_area_loc            !! Surface of basin (m^2)
+!$OMP THREADPRIVATE(routing_area_loc)
+  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)     :: topo_resid_loc              !! Topographic index of the retention time (m)
+!$OMP THREADPRIVATE(topo_resid_loc)
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_togrid_loc            !! Grid into which the basin flows (unitless)
+!$OMP THREADPRIVATE(route_togrid_loc)
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_tobasin_loc           !! Basin in to which the water goes (unitless)
+!$OMP THREADPRIVATE(route_tobasin_loc)
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_nbintobas_loc         !! Number of basin into current one (unitless)
+!$OMP THREADPRIVATE(route_nbintobas_loc)
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: global_basinid_loc          !! ID of basin (unitless)
+!$OMP THREADPRIVATE(global_basinid_loc)
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: hydrodiag_loc               !! Variable to diagnose the hydrographs
+!$OMP THREADPRIVATE(hydrodiag_loc)
+  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:)       :: hydroupbasin_loc            !! The area upstream of the gauging station (m^2)
+!$OMP THREADPRIVATE(hydroupbasin_loc)
+  !
+  ! parallelism
+  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)     :: routing_area_glo            !! Surface of basin (m^2)
+!$OMP THREADPRIVATE(routing_area_glo)
+  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)     :: topo_resid_glo              !! Topographic index of the retention time (m)
+!$OMP THREADPRIVATE(topo_resid_glo)
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_togrid_glo            !! Grid into which the basin flows (unitless)
+!$OMP THREADPRIVATE(route_togrid_glo)
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_tobasin_glo           !! Basin in to which the water goes (unitless)
+!$OMP THREADPRIVATE(route_tobasin_glo)
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_nbintobas_glo         !! Number of basin into current one (unitless)
+!$OMP THREADPRIVATE(route_nbintobas_glo)
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: global_basinid_glo          !! ID of basin (unitless)
+!$OMP THREADPRIVATE(global_basinid_glo)
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: hydrodiag_glo               !! Variable to diagnose the hydrographs
+!$OMP THREADPRIVATE(hydrodiag_glo)
+  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:)       :: hydroupbasin_glo            !! The area upstream of the gauging station (m^2)
+!$OMP THREADPRIVATE(hydroupbasin_glo)
+  !
+  REAL(r_std), SAVE, POINTER, DIMENSION(:,:)                 :: routing_area                !! Surface of basin (m^2)
+!$OMP THREADPRIVATE(routing_area)
+  REAL(r_std), SAVE, POINTER, DIMENSION(:,:)                 :: topo_resid                  !! Topographic index of the retention time (m)
+!$OMP THREADPRIVATE(topo_resid)
+  INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:)              :: route_togrid                !! Grid into which the basin flows (unitless)
+!$OMP THREADPRIVATE(route_togrid)
+  INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:)              :: route_tobasin               !! Basin in to which the water goes (unitless)
+!$OMP THREADPRIVATE(route_tobasin)
+  INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:)              :: route_nbintobas             !! Number of basin into current one (unitless)
+!$OMP THREADPRIVATE(route_nbintobas)
+  INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:)              :: global_basinid              !! ID of basin (unitless)
+!$OMP THREADPRIVATE(global_basinid)
+  INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:)              :: hydrodiag                   !! Variable to diagnose the hydrographs
+!$OMP THREADPRIVATE(hydrodiag)
+  REAL(r_std), SAVE, POINTER, DIMENSION(:)                   :: hydroupbasin                !! The area upstream of the gauging station (m^2)
+!$OMP THREADPRIVATE(hydroupbasin)
+  !
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: irrigated                   !! Area equipped for irrigation in each grid box (m^2)
+!$OMP THREADPRIVATE(irrigated)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: floodplains                 !! Maximal surface which can be inundated in each grid box (m^2)
+!$OMP THREADPRIVATE(floodplains)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: swamp                       !! Maximal surface of swamps in each grid box (m^2)
+!$OMP THREADPRIVATE(swamp)
+  !
+  ! The reservoirs, also to be put into the restart file.
+  !
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:)             :: fast_reservoir              !! Water amount in the fast reservoir (kg)
+!$OMP THREADPRIVATE(fast_reservoir)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:)             :: slow_reservoir              !! Water amount in the slow reservoir (kg)
+!$OMP THREADPRIVATE(slow_reservoir)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:)             :: stream_reservoir            !! Water amount in the stream reservoir (kg)
+!$OMP THREADPRIVATE(stream_reservoir)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:)             :: flood_reservoir             !! Water amount in the floodplains reservoir (kg)
+!$OMP THREADPRIVATE(flood_reservoir)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: lake_reservoir              !! Water amount in the lake reservoir (kg)
+!$OMP THREADPRIVATE(lake_reservoir)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: pond_reservoir              !! Water amount in the pond reservoir (kg)
+!$OMP THREADPRIVATE(pond_reservoir)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:)             :: flood_frac_bas              !! Flooded fraction per basin (unitless;0-1)
+!$OMP THREADPRIVATE(flood_frac_bas)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: pond_frac                   !! Pond fraction per grid box (unitless;0-1)
+!$OMP THREADPRIVATE(pond_frac)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: flood_height                !! Floodplain height (mm)
+!$OMP THREADPRIVATE(flood_height)
+  !
+  ! The accumulated fluxes.
+  !
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: floodout_mean               !! Accumulated flow out of floodplains (kg/m^2/dt)
+!$OMP THREADPRIVATE(floodout_mean)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: runoff_mean                 !! Accumulated runoff (kg/m^2/dt)
+!$OMP THREADPRIVATE(runoff_mean)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: drainage_mean               !! Accumulated drainage (kg/m^2/dt)
+!$OMP THREADPRIVATE(drainage_mean)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: transpot_mean               !! Mean potential transpiration from the plants (kg/m^2/dt)
+!$OMP THREADPRIVATE(transpot_mean)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: precip_mean                 !! Accumulated precipitation (kg/m^2/dt)
+!$OMP THREADPRIVATE(precip_mean)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: humrel_mean                 !! Mean soil moisture stress, mean root extraction potential (unitless)
+!$OMP THREADPRIVATE(humrel_mean)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: totnobio_mean               !! Mean last total fraction of no bio (unitless;0-1)
+!$OMP THREADPRIVATE(totnobio_mean)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: vegtot_mean                 !! Mean potentially vegetated fraction (unitless;0-1)
+!$OMP THREADPRIVATE(vegtot_mean)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: k_litt_mean                 !! Mean averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
+!$OMP THREADPRIVATE(k_litt_mean)
+  !
+  ! The averaged outflow fluxes.
+  !
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: lakeinflow_mean              !! Mean lake inflow (kg/m^2/dt)
+!$OMP THREADPRIVATE(lakeinflow_mean)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: returnflow_mean              !! Mean water flow from lakes and swamps which returns to the grid box.
+                                                                                             !! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
+!$OMP THREADPRIVATE(returnflow_mean)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: reinfiltration_mean          !! Mean water flow which returns to the grid box (kg/m^2/dt)
+!$OMP THREADPRIVATE(reinfiltration_mean)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: irrigation_mean              !! Mean irrigation flux.
+                                                                                             !! This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt)
+!$OMP THREADPRIVATE(irrigation_mean)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: riverflow_mean               !! Mean Outflow of the major rivers.
+                                                                                             !! The flux will be located on the continental grid but this should be a coastal point (kg/dt)
+!$OMP THREADPRIVATE(riverflow_mean)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: coastalflow_mean             !! Mean outflow on coastal points by small basins.
+                                                                                             !! This is the water which flows in a disperse way into the ocean (kg/dt)
+!$OMP THREADPRIVATE(coastalflow_mean)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: floodtemp                    !! Temperature to decide if floodplains work (K)
+!$OMP THREADPRIVATE(floodtemp)
+  INTEGER(i_std), SAVE                                       :: floodtemp_lev                !! Temperature level to decide if floodplains work (K)
+!$OMP THREADPRIVATE(floodtemp_lev)
+  !
+  ! Diagnostic variables ... well sort of !
+  !
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: irrig_netereq                !! Irrigation requirement (water requirements by the crop for its optimal growth (kg/m^2/dt)
+!$OMP THREADPRIVATE(irrig_netereq)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: hydrographs                  !! Hydrographs at the outflow of the grid box for major basins (kg/dt)
+!$OMP THREADPRIVATE(hydrographs)
+  !
+  ! Diagnostics for the various reservoirs we use (Kg/m^2)
+  !
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: fast_diag                    !! Diagnostic for the fast reservoir (kg/m^2)
+!$OMP THREADPRIVATE(fast_diag)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: slow_diag                    !! Diagnostic for the slow reservoir (kg/m^2)
+!$OMP THREADPRIVATE(slow_diag)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: stream_diag                  !! Diagnostic for the stream reservoir (kg/m^2)
+!$OMP THREADPRIVATE(stream_diag)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: flood_diag                   !! Diagnostic for the floodplain reservoir (kg/m^2)
+!$OMP THREADPRIVATE(flood_diag)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: pond_diag                    !! Diagnostic for the pond reservoir (kg/m^2)
+!$OMP THREADPRIVATE(pond_diag)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: lake_diag                    !! Diagnostic for the lake reservoir (kg/m^2)
+!$OMP THREADPRIVATE(lake_diag)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: delsurfstor                  !! Diagnostic of the change in surface water storage (flood, pond and lake reservoirs) (kg/m^2)
+!$OMP THREADPRIVATE(delsurfstor)
+  !
+CONTAINS
+  !
+
+!! ================================================================================================================================
+!! SUBROUTINE   : routing_main 
+!!
+!>\BRIEF          This module routes the water over the continents (runoff and
+!!                drainage produced by the hydrolc or hydrol module) into the oceans. 
+!!
+!! DESCRIPTION (definitions, functional, design, flags):
+!! The routing scheme (Polcher, 2003) carries the water from the runoff and drainage simulated by SECHIBA
+!! to the ocean through reservoirs, with some delay. The routing scheme is based on
+!! a parametrization of the water flow on a global scale (Miller et al., 1994; Hagemann
+!! and Dumenil, 1998). Given the global map of the main watersheds (Oki et al., 1999;
+!! Fekete et al., 1999; Vorosmarty et al., 2000) which delineates the boundaries of subbasins
+!! and gives the eight possible directions of water flow within the pixel, the surface
+!! runoff and the deep drainage are routed to the ocean. The time-step of the routing is one day.
+!! The scheme also diagnoses how much water is retained in the foodplains and thus return to soil
+!! moisture or is taken out of the rivers for irrigation. \n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!! 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 of 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 reservoir and is being put into the upper 
+!!                 layers of the soil.
+!! The two first fluxes are in kg/dt and the last two fluxes are in kg/(m^2dt).\n
+!!
+!! REFERENCE(S) :
+!! - Miller JR, Russell GL, Caliri G (1994)
+!!   Continental-scale river flow in climate models.
+!!   J. Clim., 7:914-928
+!! - Hagemann S and Dumenil L. (1998)
+!!   A parametrization of the lateral waterflow for the global scale.
+!!   Clim. Dyn., 14:17-31
+!! - Oki, T., T. Nishimura, and P. Dirmeyer (1999)
+!!   Assessment of annual runoff from land surface models using total runoff integrating pathways (TRIP)
+!!   J. Meteorol. Soc. Jpn., 77, 235-255
+!! - Fekete BM, Charles V, Grabs W (2000)
+!!   Global, composite runoff fields based on observed river discharge and simulated water balances.
+!!   Technical report, UNH/GRDC, Global Runoff Data Centre, Koblenz
+!! - Vorosmarty, C., B. Fekete, B. Meybeck, and R. Lammers (2000)
+!!   Global system of rivers: Its role in organizing continental land mass and defining land-to-ocean linkages
+!!   Global Biogeochem. Cycles, 14, 599-621
+!! - Vivant, A-C. (?? 2002)
+!!   DÃ©veloppement du schÃ©ma de routage et des plaines d'inondation, MSc Thesis, Paris VI University
+!! - J. Polcher (2003)
+!!   Les processus de surface a l'echelle globale et leurs interactions avec l'atmosphere
+!!   Habilitation a diriger les recherches, Paris VI University, 67pp.
+!!
+!! FLOWCHART    :
+!! \latexonly 
+!! \includegraphics[scale=0.75]{routing_main_flowchart.png}
+!! \endlatexonly
+!! \n
+! <JR19012> Could there be more labels on the picture to make it clear what does V_1, V_2 etc correspond to?
+!_ ================================================================================================================================
+
+SUBROUTINE routing_main(kjit, nbpt, dtradia, control_flags, ldrestart_read, ldrestart_write, index, &
+       & lalo, neighbours, resolution, contfrac, totfrac_nobio, veget_max, floodout, runoff, &
+       & drainage, transpot, precip_rain, humrel, k_litt, flood_frac, flood_res, &
+       & stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
+    !
+    IMPLICIT NONE
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT(in)     :: kjit                 !! Time step number (unitless)
+    INTEGER(i_std), INTENT(in)     :: nbpt                 !! Domain size (unitless)
+    INTEGER(i_std),INTENT(in)      :: rest_id              !! Restart file identifier (unitless)
+    INTEGER(i_std),INTENT(in)      :: hist_id              !! Access to history file (unitless)
+    INTEGER(i_std),INTENT(in)      :: hist2_id             !! Access to history file 2 (unitless)
+    REAL(r_std), INTENT(in)        :: dtradia              !! Time step of the model (s)
+    TYPE(control_type), INTENT(in) :: control_flags        !! Flags that (de)activate parts of the model (unitless)
+    LOGICAL, INTENT(in)            :: ldrestart_read       !! Logical for _restart_ file to read (true/false)
+    LOGICAL, INTENT(in)            :: ldrestart_write      !! Logical for _restart_ file to write (true/false)
+    INTEGER(i_std), INTENT(in)     :: index(nbpt)          !! Indices of the points on the map (unitless)
+    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) (unitless)
+    REAL(r_std), INTENT(in)        :: resolution(nbpt,2)   !! The size of each grid box in X and Y (m)
+    REAL(r_std), INTENT(in)        :: contfrac(nbpt)       !! Fraction of land in each grid box (unitless;0-1)
+    REAL(r_std), INTENT(in)        :: totfrac_nobio(nbpt)  !! Total fraction of no-vegetation (continental ice, lakes ...) (unitless;0-1)
+    REAL(r_std), INTENT(in)        :: veget_max(nbpt,nvm)  !! Maximal fraction of vegetation (unitless;0-1)
+    REAL(r_std), INTENT(in)        :: floodout(nbpt)       !! Grid-point flow out of floodplains (kg/m^2/dt)
+    REAL(r_std), INTENT(in)        :: runoff(nbpt)         !! Grid-point runoff (kg/m^2/dt)
+    REAL(r_std), INTENT(in)        :: drainage(nbpt)       !! Grid-point drainage (kg/m^2/dt)
+    REAL(r_std), INTENT(in)        :: transpot(nbpt,nvm)   !! Potential transpiration of the vegetation (kg/m^2/dt)
+    REAL(r_std), INTENT(in)        :: precip_rain(nbpt)    !! Rainfall (kg/m^2/dt)
+    REAL(r_std), INTENT(in)        :: k_litt(nbpt)         !! Averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
+    REAL(r_std), INTENT(in)        :: humrel(nbpt,nvm)     !! Soil moisture stress, root extraction potential (unitless)
+    REAL(r_std), INTENT(in)        :: stempdiag(nbpt,nbdl) !! Diagnostic soil temperature profile
+    REAL(r_std), INTENT(in)        :: reinf_slope(nbpt)    !! Coefficient which determines the reinfiltration ratio in the grid box due to flat areas (unitless;0-1)
+    !
+!! OUTPUT VARIABLES
+    REAL(r_std), INTENT(out)       :: returnflow(nbpt)     !! The water flow from lakes and swamps which returns to the grid box.
+                                                           !! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
+    REAL(r_std), INTENT(out)       :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
+    REAL(r_std), INTENT(out)       :: irrigation(nbpt)     !! Irrigation flux. This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt)
+    REAL(r_std), INTENT(out)       :: riverflow(nbpt)      !! Outflow of the major rivers. The flux will be located on the continental grid but this should be a coastal point (kg/dt)
+    REAL(r_std), INTENT(out)       :: coastalflow(nbpt)    !! Outflow on coastal points by small basins. This is the water which flows in a disperse way into the ocean (kg/dt)
+    REAL(r_std), INTENT(out)       :: flood_frac(nbpt)     !! Flooded fraction of the grid box (unitless;0-1)
+    REAL(r_std), INTENT(out)       :: flood_res(nbpt)      !! Diagnostic of water amount in the floodplains reservoir (kg)
+    !
+!! LOCAL VARIABLES
+    CHARACTER(LEN=30)              :: var_name             !! To store variables names for I/O (unitless)
+    REAL(r_std), DIMENSION(1)      :: tmp_day              !! 
+    REAL(r_std), DIMENSION(nbpt)   :: return_lakes         !! Water from lakes flowing back into soil moisture (kg/m^2/dt)
+    INTEGER(i_std)                 :: ig, jv               !! Indices (unitless)
+    LOGICAL, SAVE                  :: init_irrig=.FALSE.   !! Logical to initialize the irrigation (true/false)
+!$OMP THREADPRIVATE(init_irrig)
+    LOGICAL, SAVE                  :: init_flood=.FALSE.   !! Logical to initialize the floodplains (true/false)
+!$OMP THREADPRIVATE(init_flood)
+    LOGICAL, SAVE                  :: init_swamp=.FALSE.   !! Logical to initialize the swamps (true/false)
+!$OMP THREADPRIVATE(init_swamp)
+    REAL(r_std), DIMENSION(nbpt)   :: tot_vegfrac_nowoody  !! Total fraction occupied by grass (0-1,unitless)
+
+!_ ================================================================================================================================
+
+    !
+    ! do initialisation
+    !
+    IF (l_first_routing) THEN
+       !
+       nbvmax = 440
+       ! 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, control_flags, dtradia, returnflow, reinfiltration, irrigation, &
+            &             riverflow, coastalflow, flood_frac, flood_res, 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 the route_togrid_glo is undefined. This means that the
+       ! map has not been initialized during the restart process..
+       !
+       !! Reads in the map of the basins and flow directions to construct the catchments of each grid box
+       !
+       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
+       !! Initialisation of flags for irrigated land, flood plains and swamps
+       !
+       IF ( doirrigation .OR. dofloodplains .OR. doswamps) 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 ( doswamps ) THEN
+             IF (COUNT(swamp .GE. undef_sechiba-1) > 0) THEN
+                init_swamp = .TRUE.
+             ENDIF
+          ENDIF
+
+          !! If we have irrigated land, flood plains or swamps then we need to interpolate the 0.5 degree
+          !! base data set to the resolution of the model.
+
+          IF ( init_irrig .OR. init_flood .OR. init_swamp ) THEN
+             CALL routing_irrigmap(nbpt, index, lalo, neighbours, resolution, &
+                 contfrac, init_irrig, irrigated, init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id)
+          ENDIF
+
+          IF ( doirrigation ) THEN 
+             CALL xios_orchidee_send_field("irrigmap",irrigated)
+
+             WRITE(numout,*) 'Verification : range of irrigated : ', MINVAL(irrigated), MAXVAL(irrigated) 
+             IF ( .NOT. almaoutput ) THEN
+                CALL histwrite_p(hist_id, 'irrigmap', 1, irrigated, nbpt, index)
+             ELSE
+                CALL histwrite_p(hist_id, 'IrrigationMap', 1, irrigated, nbpt, index)
+             ENDIF
+             IF ( hist2_id > 0 ) THEN
+                IF ( .NOT. almaoutput ) THEN
+                   CALL histwrite_p(hist2_id, 'irrigmap', 1, irrigated, nbpt, index)
+                ELSE
+                   CALL histwrite_p(hist2_id, 'IrrigationMap', 1, irrigated, nbpt, index)
+                ENDIF
+             ENDIF
+          ENDIF
+          !
+          IF ( dofloodplains ) THEN
+             CALL xios_orchidee_send_field("floodmap",floodplains)
+
+             WRITE(numout,*) 'Verification : range of floodplains : ', MINVAL(floodplains), MAXVAL(floodplains) 
+             IF ( .NOT. almaoutput ) THEN
+                CALL histwrite_p(hist_id, 'floodmap', 1, floodplains, nbpt, index)
+             ELSE
+                CALL histwrite_p(hist_id, 'FloodplainsMap', 1, floodplains, nbpt, index)
+             ENDIF
+             IF ( hist2_id > 0 ) THEN
+                IF ( .NOT. almaoutput ) THEN
+                   CALL histwrite_p(hist2_id, 'floodmap', 1, floodplains, nbpt, index)
+                ELSE
+                   CALL histwrite_p(hist2_id, 'FloodplainsMap', 1, floodplains, nbpt, index)
+                ENDIF
+             ENDIF
+          ENDIF
+          !
+          IF ( doswamps ) THEN
+             CALL xios_orchidee_send_field("swampmap",swamp)
+
+             WRITE(numout,*) 'Verification : range of swamp : ', MINVAL(swamp), MAXVAL(swamp) 
+             IF ( .NOT. almaoutput ) THEN
+                CALL histwrite_p(hist_id, 'swampmap', 1, swamp, nbpt, index)
+             ELSE
+                CALL histwrite_p(hist_id, 'SwampMap', 1, swamp, nbpt, index)
+             ENDIF
+             IF ( hist2_id > 0 ) THEN
+                IF ( .NOT. almaoutput ) THEN
+                   CALL histwrite_p(hist2_id, 'swampmap', 1, swamp, nbpt, index)
+                ELSE
+                   CALL histwrite_p(hist2_id, 'SwampMap', 1, swamp, nbpt, index)
+                ENDIF
+             ENDIF
+          ENDIF
+       ENDIF
+       !
+       !! This routine gives a diagnostic of the basins used.
+       !
+       CALL routing_diagnostic_p(nbpt, index, lalo, resolution, contfrac, hist_id, hist2_id)
+       !
+       l_first_routing = .FALSE.
+       !
+       RETURN
+       !
+    ENDIF
+    !
+    !! Computes the variables averaged between routing time steps and which will be used in subsequent calculations
+    !
+    floodout_mean(:) = floodout_mean(:) + floodout(:)
+    runoff_mean(:) = runoff_mean(:) + runoff(:)
+    drainage_mean(:) = drainage_mean(:) + drainage(:)
+    floodtemp(:) = stempdiag(:,floodtemp_lev)
+    precip_mean(:) =  precip_mean(:) + precip_rain(:)
+    !
+    !! Computes the total fraction occupied by the grasses and the crops for each grid cell
+    tot_vegfrac_nowoody(:) = zero
+    DO jv  = 1, nvm
+       IF ( (jv /= ibare_sechiba) .AND. .NOT.(is_tree(jv)) ) THEN
+          tot_vegfrac_nowoody(:) = tot_vegfrac_nowoody(:) + veget_max(:,jv) 
+       END IF
+    END DO
+
+    DO ig = 1, nbpt
+       IF ( tot_vegfrac_nowoody(ig) .GT. min_sechiba ) THEN
+          DO jv = 1,nvm
+             IF ( (jv /= ibare_sechiba) .AND. .NOT.(is_tree(jv)) ) THEN
+                transpot_mean(ig) = transpot_mean(ig) + transpot(ig,jv) * veget_max(ig,jv)/tot_vegfrac_nowoody(ig)  
+             END IF
+          END DO
+       ELSE
+          IF (MAXVAL(veget_max(ig,2:nvm)) .GT. min_sechiba) THEN
+             DO jv = 2, nvm
+                transpot_mean(ig) = transpot_mean(ig) + transpot(ig,jv) * veget_max(ig,jv)/ SUM(veget_max(ig,2:nvm))
+             ENDDO
+          ENDIF
+       ENDIF
+    ENDDO
+
+    !
+    ! Averaged variables (i.e. *dtradia/dt_routing). This accounts for the difference between the shorter
+    ! timestep dtradia of other parts of the model and the long dt_routing timestep (set to one day at present)
+    !
+    totnobio_mean(:) = totnobio_mean(:) + totfrac_nobio(:)*dtradia/dt_routing
+    k_litt_mean(:) = k_litt_mean(:) + k_litt(:)*dtradia/dt_routing
+    !
+    ! Only potentially vegetated surfaces are taken into account. At the start of
+    ! the growing seasons we will give 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., floodout_mean, runoff_mean, drainage_mean, returnflow_mean, &
+               & reinfiltration_mean, irrigation_mean, riverflow_mean, coastalflow_mean)
+       ENDIF
+       !
+       ! Make sure we do not flood north of 49N as there freezing processes start to play a role and they
+       ! are not yet well treated in ORCHIDEE.
+       !
+       DO ig=1,nbpt
+          IF ( lalo(ig,1) > 49.0 ) THEN
+             floodtemp(ig) = tp_00 - un
+          ENDIF
+       ENDDO
+       !
+       !! Computes the transport of water in the various reservoirs
+       !
+       CALL routing_flow(nbpt, dt_routing, floodout_mean, runoff_mean, drainage_mean, &
+            & vegtot_mean, totnobio_mean, transpot_mean, precip_mean, humrel_mean, k_litt_mean, floodtemp, reinf_slope, &
+            & lakeinflow_mean, returnflow_mean, reinfiltration_mean, irrigation_mean, riverflow_mean, &
+            & coastalflow_mean, hydrographs, flood_frac, flood_res)
+       !
+       !! Responsible for storing the water in lakes
+       !
+       CALL routing_lake(nbpt, dt_routing, lakeinflow_mean, humrel_mean, return_lakes)
+       !
+       returnflow_mean(:) = returnflow_mean(:) + return_lakes(:)
+       !
+       !! Check the water balance in the routing scheme
+       !
+       IF ( check_waterbal ) THEN
+          CALL routing_waterbal(nbpt, .FALSE., floodout_mean, runoff_mean, drainage_mean, returnflow_mean, &
+               & reinfiltration_mean, irrigation_mean, riverflow_mean, coastalflow_mean)
+       ENDIF
+       !
+       time_counter = zero
+       !
+       floodout_mean(:) = zero
+       runoff_mean(:) = zero
+       drainage_mean(:) = zero
+       transpot_mean(:) = zero
+       precip_mean(:) = zero
+       !
+       humrel_mean(:) = zero
+       totnobio_mean(:) = zero
+       k_litt_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
+       reinfiltration_mean(:) = reinfiltration_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(:)
+    reinfiltration(:) = reinfiltration_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 = 'floodres'
+       CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, flood_reservoir, 'scatter',  nbp_glo, index_g)
+       var_name = 'floodh'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, flood_height, 'scatter',  nbp_glo, index_g)
+       var_name = 'flood_frac_bas'
+       CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, flood_frac_bas, 'scatter',  nbp_glo, index_g)
+       var_name = 'pond_frac'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, pond_frac, 'scatter',  nbp_glo, index_g)
+       var_name = 'flood_frac'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, flood_frac, 'scatter',  nbp_glo, index_g)
+       var_name = 'flood_res'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, flood_res, '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 = 'pondres'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, pond_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 = 'reinfiltration'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, reinfiltration_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 = 'floodout_route'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, floodout_mean, 'scatter',  nbp_glo, index_g)
+       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 = 'transpot_route'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, transpot_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 = 'k_litt_route'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, k_litt_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)
+       !
+       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
+       IF ( doswamps ) THEN
+          var_name = 'swamp'
+          CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, swamp, 'scatter',  nbp_glo, index_g)
+       ENDIF
+       !
+       RETURN
+       !
+    ENDIF
+    !
+    ! Write diagnostics
+    !
+
+    CALL xios_orchidee_send_field("riversret",returnflow*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("hydrographs",hydrographs/dt_sechiba)
+    CALL xios_orchidee_send_field("reinfiltration",reinfiltration)
+    CALL xios_orchidee_send_field("fastr",fast_diag)
+    CALL xios_orchidee_send_field("slowr",slow_diag)
+    CALL xios_orchidee_send_field("streamr",stream_diag)
+    CALL xios_orchidee_send_field("lakevol",lake_diag)
+    CALL xios_orchidee_send_field("pondr",pond_diag)
+    CALL xios_orchidee_send_field("irrigation",irrigation*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("irrigation_alma",irrigation/dt_sechiba)
+    CALL xios_orchidee_send_field("netirrig",irrig_netereq*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("netirrig_alma",irrig_netereq/dt_sechiba)
+    CALL xios_orchidee_send_field("floodh",flood_height)
+    CALL xios_orchidee_send_field("floodr",flood_diag)
+    delsurfstor = delsurfstor + flood_diag + pond_diag + lake_diag
+    CALL xios_orchidee_send_field("DelSurfStor",delsurfstor)
+    CALL xios_orchidee_send_field("SurfStor",flood_diag+pond_diag+lake_diag)
+
+    IF ( .NOT. almaoutput ) THEN
+       !
+       CALL histwrite_p(hist_id, 'riversret', kjit, returnflow, nbpt, index)
+       IF (dofloodplains .OR. doponds) THEN
+          CALL histwrite_p(hist_id, 'reinfiltration', kjit, reinfiltration, nbpt, index)
+       ENDIF
+       CALL histwrite_p(hist_id, 'hydrographs', kjit, hydrographs, nbpt, index)
+       !
+       CALL histwrite_p(hist_id, 'fastr', kjit, fast_diag, nbpt, index)
+       CALL histwrite_p(hist_id, 'slowr', kjit, slow_diag, nbpt, index)
+       CALL histwrite_p(hist_id, 'streamr', kjit, stream_diag, nbpt, index)
+       IF ( dofloodplains ) THEN
+          CALL histwrite_p(hist_id, 'floodr', kjit, flood_diag, nbpt, index)
+          CALL histwrite_p(hist_id, 'floodh', kjit, flood_height, nbpt, index)
+       ENDIF
+       CALL histwrite_p(hist_id, 'pondr', kjit, pond_diag, nbpt, index)
+       CALL histwrite_p(hist_id, 'lakevol', kjit, lake_diag, nbpt, index)
+       !
+       IF ( doirrigation ) THEN
+          CALL histwrite_p(hist_id, 'irrigation', kjit, irrigation, nbpt, index)
+          CALL histwrite_p(hist_id, 'returnflow', kjit, returnflow, nbpt, index)
+          CALL histwrite_p(hist_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
+       ENDIF
+       !
+    ELSE
+       !
+       delsurfstor = delsurfstor + flood_diag + pond_diag + lake_diag
+       CALL histwrite_p(hist_id, 'DelSurfStor', kjit, delsurfstor, nbpt, index)
+       CALL histwrite_p(hist_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index)
+       CALL histwrite_p(hist_id, 'Dis', kjit, hydrographs, nbpt, index)
+       IF ( doirrigation ) THEN
+          CALL histwrite_p(hist_id, 'Qirrig', kjit, irrigation, nbpt, index)
+          CALL histwrite_p(hist_id, 'Qirrig_req', kjit, irrig_netereq, nbpt, index)
+       ENDIF
+       !
+    ENDIF
+    IF ( hist2_id > 0 ) THEN
+       IF ( .NOT. almaoutput ) THEN
+          !
+          CALL histwrite_p(hist2_id, 'riversret', kjit, returnflow, nbpt, index)
+          IF (dofloodplains .OR. doponds) THEN
+             CALL histwrite_p(hist2_id, 'reinfiltration', kjit, reinfiltration, nbpt, index)
+          ENDIF
+          CALL histwrite_p(hist2_id, 'hydrographs', kjit, hydrographs, nbpt, index)
+          !
+          CALL histwrite_p(hist2_id, 'fastr', kjit, fast_diag, nbpt, index)
+          CALL histwrite_p(hist2_id, 'slowr', kjit, slow_diag, nbpt, index)
+          IF ( dofloodplains ) THEN
+             CALL histwrite_p(hist2_id, 'floodr', kjit, flood_diag, nbpt, index)
+             CALL histwrite_p(hist2_id, 'floodh', kjit, flood_height, nbpt, index)
+          ENDIF
+          CALL histwrite_p(hist2_id, 'pondr', kjit, pond_diag, nbpt, index)
+          CALL histwrite_p(hist2_id, 'streamr', kjit, stream_diag, nbpt, index)
+          CALL histwrite_p(hist2_id, 'lakevol', kjit, lake_diag, nbpt, index)
+          !
+          IF ( doirrigation ) THEN
+             CALL histwrite_p(hist2_id, 'irrigation', kjit, irrigation, nbpt, index)
+             CALL histwrite_p(hist2_id, 'returnflow', kjit, returnflow, nbpt, index)
+             CALL histwrite_p(hist2_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
+          ENDIF
+          !
+       ELSE
+          !
+          delsurfstor=delsurfstor + flood_diag + pond_diag + lake_diag
+          CALL histwrite_p(hist2_id, 'DelSurfStor', kjit, delsurfstor, nbpt, index)
+          CALL histwrite_p(hist2_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index)
+          CALL histwrite_p(hist2_id, 'Dis', kjit, hydrographs, nbpt, index)
+          !
+       ENDIF
+    ENDIF
+    !
+    !
+  END SUBROUTINE routing_main
+  !
+!! ================================================================================================================================
+!! SUBROUTINE 	: routing_init
+!!
+!> BRIEF         This subroutine allocates the memory and get the fixed fields from the restart file.
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    :None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE routing_init(kjit, nbpt, index, control_flags, dtradia, returnflow, reinfiltration, irrigation, &
+       &                  riverflow, coastalflow, flood_frac, flood_res, stempdiag, rest_id)
+    !
+    IMPLICIT NONE
+    !
+    ! interface description
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT(in)                   :: kjit           !! Time step number (unitless)
+    INTEGER(i_std), INTENT(in)                   :: nbpt           !! Domain size (unitless)
+    INTEGER(i_std), DIMENSION (nbpt), INTENT(in) :: index          !! Indices of the points on the map (unitless)
+    TYPE(control_type), INTENT(in)               :: control_flags  !! Flags that (de)activate parts of the model (unitless)
+    REAL(r_std), INTENT(in)                      :: dtradia        !! Time step of the model (s)
+    REAL(r_std), DIMENSION(nbpt,nbdl),INTENT(in) :: stempdiag      !! Temperature profile in soil
+    INTEGER(i_std), INTENT(in)                   :: rest_id        !! Restart file identifier (unitless)
+    !
+!! OUTPUT VARIABLES
+    REAL(r_std), DIMENSION (nbpt),INTENT(out)    :: returnflow     !! The water flow from lakes and swamps which returns into the grid box.
+                                                                   !! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
+    REAL(r_std), DIMENSION (nbpt),INTENT(out)    :: reinfiltration !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
+    REAL(r_std), DIMENSION (nbpt),INTENT(out)    :: irrigation     !! Irrigation flux. This is the water taken from the reservoirs and beeing put into the upper layers of the soil.(kg/m^2/dt)
+    REAL(r_std), DIMENSION (nbpt),INTENT(out)    :: riverflow      !! Outflow of the major rivers. The flux will be located on the continental grid but this should be a coastal point (kg/dt)
+    REAL(r_std), DIMENSION (nbpt),INTENT(out)    :: coastalflow    !! Outflow on coastal points by small basins. This is the water which flows in a disperse way into the ocean (kg/dt)
+    REAL(r_std), DIMENSION (nbpt),INTENT(out)    :: flood_frac     !! Flooded fraction of the grid box (unitless;0-1)
+    REAL(r_std), DIMENSION (nbpt),INTENT(out)    :: flood_res      !! Diagnostic of water amount in the floodplains reservoir (kg)
+    !
+!! LOCAL VARIABLES
+    CHARACTER(LEN=80)                            :: var_name       !! To store variables names for I/O (unitless)
+    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          !! Diagnostic ratio to check that dt_routing is a multiple of dtradia (unitless)
+    REAL(r_std)                                  :: totarea        !! Total area of basin (m^2)
+    INTEGER(i_std)                               :: ier, ig, ib, ipn(1) !! Indices (unitless)
+    LOGICAL                                      :: hydrol_cwrr    !! Flag to select the CWRR hydrology (true/false)
+
+!_ ================================================================================================================================
+    !
+    ! Taken from overall control of model
+    !
+    hydrol_cwrr = control_flags%hydrol_cwrr
+    doirrigation = control_flags%do_irrigation
+    dofloodplains = control_flags%do_floodplains
+    !
+    !
+    ! These variables will require the configuration infrastructure
+    !
+    !Config Key   = ROUTING_TIMESTEP
+    !Config If    = RIVER_ROUTING
+    !Config Desc  = Time step of the 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.
+    !Config Units = [seconds]
+    !
+    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.
+    !Config Units = [-]
+    num_largest = 50
+    CALL getin_p('ROUTING_RIVERS', num_largest)
+    !
+    !Config Key   = DO_FLOODINFILT
+    !Config Desc  = Should floodplains reinfiltrate into the soil 
+    !Config If    = RIVER_ROUTING
+    !Config Def   = FALSE
+    !Config Help  = This parameters allows the user to ask the model
+    !Config         to take into account the flood plains reinfiltration 
+    !Config         into the soil moisture. It then can go 
+    !Config         back to the slow and fast reservoirs
+    !Config Units = [FLAG]
+    !
+    dofloodinfilt = .FALSE.
+    CALL getin_p('DO_FLOODINFILT', dofloodinfilt)
+    !
+    !Config Key   = DO_SWAMPS
+    !Config Desc  = Should we include swamp parameterization 
+    !Config If    = RIVER_ROUTING
+    !Config Def   = FALSE
+    !Config Help  = This parameters allows the user to ask the model
+    !Config         to take into account the swamps and return 
+    !Config         the water into the bottom of the soil. It then can go 
+    !Config         back to the atmopshere. This tried to simulate 
+    !Config         internal deltas of rivers.
+    !Config Units = [FLAG]
+    !
+    doswamps = .FALSE.
+    CALL getin_p('DO_SWAMPS', doswamps)
+    !
+    !Config Key   = DO_PONDS
+    !Config Desc  = Should we include ponds 
+    !Config If    = RIVER_ROUTING
+    !Config Def   = FALSE
+    !Config Help  = This parameters allows the user to ask the model
+    !Config         to take into account the ponds and return 
+    !Config         the water into the soil moisture. It then can go 
+    !Config         back to the atmopshere. This tried to simulate 
+    !Config         little ponds especially in West Africa.
+    !Config Units = [FLAG]
+    !
+    doponds = .FALSE.
+    CALL getin_p('DO_PONDS', doponds)
+    !
+    ! Fix the time constants according to hydrol_cwrr flag
+    !
+    !
+    !Config Key   = SLOW_TCST
+    !Config Desc  = Time constant for the slow reservoir 
+    !Config If    = RIVER_ROUTING 
+    !Config Def   = FALSE
+    !Config Help  = This parameters allows the user to fix the 
+    !Config         time constant (in days) of the slow reservoir
+    !Config         in order to get better river flows for 
+    !Config         particular regions.
+    !Config Units = [days]
+    !
+!> A value for property of each reservoir (in day/m) is given to compute a time constant (in day)
+!> for each reservoir (product of tcst and topo_resid).
+!> The value of tcst has been calibrated for the three reservoirs over the Senegal river basin only,
+!> during the 1 degree NCEP Corrected by Cru (NCC) resolution simulations (Ngo-Duc et al., 2005, Ngo-Duc et al., 2006) and
+!> generalized for all the basins of the world. The "slow reservoir" and the "fast reservoir"
+!> have the highest value in order to simulate the groundwater. 
+!> The "stream reservoir", which represents all the water of the stream, has the lowest value.
+!> Those figures are the same for all the basins of the world.
+!> The value of slow_tcst is equal to fast_tcst when CWRR is activated.
+!> This assumption should be re-discussed.
+    !
+    IF ( hydrol_cwrr ) THEN
+       slow_tcst = slow_tcst_cwrr
+    ELSE
+       slow_tcst = slow_tcst_chois
+    ENDIF
+    CALL getin_p('SLOW_TCST', slow_tcst)
+    !
+    !Config Key   = FAST_TCST
+    !Config Desc  = Time constant for the fast reservoir 
+    !Config If    = RIVER_ROUTING 
+    !Config Def   = FALSE
+    !Config Help  = This parameters allows the user to fix the 
+    !Config         time constant (in days) of the fast reservoir
+    !Config         in order to get better river flows for 
+    !Config         particular regions.
+    !Config Units = [days]
+    !
+    IF ( hydrol_cwrr ) THEN
+       fast_tcst = fast_tcst_cwrr
+    ELSE
+       fast_tcst = fast_tcst_chois
+    ENDIF
+    CALL getin_p('FAST_TCST', fast_tcst)
+    !
+    !Config Key   = STREAM_TCST
+    !Config Desc  = Time constant for the stream reservoir 
+    !Config If    = RIVER_ROUTING
+    !Config Def   = FALSE
+    !Config Help  = This parameters allows the user to fix the 
+    !Config         time constant (in days) of the stream reservoir
+    !Config         in order to get better river flows for 
+    !Config         particular regions.
+    !Config Units = [days]
+    !
+    IF ( hydrol_cwrr ) THEN
+       stream_tcst = stream_tcst_cwrr
+    ELSE
+       stream_tcst = stream_tcst_chois
+    ENDIF
+    CALL getin_p('STREAM_TCST', stream_tcst)
+    !
+    !Config Key   = FLOOD_TCST
+    !Config Desc  = Time constant for the flood reservoir 
+    !Config If    = RIVER_ROUTING
+    !Config Def   = 4.0
+    !Config Help  = This parameters allows the user to fix the 
+    !Config         time constant (in days) of the flood reservoir
+    !Config         in order to get better river flows for 
+    !Config         particular regions.
+    !Config Units = [days]
+    !
+    IF ( hydrol_cwrr ) THEN
+       flood_tcst = flood_tcst_cwrr
+    ELSE
+       flood_tcst = flood_tcst_chois
+    ENDIF
+    CALL getin_p('FLOOD_TCST', flood_tcst)
+    !
+    !Config Key   = SWAMP_CST
+    !Config Desc  = Fraction of the river that flows back to swamps 
+    !Config If    = RIVER_ROUTING
+    !Config Def   = 0.2
+    !Config Help  = This parameters allows the user to fix the 
+    !Config         fraction of the river transport
+    !Config         that flows to swamps
+    !Config Units = [-]
+    !
+    IF ( hydrol_cwrr ) THEN
+       swamp_cst = swamp_cst_cwrr
+    ELSE
+       swamp_cst = swamp_cst_chois
+    ENDIF
+    CALL getin_p('SWAMP_CST', swamp_cst)
+    !
+    !Config Key   = FLOOD_BETA
+    !Config Desc  = Parameter to fix the shape of the floodplain  
+    !Config If    = RIVER_ROUTING
+    !Config Def   = 2.0
+    !Config Help  = Parameter to fix the shape of the floodplain
+    !Config         (>1 for convex edges, <1 for concave edges)
+    !Config Units = [-] 
+    CALL getin_p("FLOOD_BETA", beta)
+    !
+    !Config Key   = POND_BETAP
+    !Config Desc  = Ratio of the basin surface intercepted by ponds and the maximum surface of ponds
+    !Config If    = RIVER_ROUTING
+    !Config Def   = 0.5
+    !Config Help  = 
+    !Config Units = [-] 
+    CALL getin_p("POND_BETAP", betap)    
+    !
+    !Config Key   = FLOOD_CRI
+    !Config Desc  = Potential height for which all the basin is flooded
+    !Config If    = DO_FLOODPLAINS or DO_PONDS
+    !Config Def   = 2000.
+    !Config Help  = 
+    !Config Units = [mm] 
+    CALL getin_p("FLOOD_CRI", floodcri)
+    !
+    !Config Key   = POND_CRI
+    !Config Desc  = Potential height for which all the basin is a pond
+    !Config If    = DO_FLOODPLAINS or DO_PONDS
+    !Config Def   = 2000.
+    !Config Help  = 
+    !Config Units = [mm] 
+    CALL getin_p("POND_CRI", pondcri)
+
+    !
+    !
+    ! 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.'
+       WRITE(numout,*) 'The old DT_ROUTING is : ', dt_routing
+       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)
+       IF (tmp_day(1) == val_exp) THEN
+          time_counter = zero
+       ELSE
+          time_counter = tmp_day(1) 
+       ENDIF
+       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
+    !
+    ! nbintobasin
+    !
+    ALLOCATE (route_nbintobas_loc(nbpt,nbasmax))
+    ALLOCATE (route_nbintobas_glo(nbp_glo,nbasmax))
+    IF (is_root_prc) THEN
+       var_name = 'routenbintobas'
+       CALL ioconf_setatt('UNITS', '-')
+       CALL ioconf_setatt('LONG_NAME','Number of basin into current one')
+       CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
+       route_nbintobas_glo = undef_int
+       WHERE ( tmp_real_g .LT. val_exp )
+         route_nbintobas_glo = NINT(tmp_real_g)
+      ENDWHERE
+    ENDIF
+    CALL scatter(route_nbintobas_glo,route_nbintobas_loc)
+    route_nbintobas=>route_nbintobas_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_p('UNITS', 'Kg')
+    CALL ioconf_setatt_p('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_p('UNITS', 'Kg')
+    CALL ioconf_setatt_p('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_p('UNITS', 'Kg')
+    CALL ioconf_setatt_p('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 (flood_reservoir(nbpt,nbasmax))
+    var_name = 'floodres'
+    CALL ioconf_setatt_p('UNITS', 'Kg')
+    CALL ioconf_setatt_p('LONG_NAME','Water in the flood reservoir')
+    CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_reservoir, "gather", nbp_glo, index_g)
+    CALL setvar_p (flood_reservoir, val_exp, 'NO_KEYWORD', zero)
+    !
+    ALLOCATE (flood_frac_bas(nbpt,nbasmax))
+    var_name = 'flood_frac_bas'
+    CALL ioconf_setatt_p('UNITS', '-')
+    CALL ioconf_setatt_p('LONG_NAME','Flooded fraction per basin')
+    CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_frac_bas, "gather", nbp_glo, index_g)
+    CALL setvar_p (flood_frac_bas, val_exp, 'NO_KEYWORD', zero)
+    !
+    ALLOCATE (flood_height(nbpt))
+    var_name = 'floodh'
+    CALL ioconf_setatt_p('UNITS', '-')
+    CALL ioconf_setatt_p('LONG_NAME','')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_height, "gather", nbp_glo, index_g)
+    CALL setvar_p (flood_height, val_exp, 'NO_KEYWORD', zero)
+    !
+    ALLOCATE (pond_frac(nbpt))
+    var_name = 'pond_frac'
+    CALL ioconf_setatt_p('UNITS', '-')
+    CALL ioconf_setatt_p('LONG_NAME','Pond fraction per grid box')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_frac, "gather", nbp_glo, index_g)
+    CALL setvar_p (pond_frac, val_exp, 'NO_KEYWORD', zero)
+    !
+    var_name = 'flood_frac'
+    CALL ioconf_setatt_p('UNITS', '-')
+    CALL ioconf_setatt_p('LONG_NAME','Flooded fraction per grid box')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_frac, "gather", nbp_glo, index_g)
+    CALL setvar_p (flood_frac, val_exp, 'NO_KEYWORD', zero)
+    !
+    var_name = 'flood_res'
+    CALL ioconf_setatt_p('UNITS','mm')
+    CALL ioconf_setatt_p('LONG_NAME','Flooded quantity (estimation)')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_res, "gather", nbp_glo, index_g)
+    CALL setvar_p (flood_res, val_exp, 'NO_KEYWORD', zero)
+!    flood_res = zero
+    !
+    ALLOCATE (lake_reservoir(nbpt))
+    var_name = 'lakeres'
+    CALL ioconf_setatt_p('UNITS', 'Kg')
+    CALL ioconf_setatt_p('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_p (lake_reservoir, val_exp, 'NO_KEYWORD', zero)
+    !
+    ALLOCATE (pond_reservoir(nbpt))
+    var_name = 'pondres'
+    CALL ioconf_setatt_p('UNITS', 'Kg')
+    CALL ioconf_setatt_p('LONG_NAME','Water in the pond reservoir')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_reservoir, "gather", nbp_glo, index_g)
+    CALL setvar_p (pond_reservoir, val_exp, 'NO_KEYWORD', zero)
+    !
+    ! Map of irrigated areas
+    !
+    IF ( doirrigation ) THEN
+       ALLOCATE (irrigated(nbpt))
+       var_name = 'irrigated'
+       CALL ioconf_setatt_p('UNITS', 'm^2')
+       CALL ioconf_setatt_p('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
+    !
+    IF ( dofloodplains ) THEN
+       ALLOCATE (floodplains(nbpt))
+       var_name = 'floodplains'
+       CALL ioconf_setatt_p('UNITS', 'm^2')
+       CALL ioconf_setatt_p('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
+    IF ( doswamps ) THEN
+       ALLOCATE (swamp(nbpt))
+       var_name = 'swamp'
+       CALL ioconf_setatt_p('UNITS', 'm^2')
+       CALL ioconf_setatt_p('LONG_NAME','Surface which can become swamp')
+       CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., swamp, "gather", nbp_glo, index_g)
+       CALL setvar_p (swamp, 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_p('UNITS', 'Kg/dt')
+    CALL ioconf_setatt_p('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_p('UNITS', 'Kg/m^2/dt')
+    CALL ioconf_setatt_p('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 (reinfiltration_mean(nbpt))
+    var_name = 'reinfiltration'
+    CALL ioconf_setatt_p('UNITS', 'Kg/m^2/dt')
+    CALL ioconf_setatt_p('LONG_NAME','Top return flux')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., reinfiltration_mean, "gather", nbp_glo, index_g)
+    CALL setvar_p (reinfiltration_mean, val_exp, 'NO_KEYWORD', zero)
+    reinfiltration(:) = reinfiltration_mean(:)
+    !
+    ALLOCATE (irrigation_mean(nbpt))
+    ALLOCATE (irrig_netereq(nbpt))
+    irrig_netereq(:) = zero
+    !
+    IF ( doirrigation ) THEN
+       var_name = 'irrigation'
+       CALL ioconf_setatt_p('UNITS', 'Kg/dt')
+       CALL ioconf_setatt_p('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_p('UNITS', 'Kg/dt')
+    CALL ioconf_setatt_p('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_p('UNITS', 'Kg/dt')
+    CALL ioconf_setatt_p('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_p('UNITS', 'm^3/dt')
+    CALL ioconf_setatt_p('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), flood_diag(nbpt), &
+         & pond_diag(nbpt), lake_diag(nbpt), delsurfstor(nbpt), stat=ier)
+    !
+    fast_diag(:) = zero
+    slow_diag(:) = zero
+    stream_diag(:) = zero
+    flood_diag(:) = zero
+    pond_diag(:) = zero
+    lake_diag(:) = zero
+    delsurfstor(:) = 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)
+          flood_diag(ig) = flood_diag(ig) + flood_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
+       flood_diag(ig) = flood_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 (floodout_mean(nbpt))
+    var_name = 'floodout_route'
+    CALL ioconf_setatt_p('UNITS', 'Kg')
+    CALL ioconf_setatt_p('LONG_NAME','Accumulated flow out of floodplains for routing')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodout_mean, "gather", nbp_glo, index_g)
+    CALL setvar_p (floodout_mean, val_exp, 'NO_KEYWORD', zero)
+    !
+    ALLOCATE (runoff_mean(nbpt))
+    var_name = 'runoff_route'
+    CALL ioconf_setatt_p('UNITS', 'Kg')
+    CALL ioconf_setatt_p('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_p('UNITS', 'Kg')
+    CALL ioconf_setatt_p('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(transpot_mean(nbpt))
+    var_name = 'transpot_route'
+    CALL ioconf_setatt_p('UNITS', 'Kg/m^2')
+    CALL ioconf_setatt_p('LONG_NAME','Accumulated potential transpiration for routing/irrigation')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., transpot_mean, "gather", nbp_glo, index_g)
+    CALL setvar_p (transpot_mean, val_exp, 'NO_KEYWORD', zero)
+
+    ALLOCATE(precip_mean(nbpt))
+    var_name = 'precip_route'
+    CALL ioconf_setatt_p('UNITS', 'Kg/m^2')
+    CALL ioconf_setatt_p('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_p('UNITS', '-')
+    CALL ioconf_setatt_p('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(k_litt_mean(nbpt))
+    var_name = 'k_litt_route'
+    CALL ioconf_setatt_p('UNITS', '-')
+    CALL ioconf_setatt_p('LONG_NAME','Mean cond. for litter')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., k_litt_mean, "gather", nbp_glo, index_g)
+    CALL setvar_p (k_litt_mean, val_exp, 'NO_KEYWORD', zero)
+    !
+    ALLOCATE(totnobio_mean(nbpt))
+    var_name = 'totnobio_route'
+    CALL ioconf_setatt_p('UNITS', '-')
+    CALL ioconf_setatt_p('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_p('UNITS', '-')
+    CALL ioconf_setatt_p('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
+    !
+    ALLOCATE(hydroupbasin_loc(nbpt),hydroupbasin_glo(nbp_glo), stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in hydroupbasin allocation. We stop. We need kjpindex words = ', nbpt*nbasmax
+        STOP 'routing_init'
+    END IF
+    hydroupbasin=>hydroupbasin_loc
+    !
+    !
+  END SUBROUTINE routing_init
+  !
+!! ================================================================================================================================
+!! SUBROUTINE 	: routing_clear
+!!
+!> BRIEF        : This subroutine deallocates the block memory previously allocated.
+!! \n
+!_ ================================================================================================================================
+
+  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(route_nbintobas_loc)) DEALLOCATE(route_nbintobas_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(route_nbintobas_glo)) DEALLOCATE(route_nbintobas_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(flood_reservoir)) DEALLOCATE(flood_reservoir)
+    IF (ALLOCATED(flood_frac_bas)) DEALLOCATE(flood_frac_bas)
+    IF (ALLOCATED(flood_height)) DEALLOCATE(flood_height)
+    IF (ALLOCATED(pond_frac)) DEALLOCATE(pond_frac)
+    IF (ALLOCATED(lake_reservoir)) DEALLOCATE(lake_reservoir)
+    IF (ALLOCATED(pond_reservoir)) DEALLOCATE(pond_reservoir)
+    IF (ALLOCATED(returnflow_mean)) DEALLOCATE(returnflow_mean)
+    IF (ALLOCATED(reinfiltration_mean)) DEALLOCATE(reinfiltration_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(floodout_mean)) DEALLOCATE(floodout_mean)
+    IF (ALLOCATED(drainage_mean)) DEALLOCATE(drainage_mean)
+    IF (ALLOCATED(transpot_mean)) DEALLOCATE(transpot_mean)
+    IF (ALLOCATED(precip_mean)) DEALLOCATE(precip_mean)
+    IF (ALLOCATED(humrel_mean)) DEALLOCATE(humrel_mean)
+    IF (ALLOCATED(k_litt_mean)) DEALLOCATE(k_litt_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(hydroupbasin_loc)) DEALLOCATE(hydroupbasin_loc)    
+    IF (ALLOCATED(hydroupbasin_glo)) DEALLOCATE(hydroupbasin_glo)
+    IF (ALLOCATED(hydrographs)) DEALLOCATE(hydrographs)
+    IF (ALLOCATED(irrigation_mean)) DEALLOCATE(irrigation_mean)
+    IF (ALLOCATED(irrigated)) DEALLOCATE(irrigated)
+    IF (ALLOCATED(floodplains)) DEALLOCATE(floodplains)
+    IF (ALLOCATED(swamp)) DEALLOCATE(swamp)
+    IF (ALLOCATED(fast_diag)) DEALLOCATE(fast_diag)
+    IF (ALLOCATED(slow_diag)) DEALLOCATE(slow_diag)
+    IF (ALLOCATED(stream_diag)) DEALLOCATE(stream_diag)
+    IF (ALLOCATED(flood_diag)) DEALLOCATE(flood_diag)
+    IF (ALLOCATED(pond_diag)) DEALLOCATE(pond_diag)
+    IF (ALLOCATED(lake_diag)) DEALLOCATE(lake_diag)
+    IF (ALLOCATED(delsurfstor)) DEALLOCATE(delsurfstor)
+    !
+  END SUBROUTINE routing_clear
+  !
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: routing_flow
+!!
+!> BRIEF         This subroutine computes the transport of water in the various reservoirs
+!!                (including ponds and floodplains) and the water withdrawals from the reservoirs for irrigation.
+!!
+!! DESCRIPTION (definitions, functional, design, flags) :
+!! This will first compute the amount of water which flows out of each of the 3 reservoirs using the assumption of an 
+!! exponential decrease of water in the reservoir (see Hagemann S and Dumenil L. (1998)). Then we compute the fluxes 
+!! for floodplains and ponds. All this will then be used in order to update each of the basins : taking water out of 
+!! the up-stream basin and adding it to the down-stream one.
+!! As this step happens globaly we have to stop the parallel processing in order to exchange the information. Once 
+!! all reservoirs are updated we deal with irrigation. The final step is to compute diagnostic fluxes. Among them
+!! the hydrographs of the largest rivers we have chosen to monitor.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): lakeinflow, returnflow, reinfiltration, irrigation, riverflow, coastalflow, hydrographs, flood_frac, flood_res
+!!
+!! REFERENCES   :
+!! - Ngo-Duc, T., K. Laval, G. Ramillien, J. Polcher, and A. Cazenave (2007)
+!!   Validation of the land water storage simulated by Organising Carbon and Hydrology in Dynamic Ecosystems (ORCHIDEE) with Gravity Recovery and Climate Experiment (GRACE) data.
+!!   Water Resour. Res., 43, W04427, doi:10.1029/2006WR004941.
+!! * Irrigation:
+!! - de Rosnay, P., J. Polcher, K. Laval, and M. Sabre (2003)
+!!   Integrated parameterization of irrigation in the land surface model ORCHIDEE. Validation over Indian Peninsula.
+!!   Geophys. Res. Lett., 30(19), 1986, doi:10.1029/2003GL018024.
+!! - A.C. Vivant (2003)
+!!   Les plaines d'inondations et l'irrigation dans ORCHIDEE, impacts de leur prise en compte.
+!!   , , 51pp.
+!! - N. Culson (2004)
+!!   Impact de l'irrigation sur le cycle de l'eau
+!!   Master thesis, Paris VI University, 55pp.
+!! - X.-T. Nguyen-Vinh (2005)
+!!   Analyse de l'impact de l'irrigation en Amerique du Nord - plaine du Mississippi - sur la climatologie regionale
+!!   Master thesis, Paris VI University, 33pp.
+!! - M. Guimberteau (2006)
+!!   Analyse et modifications proposees de la modelisation de l'irrigation dans un modele de surface.
+!!   Master thesis, Paris VI University, 46pp.
+!! - Guimberteau M. (2010)
+!!   Modelisation de l'hydrologie continentale et influences de l'irrigation sur le cycle de l'eau.
+!!   Ph.D. thesis, Paris VI University, 195pp.
+!! - Guimberteau M., Laval K., Perrier A. and Polcher J. (2011).
+!!   Global effect of irrigation and its impact on the onset of the Indian summer monsoon.
+!!   In press, Climate Dynamics, doi: 10.1007/s00382-011-1252-5.
+!! * Floodplains:
+!! - A.C. Vivant (2002)
+!!   L'ecoulement lateral de l'eau sur les surfaces continentales. Prise en compte des plaines d'inondations dans ORCHIDEE.
+!!   Master thesis, Paris VI University, 46pp.
+!! - A.C. Vivant (2003)
+!!   Les plaines d'inondations et l'irrigation dans ORCHIDEE, impacts de leur prise en compte.
+!!   , , 51pp.
+!! - T. d'Orgeval (2006)
+!!   Impact du changement climatique sur le cycle de l'eau en Afrique de l'Ouest: modelisation et incertitudes.
+!!   Ph.D. thesis, Paris VI University, 188pp.
+!! - T. d'Orgeval, J. Polcher, and P. de Rosnay (2008)
+!!   Sensitivity of the West African hydrological cycle in ORCHIDEE to infiltration processes.
+!!   Hydrol. Earth Syst. Sci., 12, 1387-1401
+!! - M. Guimberteau, G. Drapeau, J. Ronchail, B. Sultan, J. Polcher, J.-M. Martinez, C. Prigent, J.-L. Guyot, G. Cochonneau,
+!!   J. C. Espinoza, N. Filizola, P. Fraizy, W. Lavado, E. De Oliveira, R. Pombosa, L. Noriega, and P. Vauchel (2011)
+!!   Discharge simulation in the sub-basins of the Amazon using ORCHIDEE forced by new datasets.
+!!   Hydrol. Earth Syst. Sci. Discuss., 8, 11171-11232, doi:10.5194/hessd-8-11171-2011
+!!
+!! FLOWCHART    :None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE routing_flow(nbpt, dt_routing, floodout, runoff, drainage, &
+       &                  vegtot, totnobio, transpot_mean, precip, humrel, k_litt, floodtemp, reinf_slope, &
+       &                  lakeinflow, returnflow, reinfiltration, irrigation, riverflow, &
+       &                  coastalflow, hydrographs, flood_frac, flood_res)
+    !
+    IMPLICIT NONE
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT(in)                   :: nbpt                      !! Domain size (unitless)
+    REAL(r_std), INTENT (in)                     :: dt_routing                !! Routing time step (s)
+    REAL(r_std), INTENT(in)                      :: runoff(nbpt)              !! Grid-point runoff (kg/m^2/dt)
+    REAL(r_std), INTENT(in)                      :: floodout(nbpt)            !! Grid-point flow out of floodplains (kg/m^2/dt)
+    REAL(r_std), INTENT(in)                      :: drainage(nbpt)            !! Grid-point drainage (kg/m^2/dt)
+    REAL(r_std), INTENT(in)                      :: vegtot(nbpt)              !! Potentially vegetated fraction (unitless;0-1)
+    REAL(r_std), INTENT(in)                      :: totnobio(nbpt)            !! Other areas which can not have vegetation
+    REAL(r_std), INTENT(in)                      :: transpot_mean(nbpt)       !! Mean potential transpiration of the vegetation (kg/m^2/dt)
+    REAL(r_std), INTENT(in)                      :: precip(nbpt)              !! Rainfall (kg/m^2/dt)
+    REAL(r_std), INTENT(in)                      :: humrel(nbpt)              !! Soil moisture stress, root extraction potential (unitless)
+    REAL(r_std), INTENT(in)                      :: k_litt(nbpt)              !! Averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
+    REAL(r_std), INTENT(in)                      :: floodtemp(nbpt)           !! Temperature to decide if floodplains work (K)
+    REAL(r_std), INTENT(in)                      :: reinf_slope(nbpt)         !! Coefficient which determines the reinfiltration ratio in the grid box due to flat areas (unitless;0-1)
+    REAL(r_std), INTENT(out)                     :: lakeinflow(nbpt)          !! Water inflow to the lakes (kg/dt)
+    !
+!! OUTPUT VARIABLES
+    REAL(r_std), INTENT(out)                     :: returnflow(nbpt)          !! The water flow from lakes and swamps which returns into the grid box.
+                                                                              !! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
+    REAL(r_std), INTENT(out)                     :: reinfiltration(nbpt)      !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
+    REAL(r_std), INTENT(out)                     :: irrigation(nbpt)          !! Irrigation flux. This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt)
+    REAL(r_std), INTENT(out)                     :: riverflow(nbpt)           !! Outflow of the major rivers. The flux will be located on the continental grid but this should be a coastal point (kg/dt)
+    REAL(r_std), INTENT(out)                     :: coastalflow(nbpt)         !! Outflow on coastal points by small basins. This is the water which flows in a disperse way into the ocean (kg/dt)
+    REAL(r_std), INTENT(out)                     :: hydrographs(nbpt)         !! Hydrographs at the outflow of the grid box for major basins (kg/dt)
+    REAL(r_std), INTENT(out)                     :: flood_frac(nbpt)          !! Flooded fraction of the grid box (unitless;0-1)
+    REAL(r_std), INTENT(out)                     :: flood_res(nbpt)           !! Diagnostic of water amount in the floodplains reservoir (kg)
+    !
+!! LOCAL VARIABLES
+    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: fast_flow                 !! Outflow from the fast reservoir (kg/dt)
+    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: slow_flow                 !! Outflow from the slow reservoir (kg/dt)
+    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: stream_flow               !! Outflow from the stream reservoir (kg/dt)
+    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: flood_flow                !! Outflow from the floodplain reservoir (kg/dt)
+    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: pond_inflow               !! Inflow to the pond reservoir (kg/dt)
+    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: pond_drainage             !! Drainage from pond (kg/m^2/dt)
+    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: flood_drainage            !! Drainage from floodplains (kg/m^2/dt)
+    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: return_swamp              !! Inflow to the swamp (kg/dt)
+    !
+    ! Irrigation per basin
+    !
+    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: irrig_needs               !! Total irrigation requirement (water requirements by the crop for its optimal growth) (kg)
+    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: irrig_actual              !! Possible irrigation according to the water availability in the reservoirs (kg)
+    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: irrig_deficit             !! Amount of water missing for irrigation (kg)
+    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: irrig_adduct              !! Amount of water carried over from other basins for irrigation (kg)
+    !
+    REAL(r_std), DIMENSION(nbpt, 0:nbasmax+3)    :: transport                 !! Water transport between basins (kg/dt)
+    REAL(r_std), DIMENSION(nbp_glo, 0:nbasmax+3) :: transport_glo             !! Water transport between basins (kg/dt)
+    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: floods                    !! Water flow in to the floodplains (kg/dt)
+    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: potflood                  !! Potential inflow to the swamps (kg/dt)
+    REAL(r_std), DIMENSION(nbpt)                 :: tobeflooded               !! Maximal surface which can be inundated in each grid box (m^2)
+    REAL(r_std), DIMENSION(nbpt)                 :: totarea                   !! Total area of basin (m^2)
+    REAL(r_std), DIMENSION(nbpt)                 :: totflood                  !! Total amount of water in the floodplains reservoir (kg)
+    REAL(r_std), DIMENSION(nbasmax)              :: pond_excessflow           !! 
+    REAL(r_std)                                  :: flow                      !! Outflow computation for the reservoirs (kg/dt)
+    REAL(r_std)                                  :: floodindex                !! Fraction of grid box area inundated (unitless;0-1)
+    REAL(r_std)                                  :: pondex                    !! 
+    REAL(r_std)                                  :: flood_frac_pot            !! Total fraction of the grid box which is flooded at optimum repartition (unitless;0-1)
+    REAL(r_std)                                  :: stream_tot                !! Total water amount in the stream reservoirs (kg)
+    REAL(r_std)                                  :: adduction                 !! Importation of water from a stream reservoir of a neighboring grid box (kg)
+    REAL(r_std), DIMENSION(8,nbasmax)            :: streams_around            !! Stream reservoirs of the neighboring grid boxes (kg)
+    INTEGER(i_std), DIMENSION(8)                 :: igrd                      !! 
+    INTEGER(i_std), DIMENSION(2)                 :: ff                        !! 
+    INTEGER(i_std), DIMENSION(1)                 :: fi                        !! 
+    INTEGER(i_std)                               :: ig, ib, ib2, ig2, rtg, rtb, in !! Indices (unitless)
+    !
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: fast_flow_g               !! Outflow from the fast reservoir (kg/dt)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: slow_flow_g               !! Outflow from the slow reservoir (kg/dt)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: stream_flow_g             !! Outflow from the stream reservoir (kg/dt)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: irrig_deficit_glo         !! Amount of water missing for irrigation (kg)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: stream_reservoir_glo      !! Water amount in the stream reservoir (kg)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: irrig_adduct_glo          !! Amount of water carried over from other basins for irrigation (kg)
+    !
+    LOGICAL                                      :: error_reservoir           !! Logical to check if there is a negative amount of water in the slow reservoir (true/false)
+    !
+    !! PARAMETERS
+    LOGICAL, PARAMETER                           :: check_reservoir = .FALSE. !! Logical to choose if we write informations when a negative amount of water is occurring in a reservoir (true/false)
+
+!_ ================================================================================================================================
+    !
+    transport(:,:) = zero
+    transport_glo(:,:) = zero
+    irrig_netereq(:) = zero
+    irrig_needs(:,:) = zero
+    irrig_actual(:,:) = zero
+    irrig_deficit(:,:) = zero
+    irrig_adduct(:,:) = zero
+    totarea(:) = zero
+    totflood(:) = zero
+    !
+    ! Compute all the fluxes
+    !
+    DO ib=1,nbasmax
+       DO ig=1,nbpt
+          !
+          totarea(ig) = totarea(ig) + routing_area(ig,ib)
+          totflood(ig) = totflood(ig) + flood_reservoir(ig,ib)
+       ENDDO
+    ENDDO
+          !
+!> The outflow fluxes from the three reservoirs are computed. 
+!> The outflow of volume of water Vi into the reservoir i is assumed to be linearly related to its volume.
+!> The water travel simulated by the routing scheme is dependent on the water retention index topo_resid
+!> given by a 0.5 degree resolution map for each pixel performed from a simplification of Manning's formula
+!> (Dingman, 1994; Ducharne et al., 2003).
+!> The resulting product of tcst (in day/m) and topo_resid (in m) represents the time constant (day)
+!> which is an e-folding time, the time necessary for the water amount
+!> in the stream reservoir to decrease by a factor e. Hence, it gives an order of
+!> magnitude of the travel time through this reservoir between
+!> the sub-basin considered and its downstream neighbor.
+
+    DO ib=1,nbasmax
+       DO ig=1,nbpt
+          IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
+             !
+             ! Each of the fluxes is limited by the water in the reservoir and a small margin 
+             ! (min_reservoir) to avoid rounding errors.
+             !
+             flow = MIN(fast_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)*fast_tcst*one_day/dt_routing),&
+                  & fast_reservoir(ig,ib)-min_sechiba)
+             fast_flow(ig,ib) = MAX(flow, zero)
+             !
+             flow = MIN(slow_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)*slow_tcst*one_day/dt_routing),&
+                  & slow_reservoir(ig,ib)-min_sechiba)
+             slow_flow(ig,ib) = MAX(flow, zero)
+             !
+             flow = MIN(stream_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)*stream_tcst* & 
+                  & MAX(un-SQRT(flood_frac_bas(ig,ib)),min_sechiba)*one_day/dt_routing),&
+                  & stream_reservoir(ig,ib)-min_sechiba)
+             stream_flow(ig,ib) = MAX(flow, zero)
+             ! 
+             !
+          ELSE
+             fast_flow(ig,ib) = zero
+             slow_flow(ig,ib) = zero
+             stream_flow(ig,ib) = zero
+          ENDIF
+       ENDDO
+    ENDDO
+    !-
+    !- Compute the fluxes out of the floodplains and ponds if they exist.
+    !-
+    IF (dofloodplains .OR. doponds) THEN
+       DO ig=1,nbpt
+          IF (flood_frac(ig) .GT. min_sechiba) THEN
+             !
+             flow = MIN(floodout(ig)*totarea(ig)*pond_frac(ig)/flood_frac(ig), pond_reservoir(ig)+totflood(ig))
+             pondex = MAX(flow - pond_reservoir(ig), zero)
+             pond_reservoir(ig) = pond_reservoir(ig) - (flow - pondex) 
+             !
+             ! If demand was over reservoir size, we will take it out from floodplains
+             !
+             pond_excessflow(:) = zero
+             DO ib=1,nbasmax
+                pond_excessflow(ib) = MIN(pondex*flood_frac_bas(ig,ib)/(flood_frac(ig)-pond_frac(ig)),&
+                     &                    flood_reservoir(ig,ib))
+                pondex = pondex - pond_excessflow(ib)
+             ENDDO
+             !
+             IF ( pondex .GT. min_sechiba) THEN
+                WRITE(numout,*) "Unable to redistribute the excess pond outflow over the water available in the floodplain."
+                WRITE(numout,*) "Pondex = ", pondex
+                WRITE(numout,*) "pond_excessflow(:) = ", pond_excessflow(:)
+             ENDIF
+             !
+             DO ib=1,nbasmax
+                !
+                flow = floodout(ig)*routing_area(ig,ib)*flood_frac_bas(ig,ib)/flood_frac(ig) + pond_excessflow(ib)
+                !
+                flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flow
+                !
+                !
+                IF (flood_reservoir(ig,ib) .LT. min_sechiba) THEN
+                   flood_reservoir(ig,ib) = zero
+                ENDIF
+                IF (pond_reservoir(ig) .LT. min_sechiba) THEN
+                   pond_reservoir(ig) = zero
+                ENDIF
+             ENDDO
+          ENDIF
+       ENDDO
+    ENDIF
+
+    !-
+    !- Computing the drainage and outflow from floodplains
+!> Drainage from floodplains is depending on a averaged conductivity (k_litt) 
+!> for saturated infiltration in the 'litter' layer. Flood_drainage will be
+!> a component of the total reinfiltration that leaves the routing scheme.
+    !-
+    IF (dofloodplains) THEN
+       IF (dofloodinfilt) THEN
+          DO ib=1,nbasmax
+             DO ig=1,nbpt
+                flood_drainage(ig,ib) = MAX(zero, MIN(flood_reservoir(ig,ib), &
+                     & flood_frac(ig)*routing_area(ig,ib)*k_litt(ig)*dt_routing/one_day))
+                flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flood_drainage(ig,ib)
+             ENDDO
+          ENDDO
+       ELSE
+          DO ib=1,nbasmax
+             DO ig=1,nbpt
+                flood_drainage(ig,ib) = zero 
+             ENDDO
+          ENDDO
+       ENDIF
+!> Outflow from floodplains is computed depending a delay. This delay is characterized by a time constant
+!> function of the surface of the floodplains and the product of topo_resid and flood_tcst. flood_tcst
+!> has been calibrated through observations in the Niger Inner Delta (D'Orgeval, 2006).
+!
+       DO ib=1,nbasmax
+          DO ig=1,nbpt
+             IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
+                IF (flood_frac_bas(ig,ib) .GT. min_sechiba) THEN
+                   flow = MIN(flood_reservoir(ig,ib)  &
+                        & /((topo_resid(ig,ib)/1000.)*flood_tcst* &
+                        & flood_frac_bas(ig,ib)*one_day/dt_routing),&
+                        & flood_reservoir(ig,ib))
+                ELSE
+                   flow = zero
+                ENDIF
+                flood_flow(ig,ib) = flow
+             ELSE
+                flood_flow(ig,ib) = zero
+             ENDIF
+          ENDDO
+       ENDDO
+    ELSE
+       DO ib=1,nbasmax
+          DO ig=1,nbpt
+             flood_drainage(ig,ib) = zero
+             flood_flow(ig,ib) = zero
+             flood_reservoir(ig,ib) = zero
+          ENDDO
+       ENDDO
+    ENDIF
+
+    !-
+    !- Computing drainage and inflow for ponds
+!> Drainage from ponds is computed in the same way than for floodplains.
+!> Reinfiltrated fraction from the runoff (i.e. the outflow from the fast reservoir)
+!> is the inflow of the pond reservoir.
+    !-
+    IF (doponds) THEN
+       ! If used, the slope coef is not used in hydrol for water2infilt
+       DO ib=1,nbasmax
+          DO ig=1,nbpt
+             pond_inflow(ig,ib) = fast_flow(ig,ib) * reinf_slope(ig)
+             pond_drainage(ig,ib) = MIN(pond_reservoir(ig)*routing_area(ig,ib)/totarea(ig), &
+                  & pond_frac(ig)*routing_area(ig,ib)*k_litt(ig)*dt_routing/one_day)
+             fast_flow(ig,ib) = fast_flow(ig,ib) - pond_inflow(ig,ib) 
+          ENDDO
+       ENDDO
+    ELSE
+       DO ib=1,nbasmax
+          DO ig=1,nbpt
+             pond_inflow(ig,ib) = zero
+             pond_drainage(ig,ib) = zero
+             pond_reservoir(ig) = zero
+          ENDDO
+       ENDDO
+    ENDIF
+
+!ym cette methode conserve les erreurs d'arrondie
+!ym mais n'est pas la plus efficace
+
+    !-
+    !- Compute the transport from one basin to another
+    !-
+
+    IF (is_root_prc)  THEN
+       ALLOCATE( fast_flow_g(nbp_glo, nbasmax), slow_flow_g(nbp_glo, nbasmax), &
+            stream_flow_g(nbp_glo, nbasmax) )
+    ELSE
+       ALLOCATE( fast_flow_g(1,1), slow_flow_g(1,1), &
+            stream_flow_g(1, 1) )
+    ENDIF
+    
+       
+    CALL gather(fast_flow,fast_flow_g)
+    CALL gather(slow_flow,slow_flow_g)
+    CALL gather(stream_flow,stream_flow_g)
+
+    IF (is_root_prc) THEN
+       DO ib=1,nbasmax
+          DO ig=1,nbp_glo
+             !
+             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)
+             !
+          ENDDO
+       ENDDO
+    ENDIF
+
+    DEALLOCATE( fast_flow_g, slow_flow_g, stream_flow_g )
+   
+    CALL scatter(transport_glo,transport)
+
+    !-
+    !- Do the floodings - First initialize
+    !-
+    return_swamp(:,:)=zero
+    floods(:,:)=zero
+    !-
+!> Over swamp areas, a fraction of water (return_swamp) is withdrawn from the river depending on the
+!> parameter swamp_cst.
+!> It will be transferred into soil moisture and thus does not return directly to the river.
+    !
+    !- 1. Swamps: Take out water from the river to put it to the swamps
+    !-
+    !
+    IF ( doswamps ) THEN
+       tobeflooded(:) = swamp(:)
+       DO ib=1,nbasmax
+          DO ig=1,nbpt
+             potflood(ig,ib) = transport(ig,ib) 
+             !
+             IF ( tobeflooded(ig) > 0. .AND. potflood(ig,ib) > 0. .AND. floodtemp(ig) > tp_00 ) THEN
+                !
+                IF (routing_area(ig,ib) > tobeflooded(ig)) THEN
+                   floodindex = tobeflooded(ig) / routing_area(ig,ib)
+                ELSE
+                   floodindex = 1.0
+                ENDIF
+                return_swamp(ig,ib) = swamp_cst * potflood(ig,ib) * floodindex
+                !
+                tobeflooded(ig) = tobeflooded(ig) - routing_area(ig,ib) 
+                !
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDIF
+    !-
+    !- 2. Floodplains: Update the reservoir with the flux computed above.
+    !-
+    IF ( dofloodplains ) THEN
+       DO ig=1,nbpt
+          IF (floodplains(ig) .GT. min_sechiba .AND. floodtemp(ig) .GT. tp_00) THEN
+             DO ib=1,nbasmax
+                floods(ig,ib) = transport(ig,ib) - return_swamp(ig,ib) 
+             ENDDO
+          ENDIF
+       ENDDO
+    ENDIF
+    !
+    ! Update all reservoirs
+!> The slow and deep reservoir (slow_reservoir) collect the deep drainage whereas the
+!> fast_reservoir collects the computed surface runoff. Both discharge into a third reservoir
+!> (stream_reservoir) of the next sub-basin downstream.
+!> Water from the floodplains reservoir (flood_reservoir) flows also into the stream_reservoir of the next sub-basin downstream.
+!> Water that flows into the pond_reservoir is withdrawn from the fast_reservoir.
+    !
+    error_reservoir=.FALSE.
+    DO ig=1,nbpt
+       DO ib=1,nbasmax
+          !
+          fast_reservoir(ig,ib) =  fast_reservoir(ig,ib) + runoff(ig)*routing_area(ig,ib) - &
+               & fast_flow(ig,ib) - pond_inflow(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) + flood_flow(ig,ib) + transport(ig,ib) - &
+               & stream_flow(ig,ib) - return_swamp(ig,ib) - floods(ig,ib)
+          !
+          flood_reservoir(ig,ib) = flood_reservoir(ig,ib) + floods(ig,ib) - &
+               & flood_flow(ig,ib) 
+          !
+          pond_reservoir(ig) = pond_reservoir(ig) + pond_inflow(ig,ib) - pond_drainage(ig,ib)
+          !
+          IF ( flood_reservoir(ig,ib) .LT. zero ) THEN
+             IF ( check_reservoir ) THEN
+                WRITE(numout,*) "WARNING : negative flood reservoir at :", ig, ib, ". Problem is being corrected."
+                WRITE(numout,*) "flood_reservoir, floods, flood_flow : ", flood_reservoir(ig,ib), floods(ig,ib), &
+                     & flood_flow(ig,ib) 
+             ENDIF
+             stream_reservoir(ig,ib) = stream_reservoir(ig,ib) + flood_reservoir(ig,ib)
+             flood_reservoir(ig,ib) = zero
+          ENDIF
+          !
+          IF ( stream_reservoir(ig,ib) .LT. zero ) THEN
+             IF ( check_reservoir ) THEN
+                WRITE(numout,*) "WARNING : negative stream reservoir at :", ig, ib, ". Problem is being corrected."
+                WRITE(numout,*) "stream_reservoir, flood_flow, transport : ", stream_reservoir(ig,ib), flood_flow(ig,ib), &
+                     &  transport(ig,ib)
+                WRITE(numout,*) "stream_flow, return_swamp, floods :", stream_flow(ig,ib), return_swamp(ig,ib), floods(ig,ib)
+             ENDIF
+             fast_reservoir(ig,ib) =  fast_reservoir(ig,ib) + stream_reservoir(ig,ib)
+             stream_reservoir(ig,ib) = zero
+          ENDIF
+          !
+          IF ( fast_reservoir(ig,ib) .LT. zero ) THEN
+             IF ( check_reservoir ) THEN
+                WRITE(numout,*) "WARNING : negative fast reservoir at :", ig, ib, ". Problem is being corrected."
+                WRITE(numout,*) "fast_reservoir, runoff, fast_flow, ponf_inflow  : ", fast_reservoir(ig,ib), &
+                     &runoff(ig), fast_flow(ig,ib), pond_inflow(ig,ib)
+             ENDIF
+             slow_reservoir(ig,ib) =  slow_reservoir(ig,ib) + fast_reservoir(ig,ib)
+             fast_reservoir(ig,ib) = zero
+          ENDIF
+          !
+          IF ( slow_reservoir(ig,ib) .LT. zero ) THEN
+             error_reservoir=.TRUE.
+          ENDIF
+          !
+       ENDDO
+    ENDDO
+
+    IF (error_reservoir) THEN
+       WRITE(numout,*) 'WARNING : There is a negative reservoir at :', ig, ib
+       WRITE(numout,*) 'WARNING : slowr, slow_flow, drainage', &
+            & slow_reservoir(ig,ib), slow_flow(ig,ib), drainage(ig)
+       WRITE(numout,*) 'WARNING : pondr, pond_inflow, pond_drainage', &
+            & pond_reservoir(ig), pond_inflow(ig,ib), pond_drainage(ig,ib)
+       CALL ipslerr_p(2, 'routing_flow', 'WARNING negative slow_reservoir.','','')
+    ENDIF
+
+    totflood(:) = zero
+    DO ig=1,nbpt
+       DO ib=1,nbasmax
+          totflood(ig) = totflood(ig) + flood_reservoir(ig,ib)
+       ENDDO
+    ENDDO
+
+    !-
+    !- Computes the fraction of floodplains and ponds according to their volume
+    !-
+    IF (dofloodplains .OR. doponds) THEN
+       flood_frac(:) = zero
+       flood_height(:) = zero
+       flood_frac_bas(:,:) = zero
+       DO ig=1, nbpt
+          IF (totflood(ig) .GT. min_sechiba) THEN
+             ! We first compute the total fraction of the grid box which is flooded at optimum repartition
+             flood_frac_pot = (totflood(ig) / (totarea(ig)*floodcri/(beta+un)))**(beta/(beta+un))
+             flood_frac(ig) = MIN(floodplains(ig) / totarea(ig), flood_frac_pot)
+             ! Then we diagnose the fraction for each basin with the size of its flood_reservoir 
+             ! (flood_frac_bas may be > 1)
+             DO ib=1,nbasmax
+                IF (routing_area(ig,ib) .GT. min_sechiba) THEN
+                   flood_frac_bas(ig,ib) = flood_frac(ig) * &
+                        & (flood_reservoir(ig,ib) / totflood(ig)) / (routing_area(ig,ib) / totarea(ig))
+                ENDIF
+             ENDDO
+             ! We diagnose the maximum height of floodplain
+             flood_height(ig) = (beta/(beta+1))*floodcri*(flood_frac(ig))**(un/beta) + totflood(ig)/(totarea(ig)*flood_frac(ig)) 
+             ! And finally add the pond surface
+             pond_frac(ig) = MIN(un-flood_frac(ig), ((betap+1)*pond_reservoir(ig) / (pondcri*totarea(ig)))**(betap/(betap+1)) ) 
+             flood_frac(ig) = flood_frac(ig) + pond_frac(ig)
+             !
+          ENDIF
+       ENDDO
+    ELSE
+       flood_frac(:) = zero
+       flood_height(:) = zero
+       flood_frac_bas(:,:) = zero
+    ENDIF
+
+    !-
+    !- Compute the total reinfiltration and returnflow to the grid box
+!> A term of returnflow is computed including the water from the swamps that does not return directly to the river
+!> but will be put into soil moisture (see hydrol module).
+!> A term of reinfiltration is computed including the water that reinfiltrated from the ponds and floodplains areas.
+!> It will be put into soil moisture (see hydrol module).
+    !-
+    IF (dofloodplains .OR. doswamps .OR. doponds) THEN
+       returnflow(:) = zero
+       reinfiltration(:) = zero
+       !
+       DO ib=1,nbasmax
+          DO ig=1,nbpt
+             returnflow(ig) =  returnflow(ig) + return_swamp(ig,ib)
+             reinfiltration(ig) =  reinfiltration(ig) + pond_drainage(ig,ib) + flood_drainage(ig,ib) 
+          ENDDO
+       ENDDO
+       !
+       DO ig=1,nbpt
+          returnflow(ig) = returnflow(ig)/totarea(ig)
+          reinfiltration(ig) = reinfiltration(ig)/totarea(ig)
+       ENDDO
+    ELSE
+       returnflow(:) = zero
+       reinfiltration(:) = zero
+    ENDIF
+
+    !
+    ! 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.
+    !
+!> The computation of the irrigation is performed here.
+!> * First step
+!> In a first time, the water requirements (irrig_netereq) by the crops for their optimal growth are calculated
+!> over each irrigated fraction (irrigated(ig)/totarea(ig)). It is the difference
+!> between the maximal water loss by the crops (transpot_mean) and the net water amount kept by the soil
+!> (precipitation and reinfiltration). Transpot_mean is computed in the routines enerbil and diffuco. It
+!> is derived from the effective transpiration parametrization under stress-free conditions, called potential transpiration.
+!> Crop_coef was used by a previous parametrization of irrigation in the code. Here, its value is equal to one.
+!> The crop coefficient was constant in space and time to represent a mean resistance of the vegetation to the potential evaporation.
+!> Now, the term crop_coef*Epot is substituted by transpot_mean (see Guimberteau et al., 2011).
+!> * Second step
+!> We compute irrigation needs in order to supply Irrig_netereq. Water for irrigation (irrig_actual) is withdrawn
+!> from the reservoirs. The amount of water is withdrawn in priority from the stream reservoir.
+!> If the irrigation requirement is higher than the water availability of the reservoir, water is withdrawn
+!> from the fast reservoir or, in the extreme case, from the slow reservoir.
+!> * Third step
+!> We compute a deficit in water for irrigation. If it is positive, irrigation (depending on water availibility in the reservoirs)
+!> has not supplied the crops requirements.
+!
+    IF ( doirrigation ) THEN
+       DO ig=1,nbpt
+          !
+          IF ((vegtot(ig) .GT. min_sechiba) .AND. (humrel(ig) .LT. un-min_sechiba) .AND. &
+               & (runoff(ig) .LT. min_sechiba) ) THEN
+             
+             irrig_netereq(ig) = (irrigated(ig) / totarea(ig) ) * MAX(zero, transpot_mean(ig) - &
+                  & (precip(ig)+reinfiltration(ig)) )
+             
+          ENDIF
+          !
+          DO ib=1,nbasmax
+             IF ( routing_area(ig,ib) .GT. 0 ) THEN
+             
+                irrig_needs(ig,ib) = irrig_netereq(ig) * routing_area(ig,ib)
+
+                irrig_actual(ig,ib) = MIN(irrig_needs(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)-irrig_actual(ig,ib))))
+
+                fast_reservoir(ig,ib) = MAX( zero, &
+                     &  fast_reservoir(ig,ib) + MIN(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib)))
+
+                stream_reservoir(ig,ib) = MAX(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib) )
+
+                irrig_deficit(ig,ib) = irrig_needs(ig,ib)-irrig_actual(ig,ib)
+
+             ENDIF
+          ENDDO
+          !
+          ! Check if we cannot find the missing water in another basin of the same grid (stream reservoir only).
+          ! If we find that then we create some adduction from that subbasin to the one where we need it for
+          ! irrigation.
+          !
+!> If crops water requirements have not been supplied (irrig_deficit>0), we check if we cannot find the missing water
+!> in another basin of the same grid. If there is water in the stream reservoir of this subbasin, we create some adduction
+!> from that subbasin to the one where we need it for irrigation.
+!> 
+          DO ib=1,nbasmax
+
+             stream_tot = SUM(stream_reservoir(ig,:))
+
+             DO WHILE ( irrig_deficit(ig,ib) > min_sechiba .AND. stream_tot > min_sechiba)
+                
+                fi = MAXLOC(stream_reservoir(ig,:))
+                ib2 = fi(1)
+
+                irrig_adduct(ig,ib) = MIN(irrig_deficit(ig,ib), stream_reservoir(ig,ib2))
+                stream_reservoir(ig,ib2) = stream_reservoir(ig,ib2)-irrig_adduct(ig,ib)
+                irrig_deficit(ig,ib) = irrig_deficit(ig,ib)-irrig_adduct(ig,ib)
+             
+                stream_tot = SUM(stream_reservoir(ig,:))
+                
+             ENDDO
+             
+          ENDDO
+          !
+       ENDDO
+       !
+       ! If we are at higher resolution we might need to look at neighboring grid boxes to find the streams
+       ! which can feed irrigation
+!
+!> At higher resolution (grid box smaller than 100x100km), we can import water from neighboring grid boxes
+!> to the one where we need it for irrigation.
+       !
+       IF (is_root_prc) THEN
+          ALLOCATE(irrig_deficit_glo(nbp_glo, nbasmax), stream_reservoir_glo(nbp_glo, nbasmax), &
+               &        irrig_adduct_glo(nbp_glo, nbasmax))
+       ELSE
+          ALLOCATE(irrig_deficit_glo(0, 0), stream_reservoir_glo(0, 0), &
+               &        irrig_adduct_glo(0, 0))
+       ENDIF
+
+       CALL gather(irrig_deficit, irrig_deficit_glo)
+       CALL gather(stream_reservoir,  stream_reservoir_glo)
+       CALL gather(irrig_adduct, irrig_adduct_glo)
+
+       IF (is_root_prc) THEN
+          !
+          DO ig=1,nbp_glo
+             ! Only work if the grid box is smaller than 100x100km. Else the piplines we build
+             ! here would be too long to be reasonable.
+             IF ( resolution_g(ig,1) < 100000. .AND. resolution_g(ig,2) < 100000. ) THEN
+                DO ib=1,nbasmax
+                   !
+                   IF ( irrig_deficit_glo(ig,ib)  > min_sechiba ) THEN
+                      !
+                      streams_around(:,:) = zero
+                      !
+                      DO in=1,8
+                         ig2 = neighbours_g(ig,in)
+                         IF (ig2 .GT. 0 ) THEN
+                            streams_around(in,:) = stream_reservoir_glo(ig2,:)
+                            igrd(in) = ig2
+                         ENDIF
+                      ENDDO
+                      !
+                      IF ( MAXVAL(streams_around) .GT. zero ) THEN
+                         !
+                         ff=MAXLOC(streams_around)
+                         ig2=igrd(ff(1))
+                         ib2=ff(2)
+                         !
+                         IF ( routing_area_glo(ig2,ib2) .GT. 0 .AND. stream_reservoir_glo(ig2,ib2) > zero ) THEN
+                            adduction = MIN(irrig_deficit_glo(ig,ib), stream_reservoir_glo(ig2,ib2))
+                            stream_reservoir_glo(ig2,ib2) = stream_reservoir_glo(ig2,ib2) - adduction
+                            irrig_deficit_glo(ig,ib) = irrig_deficit_glo(ig,ib) - adduction
+                            irrig_adduct_glo(ig,ib) = irrig_adduct_glo(ig,ib) + adduction
+                         ENDIF
+                         !
+                      ENDIF
+                      !
+                   ENDIF
+                   !
+                ENDDO
+             ENDIF
+          ENDDO
+          !
+       ENDIF
+       !
+
+       CALL scatter(irrig_deficit_glo, irrig_deficit)
+       CALL scatter(stream_reservoir_glo,  stream_reservoir)
+       CALL scatter(irrig_adduct_glo, irrig_adduct)
+
+       DEALLOCATE(irrig_deficit_glo, stream_reservoir_glo, irrig_adduct_glo)
+
+    ENDIF
+    !
+    !
+    ! Compute the fluxes which leave the routing scheme
+    !
+    ! Lakeinflow is in Kg/dt
+    ! returnflow is in Kg/m^2/dt
+    !
+    delsurfstor(:) = -flood_diag(:)-pond_diag(:)-lake_diag(:)
+    hydrographs(:) = zero
+    fast_diag(:) = zero
+    slow_diag(:) = zero
+    stream_diag(:) = zero
+    flood_diag(:) =  zero
+    pond_diag(:) =  zero
+    irrigation(:) = zero
+    !
+    !
+    DO ib=1,nbasmax
+       !
+       DO ig=1,nbpt
+          IF (hydrodiag(ig,ib) > 0 ) THEN
+             hydrographs(ig) = hydrographs(ig) + fast_flow(ig,ib) + slow_flow(ig,ib) + & 
+                  &  stream_flow(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)
+          flood_diag(ig) = flood_diag(ig) + flood_reservoir(ig,ib)
+          irrigation (ig) = irrigation (ig) + irrig_actual(ig,ib) + irrig_adduct(ig,ib)
+       ENDDO
+    ENDDO
+    !
+    DO ig=1,nbpt
+       fast_diag(ig) = fast_diag(ig)/totarea(ig)
+       slow_diag(ig) = slow_diag(ig)/totarea(ig)
+       stream_diag(ig) = stream_diag(ig)/totarea(ig)
+       flood_diag(ig) = flood_diag(ig)/totarea(ig)
+       pond_diag(ig) = pond_reservoir(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)
+       !
+    ENDDO
+    !
+    flood_res = flood_diag + pond_diag
+    !
+  END SUBROUTINE routing_flow
+  !
+!! ================================================================================================================================
+!! SUBROUTINE 	: routing_lake
+!!
+!> BRIEF        : This subroutine 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.
+!!
+!! DESCRIPTION (definitions, functional, design, flags): The return flow to the soil moisture reservoir
+!! is based on a maximum lake evaporation rate (maxevap_lake). \n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    :None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE routing_lake(nbpt, dt_routing, lakeinflow, humrel, return_lakes)
+    !
+    IMPLICIT NONE
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT(in) :: nbpt               !! Domain size (unitless)
+    REAL(r_std), INTENT (in)   :: dt_routing         !! Routing time step (s)
+    REAL(r_std), INTENT(in)    :: lakeinflow(nbpt)   !! Water inflow to the lakes (kg/dt)
+    REAL(r_std), INTENT(in)    :: humrel(nbpt)       !! Soil moisture stress, root extraction potential (unitless)
+    !
+!! OUTPUT VARIABLES
+    REAL(r_std), INTENT(out)   :: return_lakes(nbpt) !! Water from lakes flowing back into soil moisture (kg/m^2/dt)
+    !
+!! LOCAL VARIABLES
+    INTEGER(i_std)             :: ig                 !! Indices (unitless)
+    REAL(r_std)                :: refill             !!
+    REAL(r_std)                :: total_area         !! Sum of all the surfaces of the basins (m^2)
+
+!_ ================================================================================================================================
+    !
+    !
+    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)
+       return_lakes(ig) = MIN(refill, lake_reservoir(ig))
+       lake_reservoir(ig) = lake_reservoir(ig) - return_lakes(ig)
+       !Return in Kg/m^2/dt
+       IF ( doswamps ) THEN
+          return_lakes(ig) = return_lakes(ig)/total_area
+       ELSE
+          return_lakes(ig) = zero
+       ENDIF
+       !
+       ! 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
+!!
+!> BRIEF         This parallelized subroutine gives a diagnostic of the basins used
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE routing_diagnostic_p(nbpt, index, lalo, resolution, contfrac, hist_id, hist2_id)
+    !
+    IMPLICIT NONE
+    
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT(in)      :: nbpt               !! Domain size (unitless)
+    INTEGER(i_std), INTENT(in)      :: index(nbpt)        !! Indices of the points on the map (unitless)
+    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 of each grid box in X and Y (m)
+    REAL(r_std), INTENT(in)         :: contfrac(nbpt)     !! Fraction of land in each grid box (unitless;0-1)
+    INTEGER(i_std),INTENT (in)      :: hist_id            !! Access to history file (unitless)
+    INTEGER(i_std),INTENT (in)      :: hist2_id           !! Access to history file 2 (unitless)
+    !
+!! LOCAL VARIABLES
+    REAL(r_std), DIMENSION(nbpt)    :: nbrivers           !! Number of rivers in the grid (unitless)
+    REAL(r_std), DIMENSION(nbpt)    :: basinmap           !! Map of basins (unitless)
+    REAL(r_std), DIMENSION(nbp_glo) :: nbrivers_g         !! Number of rivers in the grid (unitless)
+    REAL(r_std), DIMENSION(nbp_glo) :: basinmap_g         !! Map of basins (unitless)
+
+!_ ================================================================================================================================
+    routing_area => routing_area_glo  
+    topo_resid => topo_resid_glo
+    route_togrid => route_togrid_glo
+    route_tobasin => route_tobasin_glo
+    route_nbintobas => route_nbintobas_glo
+    global_basinid => global_basinid_glo
+    hydrodiag=>hydrodiag_glo
+    hydroupbasin=>hydroupbasin_glo
+    
+    IF (is_root_prc) CALL routing_diagnostic(nbp_glo, index_g, lalo_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
+    route_nbintobas => route_nbintobas_loc
+    global_basinid => global_basinid_loc
+    hydrodiag=>hydrodiag_loc
+    hydroupbasin=>hydroupbasin_loc
+    
+    CALL scatter(nbrivers_g,nbrivers)
+    CALL scatter(basinmap_g,basinmap)
+    CALL scatter(hydrodiag_glo,hydrodiag_loc)
+    CALL scatter(hydroupbasin_glo,hydroupbasin_loc)
+       
+    CALL xios_orchidee_send_field("basinmap",basinmap)
+    CALL xios_orchidee_send_field("nbrivers",nbrivers)
+
+    IF ( .NOT. almaoutput ) THEN
+       CALL histwrite_p(hist_id, 'basinmap', 1, basinmap, nbpt, index)
+       CALL histwrite_p(hist_id, 'nbrivers', 1, nbrivers, nbpt, index)
+    ELSE
+    ENDIF
+    IF ( hist2_id > 0 ) THEN
+       IF ( .NOT. almaoutput ) THEN
+          CALL histwrite_p(hist2_id, 'basinmap', 1, basinmap, nbpt, index)
+          CALL histwrite_p(hist2_id, 'nbrivers', 1, nbrivers, nbpt, index)
+       ELSE
+       ENDIF
+    ENDIF
+    
+        
+  END SUBROUTINE routing_diagnostic_p
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: routing_diagnostic
+!!
+!> BRIEF         This non-parallelized subroutine gives a diagnostic of the basins used. This produces some information 
+!!               on the rivers which are being diagnosed.
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : As not all rivers can be monitored in the model, we will only
+!! archive num_largest rivers. In this routine we will diagnose the num_largest largest rivers and print to the standard
+!! output the names of these basins and their area. The list of names of these largest rivers are taken from a list coded in the 
+!! routine routing_names. As this standard output is not sufficient, we will also write it to a netCDF file with the routine 
+!! routing_diagncfile. It is important to keep for diagnostic the fraction of the largest basins in each grid box and keep information
+!! how they are linked one to the other.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): No output variables.
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    :None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE routing_diagnostic(nbpt, l_index, lalo, resolution, contfrac, nbrivers, basinmap)
+    !
+    IMPLICIT NONE
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT(in)                   :: nbpt                !! Domain size  (unitless)
+    INTEGER(i_std), INTENT(in)                   :: l_index(nbpt)       !! Indices of the points on the map (unitless)
+    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 of each grid box in X and Y (m)
+    REAL(r_std), INTENT(in)                      :: contfrac(nbpt)      !! Fraction of land in each grid box (unitless;0-1)
+    !
+!! OUTPUT VARIABLES
+    REAL(r_std), DIMENSION(nbpt), INTENT(out)    :: nbrivers            !! Number of rivers in the grid (unitless)
+    REAL(r_std), DIMENSION(nbpt), INTENT(out)    :: basinmap            !! Map of basins (unitless)
+    !
+!! LOCAL VARIABLES
+    INTEGER(i_std), DIMENSION(nbpt,nbasmax)      :: outids              !! IDs of river to which this basin contributes (unitless)
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)  :: pts                 !! List the points belonging to the basin (unitless)
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)  :: ptbas               !! List the basin number for this point (unitless)
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)  :: outpt               !! Outflow point for each basin (unitless)
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)    :: nb_pts              !! Number of points in the basin (unitless)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:)       :: totarea             !! Total area of basin (m^2)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:)       :: tmparea             !! 
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)    :: topids              !! The IDs of the first num_largest basins (unitless)
+    CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:) :: basin_names         !! Names of the rivers (unitless)
+    CHARACTER(LEN=25)                            :: name_str            !!
+    !
+    LOGICAL                                      :: river_file          !! Choose to write a description of the rivers (true/false)
+    CHARACTER(LEN=80)                            :: river_file_name     !! Filename in which we write the description of the rivers (unitless)
+    !
+    CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:)  :: sorted_names       !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: streams_nb         !! Number of streams in basin (unitless)
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: streams_avehops    !! Average number of hops in streams (unitless)
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: streams_minhops    !! Minimum number of hops in streams (unitless)
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: streams_maxhops    !! Minimum number of hops in streams (unitless)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:)        :: streams_resid      !! Average residence time
+    !
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lbasin_area        !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lbasin_uparea      !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: lrivercode         !!
+    !
+    INTEGER(i_std)                                :: ig, ib, og, ob, ign, ibn, ff(1), ic, icc, nb_small, idbas, slen, ii !! Indices (unitless)
+    CHARACTER(LEN=1)                              :: nn                 !!
+    INTEGER(i_std)                                :: name_found         !!
+    !
+    REAL(r_std)                                   :: averesid           !!
+    REAL(r_std), DIMENSION(nbasmax)               :: tmpbas             !!
+    REAL(r_std), DIMENSION(nbpt,nbasmax)          :: areaupbasin        !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: sortedrivs         !!
+    !
+    ! Variables for the river coding
+    !
+    INTEGER(i_std)                               :: longest_river       !!
+    INTEGER(i_std)                               :: nbmax               !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)  :: allstreams          !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: upstreamchange      !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)    :: tstreams, tslen, tpts, tptbas, tcode !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:)       :: tuparea             !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:)       :: tupstreamchange     !!
+    !
+    LOGICAL                                      :: err_nbpt_grid_basin !! (true/false)
+    LOGICAL                                      :: err_basin_number    !! (true/false)
+
+!_ ================================================================================================================================
+    !
+    !
+    ALLOCATE(pts(num_largest, nbpt))
+    ALLOCATE(ptbas(num_largest, nbpt))
+    ALLOCATE(outpt(num_largest, 2))
+    ALLOCATE(nb_pts(num_largest))
+    ALLOCATE(totarea(num_largest), tmparea(num_largest))
+    ALLOCATE(topids(num_largest))
+    ALLOCATE(sortedrivs(num_largest))
+    ALLOCATE(sorted_names(num_largest))
+    ALLOCATE(streams_nb(num_largest), streams_avehops(num_largest), streams_minhops(num_largest))
+    ALLOCATE(streams_maxhops(num_largest))
+    ALLOCATE(streams_resid(num_largest))
+    !
+    ALLOCATE(lbasin_area(num_largest,nbpt), lbasin_uparea(num_largest,nbpt), lrivercode(num_largest,nbpt))
+    !
+    IF ( .NOT. is_root_prc) THEN
+       WRITE(numout,*) "routing_diagnostic is not suitable for running in parallel"
+       WRITE(numout,*) "We are here on a non root processor. is_root_prc = ", is_root_prc
+       WRITE(numout,*) "STOP from routing_diagnostic"
+       STOP
+    ENDIF
+    ! 
+    !
+    !Config Key   = RIVER_DESC
+    !Config Desc  = Writes out a description of the rivers
+    !Config If    = RIVER_ROUTING
+    !Config Def   = n
+    !Config Help  = This flag allows to write out a file containing the list of 
+    !Config         rivers which are beeing simulated. It provides location of outflow
+    !Config         drainage area, name and ID.
+    !Config Units = [FLAG]
+    !
+    river_file=.FALSE.
+    CALL getin('RIVER_DESC', river_file)
+    !
+    !Config Key   = RIVER_DESC_FILE
+    !Config Desc  = Filename in which we write the description of the rivers. If suffix is ".nc" a netCDF file is created
+    !Config If    = RIVER_DESC
+    !Config Def   = river_desc.txt
+    !Config Help  = File name where we will write the information. If the suffix is ".nc" a netCDF file is generated. Else
+    !Config         a simple text file will contain some information. The netCDF file is valuable for post-processing the
+    !               data as it will contain the fraction of the large basins in each grid box.
+    !Config Units = [FILE]
+    !
+    river_file_name="river_desc.txt"
+    CALL getin('RIVER_DESC_FILE', river_file_name)
+    !
+    !
+    ! 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
+    areaupbasin(:,:) = zero
+    outids(:,:) = -1
+    ob = -1
+    og = -1
+    lbasin_area(:,:) = zero
+    lbasin_uparea(:,:) = zero
+    longest_river = 0
+    !
+    err_nbpt_grid_basin = .FALSE.
+    loopgridbasin : DO ig=1,nbpt
+       !
+       DO ib=1,nbasmax
+          IF ( routing_area(ig,ib) .GT. zero ) THEN
+             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)
+                areaupbasin(og, ob) = areaupbasin(og, ob) + routing_area(ig,ib)
+             ENDDO
+             !
+             longest_river = MAX(longest_river, ic)
+             !
+             ! 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.
+                      !
+                      nb_pts(icc) = nb_pts(icc) + 1
+                      !
+                      !
+                      IF ( nb_pts(icc) > nbpt ) THEN
+                         err_nbpt_grid_basin = .TRUE.
+                         EXIT loopgridbasin
+                      ENDIF
+                      !
+                      pts(icc, nb_pts(icc)) = ig
+                      ptbas(icc, nb_pts(icc)) = ib
+                      totarea(icc) = totarea(icc) + routing_area(ig,ib)
+                      !
+                      lbasin_area(icc,nb_pts(icc)) = routing_area(ig,ib)
+                      !
+                      ! ID of the river is taken from the last point before the outflow.
+                      topids(icc) = global_basinid(og,ob)
+                      outids(ig,ib) = global_basinid(og,ob)
+                      !
+                      ! On this gridbox and basin we will diagnose the hydrograph
+                      !
+                      hydrodiag(ig, ib) = 1
+                      !
+                   ENDIF
+                ENDDO
+             ENDIF
+          ENDIF
+          !
+       ENDDO
+       !
+    ENDDO loopgridbasin
+    !
+    IF ( err_nbpt_grid_basin ) THEN
+       WRITE(numout, *) "routing_diagnostic : The number of grid points in basin ", icc
+       WRITE(numout, *) "routing_diagnostic : is larger than anticiped. "
+       CALL ipslerr_p(3, 'routing_diagnostic', 'We are heading for a out of bounds in arrays pts, ptsbas and lbasin_area.',&
+                     & 'Increase the last dimension of these arrays.','')
+    ENDIF
+    !
+    ! Now we decide which points we will keep from the largest basins
+    !
+    ! Temporary fix
+    route_nbintobas(:,:) = 0
+    !
+    basinmap(:) = zero
+    DO ig=1,nbpt
+       !
+       ! Look for the dominant basin in this grid. This information only affects some
+       ! diagnostics : hydrographs and saved area upstream.
+       !
+       icc = 0
+       idbas = -1
+       !
+       DO ib=1,nbasmax
+          IF ( outids(ig,ib) > 0 ) THEN
+             IF ( COUNT(outids(ig,:) == outids(ig,ib)) > icc ) THEN
+                icc = COUNT(outids(ig,:) == outids(ig,ib))
+                idbas = outids(ig,ib)
+             ENDIF
+          ENDIF
+       ENDDO
+       !
+       ! If we have found a point from the large basins and decided which one
+       ! takes over this grid then we note it on the map.
+       ! Clean-up a little the hydrodiag array
+       !
+       IF ( idbas > 0 ) THEN
+          basinmap(ig) = REAL(idbas, r_std)
+       ENDIF
+       !
+       ! Now place the hydrograph diagnostic on the point closest to the
+       ! ocean.
+       !
+       tmpbas(:) = zero
+       DO ib=1,nbasmax
+          IF ( outids(ig,ib) .EQ. idbas) THEN
+             tmpbas(ib) = areaupbasin(ig,ib)
+          ENDIF
+       ENDDO
+       hydrodiag(ig,:) = 0
+       ff=MAXLOC(tmpbas)
+       hydrodiag(ig,ff(1)) = 1
+       hydroupbasin(ig) = areaupbasin(ig,ff(1))
+       !
+    ENDDO
+    !
+    !
+    !
+    tmparea(:) = totarea(:)
+    DO icc = 1, num_largest
+       ff = MAXLOC(tmparea)
+       sortedrivs(icc) = ff(1)
+       tmparea(ff(1)) = 0.0
+    ENDDO
+    !
+    ! Diagnose the complexity of the basins obtained and determine their code in the Pfafstetter system
+    !
+    nbmax=MAXVAL(nb_pts)
+    ALLOCATE(allstreams(nbmax, longest_river), upstreamchange(nbmax, longest_river))
+    ALLOCATE(tstreams(longest_river), tupstreamchange(longest_river))
+    ALLOCATE(tslen(nbmax), tpts(nbmax), tptbas(nbmax), tuparea(nbmax))
+    ALLOCATE(tcode(nbmax))
+    !
+    DO icc = 1, num_largest
+       !
+       ! Work through the largest basins
+       !
+       idbas = sortedrivs(icc)
+       !
+       streams_nb(idbas) = 0
+       streams_avehops(idbas) = 0
+       streams_minhops(idbas) = undef_int
+       streams_maxhops(idbas) = 0
+       streams_resid(idbas) = zero
+       tslen(:) = 0
+       !
+       allstreams(:,:) = 0
+       upstreamchange(:,:) = zero
+       !
+       DO ii=1,nb_pts(idbas)
+          !
+          ig = pts(idbas, ii)
+          ib = ptbas(idbas, ii)
+          !
+          lbasin_uparea(idbas,ii) = areaupbasin(ig,ib)
+          !
+          slen = 0
+          ign = ig
+          ibn = ib
+          og = ig
+          ob = ib
+          !
+          averesid = zero
+          tupstreamchange(:) = zero
+          ! go to outflow point to count the number of hops
+          DO WHILE (ibn .GT. 0 .AND. ibn .LE. nbasmax)
+             ! Store data
+             slen = slen + 1
+             tstreams(slen) = ign
+             tupstreamchange(slen) = areaupbasin(ign,ibn)-areaupbasin(og,ob)
+             ! Move to next point
+             og = ign
+             ob = ibn
+             ign = route_togrid(og, ob)
+             ibn = route_tobasin(og, ob)
+             averesid = averesid + topo_resid(og, ob)**2
+          ENDDO
+          !
+          allstreams(ii,1:slen) = tstreams(slen:1:-1)
+          upstreamchange(ii,1:slen) = tupstreamchange(slen:1:-1)
+          tslen(ii) = slen
+          !
+          ! Save diagnostics
+          !
+          streams_nb(idbas) = streams_nb(idbas) + 1
+          streams_avehops(idbas) = streams_avehops(idbas) + slen
+          streams_resid(idbas) = streams_resid(idbas) + SQRT(averesid)
+          IF ( slen < streams_minhops(idbas) ) THEN
+             streams_minhops(idbas) = slen
+          ENDIF
+          IF ( slen > streams_maxhops(idbas) ) THEN
+             streams_maxhops(idbas) = slen
+          ENDIF
+          !
+       ENDDO
+       ! build the average
+       IF ( streams_nb(idbas) > 0 ) THEN
+          streams_avehops(idbas) = streams_avehops(idbas)/streams_nb(idbas)
+          streams_resid(idbas) = streams_resid(idbas)/REAL(streams_nb(idbas), r_std)
+       ELSE
+          ! River without streams ... very rare but happens
+          streams_avehops(idbas) = zero
+          streams_resid(idbas) = zero
+          streams_maxhops(idbas) = zero
+          streams_minhops(idbas) = zero
+       ENDIF
+       !
+       !
+       ii=nb_pts(idbas)
+       tpts(:) = 0
+       tpts(1:ii) = pts(idbas,1:ii)
+       tptbas(:) = 0
+       tptbas(1:ii) = ptbas(idbas,1:ii)
+       tuparea(:) = 0
+       tuparea(1:ii) = lbasin_uparea(idbas,1:ii)
+       !
+       CALL routing_diagcode(ii, tpts, tptbas, tuparea, tslen, MAXVAL(tslen), allstreams, upstreamchange, tcode)  
+       !
+       lrivercode(idbas,:) = 0
+       lrivercode(idbas,1:ii) = tcode(1:ii)
+       !
+    ENDDO
+    !
+    ! Create the sorted list of names
+    !
+    err_basin_number = .FALSE.
+    DO icc = 1, num_largest
+       !
+       ib=sortedrivs(icc)
+       !
+       IF ( topids(ib) .GT. nb_small ) THEN
+          IF (topids(ib) <= 99 ) THEN
+             WRITE(sorted_names(icc), '("Nb_",I2.2)') topids(ib)
+          ELSE IF (topids(ib) <= 999 ) THEN
+             WRITE(sorted_names(icc), '("Nb_",I3.3)') topids(ib)
+          ELSE IF (topids(ib) <= 9999 ) THEN
+             WRITE(sorted_names(icc), '("Nb_",I4.4)') topids(ib)
+          ELSE IF (topids(ib) <= 99999 ) THEN
+             WRITE(sorted_names(icc), '("Nb_",I5.5)') topids(ib)
+          ELSE IF (topids(ib) <= 999999 ) THEN
+             WRITE(sorted_names(icc), '("Nb_",I6.6)') topids(ib)
+          ELSE
+             err_basin_number = .TRUE.
+             EXIT
+          ENDIF
+
+       ELSE
+          sorted_names(icc) = basin_names(topids(ib))
+       ENDIF
+       !
+    ENDDO
+    !
+    IF ( err_basin_number ) THEN
+       CALL ipslerr_p(3, 'routing_diagnostic', 'We found a basin number larger than 999999.',&
+            & 'This is impossible. Please verify your configuration.','')
+    ENDIF
+    !
+    ! Check for doubles and rename if needed
+    !
+    DO icc = 1, num_largest
+       name_found=0
+       DO ic=1, num_largest
+          IF ( TRIM(sorted_names(icc)) == TRIM(sorted_names(ic)) ) THEN
+             name_found = name_found + 1
+          ENDIF
+       ENDDO
+       !
+       IF ( name_found > 1 ) THEN
+          DO ic=num_largest,1,-1
+             IF ( TRIM(sorted_names(icc)) == TRIM(sorted_names(ic)) ) THEN
+                IF ( name_found > 1 ) THEN
+                   WRITE(nn,'(I1)')  name_found
+                   sorted_names(ic) = TRIM(sorted_names(ic))//nn
+                   name_found = name_found - 1
+                ENDIF
+             ENDIF
+          ENDDO
+       ENDIF
+       !
+    ENDDO
+    !
+    ! Print to stdout on ROOT_PROC the diagnostics for the largest basins we have found.
+    !
+    DO icc = 1, num_largest
+       !
+       IF ( nb_pts(sortedrivs(icc)) .GT. 2 ) THEN
+          name_str = sorted_names(icc)
+          WRITE(numout,'("Basin ID ", I5," ", A15, " Area [km^2] : ", F13.4, " Nb points : ", I4)')&
+               & topids(sortedrivs(icc)), name_str(1:15), totarea(sortedrivs(icc))/1.e6,  nb_pts(sortedrivs(icc))
+          ENDIF
+          !
+    ENDDO
+    !
+    ! Save some of the basin information into files.
+    !
+    IF ( river_file ) THEN
+
+       IF ( INDEX(river_file_name,".nc") > 1 ) THEN
+
+          CALL routing_diagncfile(river_file_name, nbpt, lalo, nb_pts, topids, sorted_names, sortedrivs, &
+               &                  pts, lbasin_area, lbasin_uparea, lrivercode, outpt, streams_nb, streams_avehops, &
+               &                  streams_minhops, streams_maxhops, streams_resid)
+
+       ELSE
+
+          OPEN(diagunit, FILE=river_file_name)
+          WRITE(diagunit,'(A)') "Basin ID, Area [km^2], Nb points, Lon and Lat of outflow"
+          WRITE(diagunit,'(A)') "Nb streams, total number of hops, min, ave and max number of hops per stream"
+          !
+          DO icc = 1, num_largest
+             !
+             IF ( nb_pts(sortedrivs(icc)) .GT. 2 ) THEN
+                !
+                name_str = sorted_names(icc)
+                !
+                WRITE(diagunit,'(I5,A25,F14.5,I5,2F9.2)') topids(sortedrivs(icc)), name_str(1:15), totarea(sortedrivs(icc))/1.e6, &
+                     &    nb_pts(sortedrivs(icc)), lalo(outpt(sortedrivs(icc),1),2), lalo(outpt(sortedrivs(icc),1),1)
+                WRITE(diagunit,'(5I9,F16.4)') streams_nb(sortedrivs(icc)), &
+                     & streams_avehops(sortedrivs(icc))*streams_nb(sortedrivs(icc)), &
+                     & streams_minhops(sortedrivs(icc)), &
+                     & streams_avehops(sortedrivs(icc)), &
+                     & streams_maxhops(sortedrivs(icc)), streams_resid(sortedrivs(icc))
+                !
+             ENDIF
+             !
+          ENDDO
+          !
+          CLOSE(diagunit)
+          !
+       ENDIF
+       !
+    ENDIF
+    !
+    !
+    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, tmparea)
+    DEALLOCATE(streams_nb, streams_avehops, streams_minhops, streams_maxhops)
+    !
+    DEALLOCATE(lbasin_area, lbasin_uparea, lrivercode)
+    !
+    DEALLOCATE(allstreams)
+    DEALLOCATE(tstreams)
+    DEALLOCATE(tslen, tpts, tptbas, tuparea)
+    DEALLOCATE(tcode)
+    !
+    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. 0.)/ic
+    WRITE(numout,*) 'Minimum topographic index :', MINVAL(topo_resid, MASK=topo_resid .GT. 0.)
+    !
+    !
+  END SUBROUTINE routing_diagnostic
+  !
+!! ================================================================================================================================
+!! SUBROUTINE 	: routing_diagcode
+!!
+!> BRIEF       This subroutine determines the code in the Pfafstetter system for all points
+!!              within the given catchment.  
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): streamcode
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    :None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE routing_diagcode(ip, tpts, tpbas, tuparea, tslen, ls, allstreams, upstreamchange, streamcode)  
+    !
+    IMPLICIT NONE
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT(in)                   :: ip             !!
+    INTEGER(i_std), INTENT(in)                   :: ls             !!
+    INTEGER(i_std), DIMENSION(ip), INTENT(in)    :: tpts           !!
+    INTEGER(i_std), DIMENSION(ip), INTENT(in)    :: tpbas          !!
+    REAL(r_std), DIMENSION(ip), INTENT(in)       :: tuparea        !!
+    INTEGER(i_std), DIMENSION(ip), INTENT(in)    :: tslen          !!
+    INTEGER(i_std), DIMENSION(ip,ls), INTENT(in) :: allstreams     !!
+    REAL(r_std), DIMENSION(ip,ls), INTENT(in)    :: upstreamchange !!
+    !
+!! OUTPUT VARIABLES
+    INTEGER(i_std), DIMENSION(ip), INTENT(out)   :: streamcode     !!
+    !
+!! LOCAL VARIABLES
+    INTEGER(i_std)                               :: ilev, cntsubbas, ib, ic, i, it, ilevmax, imaxlen, nbzero !!
+    INTEGER(i_std)                               :: tstreamcode(ip)!!
+    INTEGER(i_std)                               :: indsubbas(ip)  !!
+    INTEGER(i_std)                               :: iw(ip)         !!
+    INTEGER(i_std)                               :: tdiff(ip)      !!
+    INTEGER(i_std)                               :: tmpjunc(4)     !!
+    INTEGER(i_std)                               :: junction(4)    !!
+    INTEGER(i_std)                               :: ff(1)          !!
+    INTEGER(i_std)                               :: ll             !!
+    REAL(r_std)                                  :: chguparea(ip)  !!
+    REAL(r_std)                                  :: largest        !!
+
+!_ ================================================================================================================================
+    !
+    streamcode(:) = 0
+    !
+    ! If we accept 4 grid boxes per coded basin then per level we need at least
+    ! 4*9=36 boxes.
+    !
+    ilevmax = 0
+    it = ip
+    DO WHILE (it >= 36)
+       ilevmax = ilevmax+1
+       it = it/9
+    ENDDO
+    !
+    DO ilev=1,ilevmax
+       !
+       ! Count number of sub-basins we already have
+       !
+       cntsubbas=0
+       tstreamcode(:) = streamcode(:)
+       DO WHILE ( COUNT(tstreamcode(:) >= 0) > 0 )
+         cntsubbas=cntsubbas+1
+         indsubbas(cntsubbas) = MAXVAL(tstreamcode(:))
+         WHERE ( tstreamcode(:) == indsubbas(cntsubbas) ) tstreamcode = -1
+       ENDDO
+       !
+       ! Go through all these basins in order to find the next Pfafstetter numbers
+       !
+       DO ib=1,cntsubbas
+          !
+          ! Get all the streams which have the current Pfadstetter number
+          !
+          it=0
+          DO ic=1,ip
+             IF ( streamcode(ic) == indsubbas(ib) ) THEN
+                it =it+1
+                iw(it)=ic 
+             ENDIF
+          ENDDO
+          !
+          ! Which is the longest stream in this basin ?
+          !
+          ff=MAXLOC(tslen(iw(1:it)))
+          imaxlen=iw(ff(1))
+          chguparea(:) = zero
+          chguparea(1:tslen(imaxlen)) = upstreamchange(imaxlen, 1:tslen(imaxlen))
+          !
+          IF ( COUNT(chguparea(1:tslen(imaxlen)) > 0) < 4 ) THEN
+             !
+             ! If this subbasin is too small we just set all points to zero
+             !
+             DO i=1,it
+                streamcode(iw(i)) = streamcode(iw(i))*10
+             ENDDO
+          ELSE
+             ! 
+             ! Else do the Pfafstetter numbering
+             ! 
+             !
+             ! Where do we have the 4 largest change in upstream area on this stream.
+             ! This must be the confluence of 2 rivers and thus a junction point.
+             !
+             largest=pi*R_Earth*R_Earth
+             DO i=1,4
+                ff = MAXLOC(chguparea(1:tslen(imaxlen)), MASK = chguparea(1:tslen(imaxlen)) < largest)
+                tmpjunc(i) = ff(1)
+                largest=chguparea(tmpjunc(i))
+             ENDDO
+             ! sort junctions to go from the outflow up-stream
+             ff(1)=0
+             DO i=1,4
+                junction(i) = MINVAL(tmpjunc, MASK=tmpjunc > ff(1))
+                ff(1) = junction(i)
+             ENDDO
+             !
+             ! Find all streams which are identical up to that junction and increase their code accordingly 
+             !
+             DO i=1,it
+                ll=MIN(tslen(imaxlen),tslen(iw(i)))
+                tdiff(1:ll) = allstreams(imaxlen,1:ll)-allstreams(iw(i),1:ll)
+                nbzero = COUNT(tdiff(1:ll) == 0)
+                IF (nbzero < junction(1) ) THEN
+                   ! Before first of the 4 largest basins
+                   streamcode(iw(i)) = streamcode(iw(i))*10+1
+                ELSE IF (nbzero == junction(1) ) THEN
+                   ! Stream part of the first largest basin
+                   streamcode(iw(i)) = streamcode(iw(i))*10+2
+                ELSE IF (nbzero < junction(2) ) THEN
+                   ! Between first and second stream
+                   streamcode(iw(i)) = streamcode(iw(i))*10+3
+                ELSE IF (nbzero == junction(2) ) THEN
+                   ! Stream part of the second basin
+                   streamcode(iw(i)) = streamcode(iw(i))*10+4
+                ELSE IF (nbzero < junction(3) ) THEN
+                   ! In between stream 2 and 3
+                   streamcode(iw(i)) = streamcode(iw(i))*10+5
+                ELSE IF (nbzero == junction(3) ) THEN
+                   ! Part of 3rd basin
+                   streamcode(iw(i)) = streamcode(iw(i))*10+6
+                ELSE IF (nbzero < junction(4) ) THEN
+                   ! In between 3 and 4th basins
+                   streamcode(iw(i)) = streamcode(iw(i))*10+7
+                ELSE IF (nbzero == junction(4) ) THEN
+                   ! Final of the 4 largest basins
+                   streamcode(iw(i)) = streamcode(iw(i))*10+8
+                ELSE
+                   ! The rest of the points and also the basin of the longest stream
+                   streamcode(iw(i)) = streamcode(iw(i))*10+9
+                ENDIF
+             ENDDO
+          ENDIF
+       ENDDO
+       !
+    ENDDO
+    !
+    !
+  END SUBROUTINE routing_diagcode
+  !
+!! ================================================================================================================================
+!! SUBROUTINE 	: routing_diagncfile
+!!
+!> BRIEF         This subroutine creates a netCDF file containing all the informations
+!!                on the largest rivers which can be used for a refined analysis. 
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE routing_diagncfile(river_file_name, nbpt, lalo, nb_pts, topids, sorted_names, sortedrivs, &
+       &       lbasin_index, lbasin_area, lbasin_uparea, lrivercode, outpt, streams_nb, streams_avehops, &
+       &       streams_minhops, streams_maxhops, streams_resid)
+    !
+    USE netcdf
+    !
+    IMPLICIT NONE
+    !
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std)                              :: nbpt                     !! Domain size  (unitless)
+    REAL(r_std), INTENT(in)                     :: lalo(nbpt,2)             !! Vector of latitude and longitudes (beware of the order !)
+
+!! LOCAL VARIABLES
+    CHARACTER(LEN=80)                           :: river_file_name          !! Filename in which we write the description of the rivers (1)
+    INTEGER(i_std), DIMENSION(num_largest)      :: nb_pts                   !! Number of points in the basin (unitless)
+    INTEGER(i_std), DIMENSION(num_largest)      :: topids                   !! The IDs of the first num_largest basins (unitless)
+    CHARACTER(LEN=25), DIMENSION(num_largest)   :: sorted_names             !! Names of the basins to be put into the file (unitless)
+    INTEGER(i_std), DIMENSION(num_largest)      :: sortedrivs               !!
+    INTEGER(i_std), DIMENSION(num_largest,nbpt) :: lbasin_index             !!
+    REAL(r_std), DIMENSION(num_largest,nbpt)    :: lbasin_area              !!
+    REAL(r_std), DIMENSION(num_largest,nbpt)    :: lbasin_uparea            !!
+    INTEGER(i_std), DIMENSION(num_largest,nbpt) :: lrivercode               !!
+    !
+    INTEGER(i_std), DIMENSION(num_largest,2)    :: outpt                    !! Outflow point for each basin (unitless)
+    INTEGER(i_std), DIMENSION(num_largest)      :: streams_nb               !! Number of streams in basin (unitless)
+    INTEGER(i_std), DIMENSION(num_largest)      :: streams_avehops          !! Average number of hops in streams (unitless)
+    INTEGER(i_std), DIMENSION(num_largest)      :: streams_minhops          !! Minimum number of hops in streams (unitless)
+    INTEGER(i_std), DIMENSION(num_largest)      :: streams_maxhops          !! Minimum number of hops in streams (unitless)
+    REAL(r_std), DIMENSION(num_largest)         :: streams_resid            !! Average residence time
+    !
+    INTEGER(i_std)                              :: icc, fid, iret, ierr_tot, ib, ij, ik, i, j, lcc !! Indices (unitless)
+    INTEGER(i_std)                              :: nlonid, nlatid, varid, varid2, varid3
+    INTEGER(i_std)                              :: dims(2)                  !!
+    REAL(r_std)                                 :: lon_min, lon_max, lat_min, lat_max
+    CHARACTER(LEN=80)                           :: lon_name, lat_name, var_name, long_name, nc_name, att_str
+    CHARACTER(LEN=15)                           :: gridtype                 !!
+    !
+    REAL(r_std)                                 :: basinfrac(iim_g,jjm_g)   !!
+    REAL(r_std)                                 :: basinuparea(iim_g,jjm_g) !!
+    INTEGER(i_std)                              :: basincode(iim_g,jjm_g)   !!
+    !
+    LOGICAL                                     :: check=.FALSE.            !! (true/false)
+    !
+!! PARAMETERS
+    INTEGER(i_std),PARAMETER                    :: kind_r_diag=NF90_REAL8   !!
+    INTEGER(i_std),PARAMETER                    :: kind_i_diag=NF90_INT     !!
+
+!_ ================================================================================================================================
+    !
+    !
+    ! 1.0 Create the NETCDF file and store the coordinates.
+    !
+    ! This variable should be defined and computed in the module grid.f90.
+    ! Jan
+    gridtype="regular"
+    !
+    iret = NF90_CREATE(TRIM(river_file_name), NF90_CLOBBER, fid)
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr_p (3,'routing_diagncfile', 'Could not create file :', &
+            & TRIM(river_file_name), '(Problem with disk place or filename ?)')
+    ENDIF
+    !
+    ! 1.1 Define dimensions
+    !
+    IF ( INDEX(gridtype, "regular") == 1 ) THEN
+       !
+       ! 1.1.1 regular grid
+       !
+       iret = NF90_DEF_DIM(fid, 'lon', iim_g, dims(1))
+       IF (iret /= NF90_NOERR) THEN
+          CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "x" can not be defined for the file : ', &
+               &         TRIM(river_file_name),'(Solution ?)')
+       ENDIF
+       iret = NF90_DEF_DIM(fid, 'lat', jjm_g, dims(2))
+       IF (iret /= NF90_NOERR) THEN
+          CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "y" can not be defined for the file : ', &
+               &         TRIM(river_file_name),'(Solution ?)')
+       ENDIF
+    ELSE
+       !
+       ! 1.1.2 irregular grid
+       !
+       iret = NF90_DEF_DIM(fid, 'x', iim_g, dims(1))
+       IF (iret /= NF90_NOERR) THEN
+          CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "x" can not be defined for the file : ', &
+               &         TRIM(river_file_name),'(Solution ?)')
+       ENDIF
+       
+       iret = NF90_DEF_DIM(fid, 'y', jjm_g, dims(2))
+       IF (iret /= NF90_NOERR) THEN
+          CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "y" can not be defined for the file : ', &
+               &         TRIM(river_file_name),'(Solution ?)')
+       ENDIF
+    ENDIF
+    !
+    !
+    ! 1.2 Define variables and attributes
+    !
+    IF ( INDEX(gridtype, "regular") == 1 ) THEN
+       !
+       ! 1.2.1 regular grid
+       !
+       lon_name = 'lon'
+       !
+       iret = NF90_DEF_VAR(fid, lon_name, kind_r_diag, dims(1), nlonid)
+       IF (iret /= NF90_NOERR) THEN
+          CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lon_name//' can not be defined for the file : ', &
+               &         TRIM(river_file_name),'(Solution ?)')
+       ENDIF
+       !
+       lat_name = 'lat'
+       iret = NF90_DEF_VAR(fid, lat_name, kind_r_diag, dims(2), nlatid)
+       IF (iret /= NF90_NOERR) THEN
+          CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lat_name//' can not be defined for the file : ', &
+               &         TRIM(river_file_name),'(Solution ?)')
+       ENDIF
+       !
+    ELSE
+       !
+       ! 1.2.2 irregular grid
+       !
+       lon_name = 'nav_lon'
+       !
+       iret = NF90_DEF_VAR(fid, lon_name, kind_r_diag, dims, nlonid)
+       IF (iret /= NF90_NOERR) THEN
+          CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lon_name//' can not be defined for the file : ', &
+               &         TRIM(river_file_name),'(Solution ?)')
+       ENDIF
+       !
+       lat_name = 'nav_lat'
+       iret = NF90_DEF_VAR(fid, lat_name, kind_r_diag, dims, nlatid)
+       IF (iret /= NF90_NOERR) THEN
+          CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lat_name//' can not be defined for the file : ', &
+               &         TRIM(river_file_name),'(Solution ?)')
+       ENDIF
+       !
+    ENDIF
+    !
+    ! 1.3 Add attributes to the coordinate variables
+    !
+    iret = NF90_PUT_ATT(fid, nlonid, 'units', "degrees_east") 
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
+            &          TRIM(river_file_name),'(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_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
+            &          TRIM(river_file_name),'(Solution ?)')
+    ENDIF
+    iret = NF90_PUT_ATT(fid, nlonid, 'valid_max', lon_max)
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
+            &          TRIM(river_file_name),'(Solution ?)')
+    ENDIF
+    !
+    iret = NF90_PUT_ATT(fid, nlonid, 'long_name', "Longitude")
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
+            &          TRIM(river_file_name),'(Solution ?)')
+    ENDIF
+    iret = NF90_PUT_ATT(fid, nlatid, 'units', "degrees_north")
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
+            &          TRIM(river_file_name),'(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_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
+            &          TRIM(river_file_name),'(Solution ?)')
+    ENDIF
+    iret = NF90_PUT_ATT(fid, nlatid, 'valid_max', lat_max)
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
+            &          TRIM(river_file_name),'(Solution ?)')
+    ENDIF
+    iret = NF90_PUT_ATT(fid, nlatid, 'long_name', "Latitude")
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
+            &          TRIM(river_file_name),'(Solution ?)')
+    ENDIF
+    !
+    iret = NF90_ENDDEF(fid)
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr_p (3,'routing_diagncfile', 'Could not end definitions in the file : ', &
+ &          TRIM(river_file_name),'(Solution ?)')
+    ENDIF
+    !
+    !  1.4 Write coordinates
+    !
+    IF ( INDEX(gridtype, "regular") == 1 ) THEN
+       !
+       ! 1.4.1 regular grid
+       !
+       iret = NF90_PUT_VAR(fid, nlonid, lon_g(1:iim_g,1))
+       IF (iret /= NF90_NOERR) THEN
+          CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lon  in the file : ', &
+               &          TRIM(river_file_name),'(Solution ?)')
+       ENDIF
+       !
+       iret = NF90_PUT_VAR(fid, nlatid, lat_g(1,1:jjm_g))
+       IF (iret /= NF90_NOERR) THEN
+          CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lat  in the file : ', &
+               &          TRIM(river_file_name),'(Solution ?)')
+       ENDIF
+    ELSE
+       !
+       ! 1.4.2 irregular grid
+       !
+       iret = NF90_PUT_VAR(fid, nlonid, lon_g)
+       IF (iret /= NF90_NOERR) THEN
+          CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lon  in the file : ', &
+               &          TRIM(river_file_name),'(Solution ?)')
+       ENDIF
+       !
+       iret = NF90_PUT_VAR(fid, nlatid, lat_g)
+       IF (iret /= NF90_NOERR) THEN
+          CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lat  in the file : ', &
+               &          TRIM(river_file_name),'(Solution ?)')
+       ENDIF
+    ENDIF
+    !
+    ! 2.0 Go through all basins and wirte the information into the netCDF file.
+    !
+    DO icc = 1, num_largest
+       !
+       ! 2.1 Compute the fields to be saved in the file
+       !
+       ib=sortedrivs(icc)
+       !
+       !
+       IF ( nb_pts(ib) > 2 ) THEN
+          !
+          basinfrac(:,:) = zero
+          basinuparea(:,:) = zero
+          basincode(:,:) = zero
+          !
+          DO ij=1, nb_pts(ib)
+
+             ik=lbasin_index(ib,ij)
+
+             j = ((index_g(ik)-1)/iim_g) + 1
+             i = (index_g(ik)-(j-1)*iim_g)
+
+             basinfrac(i,j) = basinfrac(i,j) + lbasin_area(ib,ij)/(resolution_g(ik,1)*resolution_g(ik,2))
+             basinuparea(i,j) = MAX(basinuparea(i,j), lbasin_uparea(ib,ij))
+             basincode(i,j) = lrivercode(ib,ij)
+
+          ENDDO
+          !
+          DO i=1,iim_g
+             DO j=1,jjm_g
+                IF ( basinfrac(i,j) <= EPSILON(zero) ) THEN
+                   basinfrac(i,j) = undef_sechiba
+                   basinuparea(i,j)  = undef_sechiba
+                   basincode(i,j)  = undef_int
+                ELSE
+                   basinfrac(i,j) = MAX(basinfrac(i,j), un)
+                ENDIF 
+             ENDDO
+          ENDDO
+          !
+          ! 
+          ! 2.2 Define the variables in the netCDF file
+          !
+          iret = NF90_REDEF(fid)
+          IF (iret /= NF90_NOERR) THEN
+             CALL ipslerr_p (3,'routing_diagncfile', &
+                  &          'Could not restart definitions in the file : ', &
+                  &          TRIM(river_file_name),'(Solution ?)')
+          ENDIF
+          !
+          ! Create a name more suitable for a variable in a netCDF file
+          !
+          nc_name =  TRIM(sorted_names(icc))
+          ! Take out all character which could cause problems
+          lcc=LEN_TRIM(nc_name)
+          DO ij=1,lcc
+             IF ( nc_name(ij:ij) == " " ) nc_name(ij:ij) = "_"
+             IF ( nc_name(ij:ij) == "(" ) nc_name(ij:ij) = "_"
+             IF ( nc_name(ij:ij) == ")" ) nc_name(ij:ij) = "_"
+          ENDDO
+          ! reduce redundant "__"
+          DO ij=1,lcc
+             IF ( nc_name(ij:ij+1) == "__" ) nc_name(ij+1:)=nc_name(ij+2:lcc)
+          ENDDO
+          lcc=LEN_TRIM(nc_name)
+          IF ( nc_name(lcc:lcc) == "_" ) nc_name(lcc:lcc) = " "
+          !
+          !
+          ! 2.3 Fraction variable
+          !
+          IF (check) WRITE(*,*) "Define Fraction variable and add attributes"
+          !
+          var_name =  TRIM(nc_name)//"_frac"
+          !
+          iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_r_diag, dims, varid)
+          IF (iret /= NF90_NOERR) THEN
+             CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
+                  &         TRIM(river_file_name),'(Solution ?)')
+          ENDIF
+          !
+          ierr_tot = 0
+          ! Units
+          iret = NF90_PUT_ATT(fid, varid, 'units', "-")
+          IF (iret /= NF90_NOERR) THEN
+             WRITE(*,*) 'Units',  iret
+             WRITE(*,*) TRIM(NF90_STRERROR(iret))
+             ierr_tot = ierr_tot + 1
+          ENDIF
+          ! Long name
+          long_name = "Fraction of basin "//TRIM(sorted_names(icc))//" per grid box"
+          iret = NF90_PUT_ATT(fid, varid, 'long_name', long_name)
+          IF (iret /= NF90_NOERR) THEN
+             WRITE(*,*) 'Long_Name', long_name, iret
+             WRITE(*,*) TRIM(NF90_STRERROR(iret))
+             ierr_tot = ierr_tot + 1
+          ENDIF
+          ! Missing value
+          iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+          IF (iret /= NF90_NOERR) THEN
+             WRITE(*,*) 'Missing value', undef_sechiba, iret
+             WRITE(*,*) TRIM(NF90_STRERROR(iret))
+             ierr_tot = ierr_tot + 1
+          ENDIF
+          !
+          ib=sortedrivs(icc)
+          IF ( check ) WRITE(*,*) "Doing basin ", icc," corrsdponding to index = ", ib, "num_largest : ", num_largest
+          !
+          ! Nb of grid points in basin
+          att_str='Nb_of_grid_points_in_basin'
+          iret = NF90_PUT_ATT(fid, varid, att_str, nb_pts(ib))
+          IF (iret /= NF90_NOERR) THEN
+             WRITE(*,*) 'Nb of grid points in basin', nb_pts(ib), iret
+             WRITE(*,*) TRIM(NF90_STRERROR(iret))
+             ierr_tot = ierr_tot + 1
+          ENDIF
+          !
+          ! Longitude of outflow point 
+          att_str='Longitude_of_outflow_point'
+          iret = NF90_PUT_ATT(fid, varid, att_str, lalo(outpt(ib,1),2))
+          IF (iret /= NF90_NOERR) THEN
+             WRITE(*,*) 'Longitude of outflow point', lalo(outpt(ib,1),2), iret
+             WRITE(*,*) TRIM(NF90_STRERROR(iret))
+             ierr_tot = ierr_tot + 1
+          ENDIF
+          !
+          ! Latitide of outflow point
+          att_str='Latitude_of_outflow_point'
+          iret = NF90_PUT_ATT(fid, varid, att_str, lalo(outpt(ib,1),1))
+          IF (iret /= NF90_NOERR) THEN
+             WRITE(*,*) 'Latitude of outflow point',  lalo(outpt(ib,1),1), iret
+             WRITE(*,*) TRIM(NF90_STRERROR(iret))
+             ierr_tot = ierr_tot + 1
+          ENDIF
+          !
+          ! Number of streams
+          att_str= 'Number_of_streams'
+          iret = NF90_PUT_ATT(fid, varid, att_str, streams_nb(ib))
+          IF (iret /= NF90_NOERR) THEN
+             WRITE(*,*) 'Number of streams', streams_nb(ib), iret
+             WRITE(*,*) TRIM(NF90_STRERROR(iret))
+             ierr_tot = ierr_tot + 1
+          ENDIF
+          !
+          ! Total number of hops to go to the oceans
+          att_str='Total_number_of_hops_to_ocean'
+          iret = NF90_PUT_ATT(fid, varid, att_str, streams_avehops(ib)*streams_nb(ib))
+          IF (iret /= NF90_NOERR) THEN
+             WRITE(*,*) 'Total number of hops to go to the oceans ', streams_avehops(ib)*streams_nb(ib), iret
+             ierr_tot = ierr_tot + 1
+          ENDIF
+          !
+          ! Minimum number of hops to go to the ocean for any stream
+          att_str='Minimum_number_of_hops_to_ocean_for_any_stream'
+          iret = NF90_PUT_ATT(fid, varid, att_str, streams_minhops(ib))
+          IF (iret /= NF90_NOERR) THEN
+             WRITE(*,*) 'Minimum number of hops to go tp the ocean for any stream', streams_minhops(ib), iret
+             ierr_tot = ierr_tot + 1
+          ENDIF
+          !
+          ! Average number of hops to go to the ocean for any stream 
+          att_str='Average_number_of_hops_to_ocean_for_any_stream'
+          iret = NF90_PUT_ATT(fid, varid, att_str, streams_avehops(ib))
+          IF (iret /= NF90_NOERR) THEN
+             WRITE(*,*) 'Average number of hops to go tp the ocean for any stream', streams_avehops(ib), iret
+             ierr_tot = ierr_tot + 1
+          ENDIF
+          !
+          ! Maximum number of hops to go to the ocean for any stream 
+          att_str='Maximum_number_of_hops_to_ocean_for_any_stream'
+          iret = NF90_PUT_ATT(fid, varid, att_str, streams_maxhops(ib))
+          IF (iret /= NF90_NOERR) THEN
+             WRITE(*,*) 'Maximum number of hops to go tp the ocean for any stream', streams_maxhops(ib), iret
+             ierr_tot = ierr_tot + 1
+          ENDIF
+          !
+          ! Average residence time in the basin
+          att_str='Average_residence_time_in_basin'
+          iret = NF90_PUT_ATT(fid, varid, att_str, streams_resid(ib))
+          IF (iret /= NF90_NOERR) THEN
+             WRITE(*,*) 'Average residence time in the basin', streams_resid(ib), iret
+             ierr_tot = ierr_tot + 1
+          ENDIF
+          !
+          IF (ierr_tot > 0 ) THEN
+             CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
+                  &          TRIM(river_file_name),'(Solution ?)')
+          ENDIF
+          !
+          ! 2.4 Upstream area variable variable
+          !
+          IF (check) WRITE(*,*) "Define Upstream variable and add attributes"
+          !
+          ! Create a name more suitable for a variable in a netCDF file
+          !
+          var_name =  TRIM(nc_name)//"_upstream"
+          DO ij=1,LEN_TRIM(var_name)
+             IF ( var_name(ij:ij) == " " ) var_name(ij:ij) = "_"
+          ENDDO
+          !
+          iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_r_diag, dims, varid2)
+          IF (iret /= NF90_NOERR) THEN
+             CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
+                  &         TRIM(river_file_name),'(Solution ?)')
+          ENDIF
+          !
+          ierr_tot = 0
+          ! Units
+          iret = NF90_PUT_ATT(fid, varid2, 'units', "m^2")
+          IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
+          ! Long name
+          long_name = "Upstream area of basin "//TRIM(sorted_names(icc))//" in the grid box"
+          iret = NF90_PUT_ATT(fid, varid2, 'long_name', long_name)
+          IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
+          ! Missing value
+          iret = NF90_PUT_ATT(fid, varid2, 'missing_value', undef_sechiba)
+          IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
+          !
+          IF (ierr_tot > 0 ) THEN
+             CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
+                  &          TRIM(river_file_name),'(Solution ?)')
+          ENDIF
+          !
+          ! 2.5 Pfafstetter codes for basins
+          !
+          IF (check) WRITE(*,*) "Define Pfafstetter codes variable and add attributes"
+          !
+          var_name =  TRIM(nc_name)//"_coding"
+          DO ij=1,LEN_TRIM(var_name)
+             IF ( var_name(ij:ij) == " " ) var_name(ij:ij) = "_"
+          ENDDO
+          !
+          iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_i_diag, dims, varid3)
+          IF (iret /= NF90_NOERR) THEN
+             CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
+                  &         TRIM(river_file_name),'(Solution ?)')
+          ENDIF
+          !
+          ierr_tot = 0
+          ! Units
+          iret = NF90_PUT_ATT(fid, varid3, 'units', "-")
+          IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
+          ! Long name
+          long_name = "Pfafstetter codes of grid boxes in basin "//TRIM(sorted_names(icc))
+          iret = NF90_PUT_ATT(fid, varid3, 'long_name', long_name)
+          IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
+          ! Missing value
+          iret = NF90_PUT_ATT(fid, varid3, 'missing_value', undef_int)
+          IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
+          !
+          IF (ierr_tot > 0 ) THEN
+             CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
+                  &          TRIM(river_file_name),'(Solution ?)')
+          ENDIF
+          !
+          ! 2.6 ENDDEF of netCDF file
+          !
+          IF (check) WRITE(*,*) "END define"
+          !
+          iret = NF90_ENDDEF(fid)
+          IF (iret /= NF90_NOERR) THEN
+             CALL ipslerr_p (3,'routing_diagncfile', &
+                  &          'Could not end definitions in the file : ', &
+                  &          TRIM(river_file_name),'(Solution ?)')
+          ENDIF
+          !
+          ! 2.7 Write the data to the file
+          !
+          IF (check) WRITE(*,*) "Put basinfrac"
+          iret = NF90_PUT_VAR(fid, varid, basinfrac)
+          IF (iret /= NF90_NOERR) THEN
+             CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable basinfrac in the file : ', &
+                  &          TRIM(river_file_name),'(Solution ?)')
+          ENDIF
+
+          IF (check) WRITE(*,*) "Put basinuparea"
+          iret = NF90_PUT_VAR(fid, varid2, basinuparea)
+          IF (iret /= NF90_NOERR) THEN
+             CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable basinuparea in the file : ', &
+                  &          TRIM(river_file_name),'(Solution ?)')
+          ENDIF
+
+          IF (check) WRITE(*,*) "Put basincode"
+          iret = NF90_PUT_VAR(fid, varid3, basincode)
+          IF (iret /= NF90_NOERR) THEN
+             CALL ipslerr_p (3,'routing_diagfile', 'Could not put variable basincode in the file : ', &
+                  &          TRIM(river_file_name),'(Solution ?)')
+          ENDIF
+          !
+       ENDIF
+       !
+    ENDDO
+    !
+    IF (check) WRITE(*,*) "Close file"
+    !
+    ! Close netCDF file and do some memory management.
+    !
+    iret = NF90_CLOSE(fid)
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr_p (3,'routing_diagncfile', &
+            &          'Could not end definitions in the file : ', &
+            &          TRIM(river_file_name),'(Solution ?)')
+    ENDIF
+    !
+    !
+  END SUBROUTINE routing_diagncfile
+  !
+!! ================================================================================================================================
+!! SUBROUTINE 	: routing_basins_p
+!!
+!> BRIEF        This parallelized subroutine computes the routing map if needed. 
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac)
+    !
+    IMPLICIT NONE
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT(in) :: nbpt               !! Domain size (unitless)
+    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) (unitless)
+    REAL(r_std), INTENT(in)    :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
+    REAL(r_std), INTENT(in)    :: contfrac(nbpt)     !! Fraction of land in each grid box (unitless;0-1)
+
+!_ ================================================================================================================================
+
+!    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
+    route_nbintobas => route_nbintobas_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
+    route_nbintobas => route_nbintobas_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(route_nbintobas_glo,route_nbintobas_loc)
+    CALL scatter(global_basinid_glo,global_basinid_loc)
+    
+  END SUBROUTINE routing_basins_p
+  ! 
+ 
+!! ================================================================================================================================
+!! SUBROUTINE 	: routing_basins
+!!
+!> BRIEF        This non-parallelized subroutine reads in the map of basins and flow direction to construct
+!!              the catchments of each grid box. 
+!!
+!! DESCRIPTION (definitions, functional, design, flags) :
+!! 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 the 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 the global fields.
+!! Then we work on the global grid to perform the following tasks :
+!!  1) We link up the basins of the various grid points and check the global consistency.
+!!  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.\n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): None, as the routine puts information into the global variables of the module.
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE routing_basins(nbpt, lalo, neighbours, resolution, contfrac)
+    !
+    IMPLICIT NONE
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT(in)                    :: nbpt                  !! Domain size (unitless)
+    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) (unitless)
+    REAL(r_std), INTENT(in)                       :: resolution(nbpt,2)    !! The size of each grid box in X and Y (m)
+    REAL(r_std), INTENT(in)                       :: contfrac(nbpt)        !! Fraction of land in each grid box (unitless;0-1)
+    !
+!! LOCAL VARIABLES
+    CHARACTER(LEN=80)                             :: filename              !! Name of the netcdf file (unitless)
+    INTEGER(i_std)                                :: iml, jml, lml, tml, fid, ib, ip, jp, fopt !! Indices (unitless)
+    REAL(r_std)                                   :: lev(1), date, dt, coslat
+    INTEGER(i_std)                                :: itau(1)               !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: trip                  !! The trip field (unitless)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: basins                !! The basin field (unitless)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: topoindex             !! Topographic index of the residence time (m)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: hierarchy             !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lat_rel               !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lon_rel               !!
+    !
+    INTEGER(i_std)                                :: nbi, nbj              !! Number of point in x and y within the grid (unitless)
+    REAL(r_std)                                   :: min_topoind           !! The current minimum of topographic index (m)
+    REAL(r_std)                                   :: max_basins            !!
+    REAL(r_std)                                   :: invented_basins       !!
+    !
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: area_bx               !! Area of each small box in the grid box (m^2)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: hierarchy_bx          !! Level in the basin of the point
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lon_bx                !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lat_bx                !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: topoind_bx            !! Topographic index of the residence time for each of the smaller boxes (m)
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: trip_bx               !! The trip field for each of the smaller boxes (unitless)
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: basin_bx              !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: coast_pts             !! The coastal flow points (unitless)
+    !
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: basin_count           !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: basin_id              !!
+    REAL(r_std),  ALLOCATABLE, DIMENSION(:,:)     :: basin_area            !!
+    REAL(r_std),  ALLOCATABLE, DIMENSION(:,:)     :: basin_hierarchy       !!
+    REAL(r_std),  ALLOCATABLE, DIMENSION(:,:)     :: basin_topoind         !! Topographic index of the residence time for a basin (m)
+    REAL(r_std),  ALLOCATABLE, DIMENSION(:,:)     :: fetch_basin           !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: basin_flowdir         !! Water flow directions in the basin (unitless)
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: outflow_grid          !! Type of outflow on the grid box (unitless)
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: outflow_basin         !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: inflow_number         !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_basin          !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_grid           !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: nbcoastal             !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: coastal_basin         !!
+    !
+    ! Interpolation help variables
+    !
+    INTEGER(i_std)                                :: nix, njx              !!
+    CHARACTER(LEN=30)                             :: callsign              !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:)    :: resol_lu              !! Resolution
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: mask                  !! Mask to exclude some points (unitless)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: sub_area              !! Area on the fine grid (m^2)
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: sub_index             !! Indices of the points we need on the fine grid (unitless)
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: sub_pts               !! Number of high resolution points on this grid (unitless)
+    INTEGER                                       :: ALLOC_ERR             !!
+    LOGICAL                                       :: ok_interpol = .FALSE. !! Flag for interpolation (true/false)
+    !
+    INTEGER(i_std)                                :: nb_basin              !! Number of sub-basins (unitless)
+    INTEGER(i_std)                                :: nwbas                 !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: basin_inbxid          !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: basin_sz              !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: basin_bxout           !!
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: basin_pts             !!
+    CHARACTER(LEN=7)                              :: fmt                   !!
+    LOGICAL                                       :: debug = .FALSE.       !! (true/false)
+    !
+    INTEGER(i_std), DIMENSION(2)                  :: diagbox = (/ 1, 2 /)  !!
+
+!_ ================================================================================================================================
+    !
+    !
+    IF ( .NOT. is_root_prc) THEN
+       WRITE(numout,*) "is_root_prc = ", is_root_prc
+       CALL ipslerr_p (3,'routing_basins', &
+            &          'routing_basins is not suitable for running in parallel', &
+            &          'We are here on a non root processor. ','(STOP from routing_basins)')
+    ENDIF
+    !
+    ! Test on diagbox and nbpt
+    !
+    IF (debug) THEN
+       IF (ANY(diagbox .GT. nbpt)) THEN 
+          WRITE(numout,*) "Debug diganostics : nbpt, diagbox", nbpt, diagbox
+          call ipslerr_p(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
+    !
+    !
+    !  Needs to be a configurable variable
+    !
+    !
+    !Config Key   = ROUTING_FILE
+    !Config Desc  = Name of file which contains the routing information
+    !Config If    = RIVER_ROUTING
+    !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.
+    !Config Units = [FILE]
+    !
+    filename = 'routing.nc'
+    CALL getin('ROUTING_FILE',filename)
+    !
+    CALL flininfo(filename,iml, jml, lml, tml, fid)
+    CALL flinclo(fid)
+    !
+    ! 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 (routing_basins): ",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 (routing_basins): ",ALLOC_ERR
+      STOP 
+    ENDIF
+    !
+    ALLOC_ERR=-1
+    ALLOCATE (trip(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of trip (routing_basins): ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE (basins(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of basins (routing_basins): ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE (topoindex(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of topoindex (routing_basins): ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE (hierarchy(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of hierarchy (routing_basins): ",ALLOC_ERR
+      STOP 
+    ENDIF
+    !
+    !
+    CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
+    !!
+    !! From the basin description data we will read the following variables :
+    !!
+    !! Trip : Provides the flow direction following the convention :
+    !! 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
+    !!
+    !! Basins : Provides a uniqe ID for each basin. These IDs are also used to get
+    !! the name of the basin from the table in routine routing_names.
+    !! 
+    !! Topoind :  is the topographic index for the retention time of the water in the
+    !! grid box. It has been computed with the following formula : 1000 x sqrt(d^3/Dz) 
+    !! where d is the distance of the river from the current grid box to the next one
+    !! as indicated by the variable trip.
+    !! Dz the hight difference between between the two grid boxes.
+    !! All these variables are in meters.
+    !! Furthermore  we have to limit the height difference to 5m in order to avoid any unpleasant
+    !! surprises. If dz < 5m then dz=5.
+    !!
+    !
+    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)
+    !
+    min_topoind = MINVAL(topoindex, MASK=topoindex .LT. undef_sechiba-un)
+    !
+    DO ip=1,iml
+       DO jp=1,jml
+          IF ( trip(ip,jp) < 1.e10 .AND. topoindex(ip,jp) > 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
+    !
+    ALLOC_ERR=-1
+    ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of resol_lu : ",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
+    !
+    ! Consider all points a priori
+    !
+    mask(:,:) = 0
+    !
+    DO ip=1,iml
+       DO jp=1,jml
+          !
+          ! Determine the land mask of the basin map read from the file ROUTING_FILE
+          !
+          IF ( trip(ip,jp) < 1.e10 ) THEN
+             mask(ip,jp) = 1
+          ENDIF
+          !
+          ! Resolution in longitude
+          !
+          coslat = MAX( COS( lat_rel(ip,jp) * pi/180. ), mincos )     
+          IF ( ip .EQ. 1 ) THEN
+             resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip,jp) ) * pi/180. * R_Earth * coslat
+          ELSEIF ( ip .EQ. iml ) THEN
+             resol_lu(ip,jp,1) = ABS( lon_rel(ip,jp) - lon_rel(ip-1,jp) ) * pi/180. * R_Earth * coslat
+          ELSE
+             resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat
+          ENDIF
+          !
+          ! Resolution in latitude
+          !
+          IF ( jp .EQ. 1 ) THEN
+             resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp) - lat_rel(ip,jp+1) ) * pi/180. * R_Earth
+          ELSEIF ( jp .EQ. jml ) THEN
+             resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp) ) * pi/180. * R_Earth
+          ELSE
+             resol_lu(ip,jp,2) =  ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp+1) )/2. * pi/180. * R_Earth
+          ENDIF
+          !
+       ENDDO
+    ENDDO
+    !
+    ! The maximum number of points of the source map (basin description here) which can fit into
+    ! any grid point of the ORCHIDEE grid is stimated here.
+    ! Some margin is taken.
+    !
+    callsign = "routing_basins"
+    ok_interpol = .FALSE.
+    !  
+    nix=INT(MAXVAL(resolution_g(:,1))/MAXVAL(resol_lu(:,:,1)))+2
+    njx=INT(MAXVAL(resolution_g(:,2))/MAXVAL(resol_lu(:,:,2)))+2
+    nbvmax = nix*njx*2
+    !
+    ! We are on the root processor here as this routine is not in parallel. So no need to broadcast.
+    !
+    WRITE(numout,*) "Projection arrays for ",callsign," : "
+    WRITE(numout,*) "Routing : nbvmax = ", nbvmax
+    !
+    !
+    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
+    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_pts(nbpt), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+       WRITE(numout,*) "ERROR IN ALLOCATION of sub_pts : ",ALLOC_ERR
+       STOP 
+    ENDIF
+    sub_pts(:)=0
+    !
+    ! routine aggregate will for each point of the ORCHIDEE grid determine which points
+    ! of the source grid (basin definitions here) fit in there and which fraction of
+    ! of the ORCHIDEE grid it represents.
+    !
+    CALL aggregate(nbpt, lalo, neighbours, resolution, contfrac, &
+         &                iml, jml, lon_rel, lat_rel, mask, callsign, &
+         &                nbvmax, sub_index, sub_area, ok_interpol)
+    !
+    WHERE (sub_area < 0) sub_area=zero
+    !
+    ! Some verifications
+    !
+    DO ib=1,nbpt
+       sub_pts(ib) = COUNT(sub_area(ib,:) > zero)
+       DO fopt=1,sub_pts(ib)
+          IF (sub_area(ib, fopt) == 0 ) THEN
+             WRITE(numout,*) "Zero Area - Sub_area > 0 : ", ib, fopt
+             WRITE(numout,*) "Zero Area - lon : ",lalo(ib,2)
+             WRITE(numout,*) "Zero Area - lon_rel : ", lon_rel(sub_index(ib, fopt, 1),sub_index(ib, fopt, 2))
+             WRITE(numout,*) "Zero Area - lat : ",lalo(ib,1)
+             WRITE(numout,*) "Zero Area - lat_rel : ", lat_rel(sub_index(ib, fopt, 1),sub_index(ib, fopt, 2))
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    ! Do some memory management.
+    !
+    nwbas = MAXVAL(sub_pts)
+    !
+    ALLOCATE (area_bx(nbvmax,nbvmax))
+    ALLOCATE (hierarchy_bx(nbvmax,nbvmax))
+    ALLOCATE (lon_bx(nbvmax,nbvmax))
+    ALLOCATE (lat_bx(nbvmax,nbvmax))
+    ALLOCATE (topoind_bx(nbvmax,nbvmax))
+    ALLOCATE (trip_bx(nbvmax,nbvmax))
+    ALLOCATE (basin_bx(nbvmax,nbvmax))
+    ALLOCATE (coast_pts(nbvmax))
+    !
+    ALLOCATE (basin_inbxid(nbvmax))
+    ALLOCATE (basin_sz(nbvmax))
+    ALLOCATE (basin_pts(nbvmax,nbvmax,2))
+    ALLOCATE (basin_bxout(nbvmax))
+    !
+    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
+    !
+    !! Finds,in each grid box, the distance to the outflow point ... this defines the order in which
+    !! the water will go through the sub-basins and grid boxes.
+    !
+    CALL routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
+    !
+    !
+    DO ib =1, nbpt
+       !
+       !
+       !  extract the information for this grid box
+       !
+       !! Extracts from the global high resolution fields the data for the current 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)
+       !
+       !! Finds the basins: returns the list of all points which are within the same basin of the grid box.
+       !
+       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 coastal flow.
+       !
+       IF ( debug .AND. (COUNT(diagbox .EQ. ib) .GT. 0) ) THEN
+          WRITE(numout,*) '===================== IB = :', ib
+          WRITE(numout,*) "sub_pts(ib) :", sub_pts(ib), "sub_area(ib,:) :",sub_area(ib,1:2)
+          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
+       !
+       !! Puts the basins found for the current grid box in the context of the global map.
+       !
+       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
+    !
+    !! Makes the connections between the bains and ensures global coherence.
+    !
+    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
+    !
+    !! Computes the fetch of each basin, upstream area in known.
+    !
+    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."
+    !
+    !! Reduces the number of basins per grid to the value chosen by the user.
+    !
+    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 (mask)
+    DEALLOCATE (resol_lu)
+    !
+    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
+!!
+!> BRIEF         This subroutine extracts from the global high resolution fields
+!!               the data for the current grid box we are dealing with.
+!!
+!! DESCRIPTION (definitions, functional, design, flags) :
+!! 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).:\n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  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
+    !
+!!  INPUT VARIABLES
+    INTEGER(i_std), INTENT(in)  :: nbpt                        !! Domain size (unitless)
+    INTEGER(i_std), INTENT(in)  :: iml                         !! X resolution of the high resolution grid
+    INTEGER(i_std), INTENT(in)  :: jml                         !! Y resolution of the high resolution grid
+    INTEGER(i_std), INTENT(in)  :: ib                          !! Current basin (unitless)
+    INTEGER(i_std), INTENT(in)  :: sub_pts(nbpt)               !! Number of high resolution points on this grid (unitless)
+    INTEGER(i_std), INTENT(in)  :: sub_index(nbpt,nbvmax,2)    !! Indices of the points we need on the fine grid (unitless)
+    REAL(r_std), INTENT(inout)  :: max_basins                  !! The current maximum of basins
+    REAL(r_std), INTENT(in)     :: min_topoind                 !! The current minimum of topographic index (m)
+    REAL(r_std), INTENT(in)     :: sub_area(nbpt,nbvmax)       !! Area on the fine grid (m^2)
+    REAL(r_std), INTENT(in)     :: lon_rel(iml,jml)            !!
+    REAL(r_std), INTENT(in)     :: 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 of each grid box in X and Y (m)
+    REAL(r_std), INTENT(in)     :: contfrac(nbpt)              !! Fraction of land in each grid box (unitless;0-1)
+    REAL(r_std), INTENT(inout)  :: trip(iml,jml)               !! The trip field (unitless)
+    REAL(r_std), INTENT(inout)  :: basins(iml,jml)             !! data on the fine grid
+    REAL(r_std), INTENT(inout)  :: topoindex(iml,jml)          !! Topographic index of the residence time (m)
+    REAL(r_std), INTENT(inout)  :: hierarchy(iml, jml)         !! data on the fine grid
+    !
+!!  OUTPUT VARIABLES
+    INTEGER(i_std), INTENT(out) :: nbi, nbj                    !! Number of point in x and y within the grid (unitless)
+    REAL(r_std), INTENT(out)    :: area_bx(nbvmax,nbvmax)      !! Area of each small box in the grid box (m^2)
+    REAL(r_std), INTENT(out)    :: hierarchy_bx(nbvmax,nbvmax) !! Level in the basin of the point
+    REAL(r_std), INTENT(out)    :: lon_bx(nbvmax,nbvmax)       !!
+    REAL(r_std), INTENT(out)    :: lat_bx(nbvmax,nbvmax)       !!
+    REAL(r_std), INTENT(out)    :: topoind_bx(nbvmax,nbvmax)   !! Topographic index of the residence time for each of the smaller boxes (m)
+    INTEGER(i_std), INTENT(out) :: trip_bx(nbvmax,nbvmax)      !! The trip field for each of the smaller boxes (unitless)
+    INTEGER(i_std), INTENT(out) :: basin_bx(nbvmax,nbvmax)     !!
+    !
+!! LOCAL VARIABLES
+    INTEGER(i_std)              :: ip, jp, ll(1), iloc, jloc   !! Indices (unitless)
+    REAL(r_std)                 :: lonstr(nbvmax*nbvmax)       !!
+    REAL(r_std)                 :: 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
+!!
+!> BRIEF         This subroutines orders the coordinates to go from North to South and West to East.
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE routing_sortcoord(nb_in, coords, direction, nb_out)
+    !
+    IMPLICIT NONE
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT(in)   :: nb_in             !!
+    REAL(r_std), INTENT(inout)   :: coords(nb_in)     !!
+    !
+!! OUTPUT VARIABLES
+    INTEGER(i_std), INTENT(out)  :: nb_out            !!
+    !
+!! LOCAL VARIABLES
+    CHARACTER(LEN=2)             :: direction         !!
+    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
+!!
+!> BRIEF         This subroutine finds 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.
+!!
+!! DESCRIPTION (definitions, functional, design, flags) :
+!!  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    \n
+!! -------------------    \n
+!! Inside of the box :    \n
+!! trip = 1 : flow = N    \n
+!! trip = 2 : flow = NE    \n
+!! trip = 3 : flow = E    \n
+!! trip = 4 : flow = SE    \n
+!! trip = 5 : flow = S    \n
+!! trip = 6 : flow = SW    \n
+!! trip = 7 : flow = W    \n
+!! trip = 8 : flow = NW    \n
+!! trip = 97 : return flow into the ground    \n
+!! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here    \n
+!! trip = 99 : river flow into the oceans    \n
+!!
+!! Out flow from the grid :    \n
+!! trip = 101 : flow = N out of the coarse grid    \n
+!! trip = 102 : flow = NE out of the coarse grid    \n
+!! trip = 103 : flow = E out of the coarse grid    \n
+!! trip = 104 : flow = SE out of the coarse grid    \n
+!! trip = 105 : flow = S out of the coarse grid    \n
+!! trip = 106 : flow = SW out of the coarse grid    \n
+!! trip = 107 : flow = W out of the coarse grid    \n
+!! trip = 108 : flow = NW out of the coarse grid!    \n
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE routing_findbasins(nbi, nbj, trip, basin, hierarchy, topoind, nb_basin, basin_inbxid, basin_sz,&
+       & basin_bxout, basin_pts, coast_pts)
+    !
+    IMPLICIT NONE
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT(in)    :: nbi                          !! Number of point in x within the grid (unitless)
+    INTEGER(i_std), INTENT(in)    :: nbj                          !! Number of point in y within the grid (unitless)
+    REAL(r_std), INTENT(in)       :: hierarchy(:,:)               !!
+    REAL(r_std), INTENT(in)       :: topoind(:,:)                 !! Topographic index of the residence time (m)
+    !
+    !  Modified
+    INTEGER(i_std), INTENT(inout) :: trip(:,:)                    !! The trip field (unitless)
+    INTEGER(i_std), INTENT(inout) :: basin(:,:)                   !!
+    !
+!! OUTPUT VARIABLES
+    INTEGER(i_std), INTENT(out)   :: nb_basin                     !! Number of sub-basins (unitless)
+    INTEGER(i_std), INTENT(out)   :: basin_inbxid(nbvmax)         !!
+    INTEGER(i_std), INTENT(out)   :: basin_sz(nbvmax)             !!
+    INTEGER(i_std), INTENT(out)   :: basin_bxout(nbvmax)          !!
+    INTEGER(i_std), INTENT(out)   :: basin_pts(nbvmax, nbvmax, 2) !!
+    INTEGER(i_std), INTENT(out)   :: coast_pts(nbvmax)            !! The coastal flow points (unitless)
+    !
+!! LOCAL VARIABLES
+    INTEGER(i_std)                :: ibas, ilf, nbb, nb_in        !!
+    INTEGER(i_std)                :: bname(nbvmax)                !!
+    INTEGER(i_std)                :: sz(nbvmax)                   !!
+    INTEGER(i_std)                :: pts(nbvmax,nbvmax,2)         !!
+    INTEGER(i_std)                :: nbout(nbvmax)                !!
+    INTEGER(i_std)                :: new_nb                       !!
+    INTEGER(i_std)                :: new_bname(nbvmax)            !!
+    INTEGER(i_std)                :: new_sz(nbvmax)               !!
+    INTEGER(i_std)                :: new_pts(nbvmax,nbvmax,2)     !!
+    INTEGER(i_std)                :: itrans                       !!
+    INTEGER(i_std)                :: trans(nbvmax)                !!
+    INTEGER(i_std)                :: 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
+    ibas = -1
+    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
+!!
+!> BRIEF         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 and grid box.
+!!               But here we will not change the direction of the outflow.  
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE routing_simplify(nbi, nbj, trip, basin, hierarchy, basin_inbxid)
+    !
+    IMPLICIT NONE
+    !
+!! LOCAL VARIABLES
+    INTEGER(i_std)                             :: nbi                        !! Number of point in x within the grid (unitless)
+    INTEGER(i_std)                             :: nbj                        !! Number of point in y within the grid (unitless)
+    INTEGER(i_std)                             :: trip(:,:)                  !! The trip field (unitless)
+    INTEGER(i_std)                             :: basin(:,:)                 !!
+    REAL(r_std)                                :: hierarchy(:,:)             !!
+    INTEGER(i_std)                             :: basin_inbxid               !!
+    !
+    INTEGER(i_std)                             :: ip, jp, nbout, basin_sz, iborder !!
+    INTEGER(i_std), DIMENSION(nbvmax,nbvmax)   :: trip_tmp                   !! Temporary trip field which only contains the values for the basin on which we currently work (1)
+    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 !! Indices (unitless)
+    INTEGER(i_std), DIMENSION(nbvmax)          :: todopt                     !!
+!!$, todosz
+    REAL(r_std), DIMENSION(nbvmax)             :: todohi                     !!
+    LOGICAL                                    :: not_found, debug = .FALSE. !! (true/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 smallest 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
+!!
+!> BRIEF        This subroutine cuts the original basin which has more than one outflow
+!!              into as many subbasins as outflow directions.  
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE routing_cutbasin (nbi, nbj, nbbasins, trip, basin, basin_inbxid, nb, bname, sz, pts)
+    !
+    IMPLICIT NONE
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT(in)                 :: nbi, nbj             !! Number of point in x and y within the grid (unitless)
+    INTEGER(i_std), INTENT(in)                 :: nbbasins             !!
+    INTEGER(i_std), INTENT(in)                 :: basin_inbxid         !!
+    !
+    !  Modified
+    INTEGER(i_std), INTENT(inout)              :: trip(:,:)            !! The trip field (unitless)
+    INTEGER(i_std), INTENT(inout)              :: basin(:,:)           !!
+    !
+!! OUTPUT VARIABLES
+    INTEGER(i_std), INTENT(out)                :: nb                   !!
+    INTEGER(i_std), INTENT(out)                :: bname(nbvmax)        !!
+    INTEGER(i_std), INTENT(out)                :: sz(nbvmax)           !!
+    INTEGER(i_std), INTENT(out)                :: pts(nbvmax,nbvmax,2) !!
+    !
+!! LOCAL VARIABLES
+    INTEGER(i_std)                             :: ip, jp, iip, jjp, ib, ibb, id, nbout !! Indices (unitless)
+    INTEGER(i_std)                             :: basin_sz             !!
+    INTEGER(i_std)                             :: nb_in                !!
+    INTEGER(i_std), DIMENSION(nbvmax,nbvmax)   :: trip_tmp             !! Temporary trip field which only contains the values for the basin on which we currently work (unitless)
+    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            !! (true/false)
+    LOGICAL                                    :: debug=.FALSE.        !! (true/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
+!!
+!> BRIEF        This subroutine finds, for each point, the distance to the outflow
+!!               point along the flowlines of the basin. 
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
+    !
+    IMPLICIT NONE
+    !
+!! LOCAL VARIABLES
+    INTEGER(i_std)                  :: iml          !! X resolution of the high resolution grid
+    INTEGER(i_std)                  :: jml          !! Y resolution of the high resolution grid
+    REAL(r_std), DIMENSION(iml,jml) :: trip         !! The trip field (unitless)
+    REAL(r_std), DIMENSION(iml,jml) :: hierarchy    !!
+    REAL(r_std), DIMENSION(iml,jml) :: topoindex    !! Topographic index of the residence time (m)
+    !
+    INTEGER(i_std), DIMENSION(8,2)  :: inc          !!
+    INTEGER(i_std)                  :: ip, jp, ib, ntripi, ntripj, cnt, trp !!
+    REAL(r_std)                     :: topohier     !! The new value of topographically weighted hierarchy (m)
+    REAL(r_std)                     :: topohier_old !! The old value of topographically weighted hierarchy (m)
+    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 = NINT(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 = NINT(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
+!!
+!> BRIEF        This subroutine simply computes the route to each outflow point
+!!              and returns the outflow point for each point in the basin.  
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE routing_findrout(nbi, nbj, trip, basin_sz, basinid, nbout, outflow, trip_flow, outsz)
+    !
+    IMPLICIT NONE
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std)                                          :: nbi       !! Number of point in x within the grid (unitless)
+    INTEGER(i_std)                                          :: nbj       !! Number of point in y within the grid (unitless)
+    INTEGER(i_std), DIMENSION(nbvmax,nbvmax)                :: trip      !! The trip field (unitless)
+    INTEGER(i_std)                                          :: basin_sz  !!
+    INTEGER(i_std)                                          :: basinid   !!
+    !
+!! OUTPUT VARIABLES
+    INTEGER(i_std), DIMENSION(nbvmax,2), INTENT(out)        :: outflow   !!
+    INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2), INTENT(out) :: trip_flow !!
+    INTEGER(i_std), INTENT(out)                             :: nbout     !! 
+    INTEGER(i_std), DIMENSION(nbvmax), INTENT(out)          :: outsz     !!
+    !
+!! LOCAL VARIABLES
+    INTEGER(i_std), DIMENSION(8,2)                          :: inc       !!
+    INTEGER(i_std)                                          :: ip, jp, ib, cnt, trp, totsz !! Indices (unitless)
+    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
+!!
+!> BRIEF        This subroutine puts the basins found for grid box in the global map.
+!!               Connection can only be made later when all information is together. 
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!! 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
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+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
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT (in)                :: nbpt                   !! Domain size (unitless)
+    INTEGER(i_std), INTENT (in)                :: ib                     !! Current basin (unitless)
+    INTEGER(i_std), INTENT(in)                 :: neighbours(nbpt,8)     !! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
+    !
+!! LOCAL VARIABLES 
+    REAL(r_std), DIMENSION(nbvmax,nbvmax)      :: area_bx                !! Area of each small box in the grid box (m^2)
+    INTEGER(i_std), DIMENSION(nbvmax,nbvmax)   :: trip_bx                !! The trip field for each of the smaller boxes (unitless)
+    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 of the residence time for each of the smaller boxes (m)
+    REAL(r_std)                                :: min_topoind            !! The current minimum of topographic index (m)
+    INTEGER(i_std)                             :: nb_basin               !! Number of sub-basins (unitless)
+    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 (unitless)
+    ! global maps
+    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          !! Water flow directions in the basin (unitless)
+    REAL(r_std), DIMENSION(nbpt,nwbas)         :: basin_area             !!
+    REAL(r_std), DIMENSION(nbpt,nwbas)         :: basin_hierarchy        !!
+    REAL(r_std), DIMENSION(nbpt,nwbas)         :: basin_topoind          !! Topographic index of the residence time for a basin (m)
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)      :: outflow_grid           !! Type of outflow on the grid box (unitless)
+    INTEGER(i_std), DIMENSION(nbpt)            :: nbcoastal              !!
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)      :: coastal_basin          !!
+    !
+    INTEGER(i_std)                             :: ij, iz                 !! Indices (unitless)
+    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_p(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 smallest 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
+!!
+!> BRIEF         This subroutine makes the connections between the basins and ensure global coherence. 
+!!
+!! DESCRIPTION (definitions, functional, design, flags) :
+!! The convention for outflow_grid is :
+!! outflow_grid = -1 : River flow
+!! outflow_grid = -2 : Coastal flow
+!! outflow_grid = -3 : Return flow\n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+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
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT (in)                    :: nbpt                  !! Domain size  (unitless)
+    INTEGER(i_std), DIMENSION(nbpt,8), INTENT (in) :: neighbours            !!
+    REAL(r_std), INTENT(in)                        :: invented_basins       !!
+    !
+    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         !! Water flow directions in the basin (unitless)
+    REAL(r_std), DIMENSION(nbpt,nwbas)             :: basin_area            !!
+    REAL(r_std), DIMENSION(nbpt,nwbas)             :: basin_hierarchy       !!
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: outflow_grid          !! Type of outflow on the grid box (unitless)
+    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         !!
+    !
+!! LOCAL VARIABLES
+    INTEGER(i_std)                                 :: sp, sb, sbl, inp, bid, outdm1, outdp1 !! Indices (unitless)
+    INTEGER(i_std)                                 :: dp1, dm1, dm1i, dp1i, bp1, bm1 !! Indices (unitless)
+    INTEGER(i_std)                                 :: dop, bop              !!
+    INTEGER(i_std)                                 :: fbas(nwbas), nbfbas   !!
+    REAL(r_std)                                    :: fbas_hierarchy(nwbas) !!
+    INTEGER(i_std)                                 :: ff(1)                 !!
+    !
+    ! ERRORS 
+    LOGICAL                                        :: error1, error2, error3, error4, error5 !! (true/false)
+    !
+!! PARAMETERS
+    LOGICAL, PARAMETER                             :: check = .FALSE.       !! (true/false)
+
+!_ ================================================================================================================================    
+    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,*) 'Coordinates : (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 conditions 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_p(3,'routing_linkup', &
+            "bop .LT. undef_int",'Increase nbvmax','stop routing_linkup')
+    ENDIF
+    IF (error2) THEN
+       CALL ipslerr_p(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_p(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_p(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_p(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
+!!
+!> BRIEF        This subroutine computes 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. 
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id,&
+       & outflow_grid, outflow_basin, fetch_basin)
+    !
+    IMPLICIT NONE
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT(in)                           :: nbpt          !! Domain size  (unitless)
+    !
+    REAL(r_std), DIMENSION(nbpt,2), INTENT(in)           :: resolution    !! The size of each grid box in X and Y (m)
+    REAL(r_std), DIMENSION(nbpt), INTENT(in)             :: contfrac      !! Fraction of land in each grid box (unitless;0-1)
+    !
+    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  !! Type of outflow on the grid box (unitless)
+    INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in)    :: outflow_basin !!
+!
+!! OUTPUT VARIABLES
+    REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(out)      :: fetch_basin   !!
+    !
+!! LOCAL VARIABLES
+    INTEGER(i_std)                                        :: ib, ij, ff(1), it, itt, igrif, ibasf, nboutflow !! Indices (unitless)
+    REAL(r_std)                                           :: contarea     !!
+    REAL(r_std)                                           :: 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 smallest 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
+!!
+!> BRIEF         This subroutine reduces the number of basins per grid 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.  
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : 
+!! 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.:\n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+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
+    !
+!! PARAMETERS
+    INTEGER(i_std), PARAMETER                       :: pickmax = 200  !!
+
+!! INPUT VARIABLES
+    INTEGER(i_std)                                  :: nbpt           !! Domain size  (unitless)
+    !
+    REAL(r_std), DIMENSION(nbpt,2)                  :: resolution     !! The size of each grid box in X and Y (m)
+    REAL(r_std), DIMENSION(nbpt), INTENT(in)        :: contfrac       !! Fraction of land in each grid box (unitless;0-1)
+    !
+    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  !! Water flow directions in the basin (unitless)
+    REAL(r_std), DIMENSION(nbpt,nwbas)              :: basin_area     !!
+    REAL(r_std), DIMENSION(nbpt,nwbas)              :: basin_topoind  !! Topographic index of the residence time for a basin (m)
+    REAL(r_std), DIMENSION(nbpt,nwbas)              :: fetch_basin    !!
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)           :: outflow_grid   !! Type of outflow on the grid box (unitless)
+    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 VARIABLES
+    INTEGER(i_std)                                  :: ib, ij, ibf, ijf, igrif, ibasf, cnt, pold, bold, ff(2) !! Indices (unitless)
+    INTEGER(i_std)                                  :: ii, kbas, sbas, ik, iter, ibt, obj !! Indices (unitless)
+    REAL(r_std), DIMENSION(nbpt,nbasmax)            :: floflo         !!
+    REAL(r_std), DIMENSION(nbpt)                    :: gridarea       !!
+    REAL(r_std), DIMENSION(nbpt)                    :: gridbasinarea  !!
+    REAL(r_std)                                     :: ratio          !!
+    INTEGER(i_std), DIMENSION(pickmax,2)            :: largest_basins !!
+    INTEGER(i_std), DIMENSION(pickmax)              :: tmp_ids        !!
+    INTEGER(i_std)                                  :: multbas        !!
+    INTEGER(i_std)                                  :: iml(1)         !! X resolution of the high resolution grid
+    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     !!
+!$OMP THREADPRIVATE(indextrunc)
+
+!_ ================================================================================================================================
+    !
+    !
+    IF ( .NOT. ALLOCATED(indextrunc)) THEN
+       ALLOCATE(indextrunc(nbpt))
+    ENDIF
+    !
+    ! 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 smallest 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 running into it
+          !   and putting the smallest 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 smallest 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 smallest 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 smallest
+                   !
+                   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 continents
+    !
+    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
+       ELSE
+          WRITE(numout,*) 'gridbasinarea(ib) <= zero. We should stop here :', ib
+       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)
+       ! tdo - To take into account rivers that do not flow to the oceans 
+       IF ( route_tobasin(ff(1), ff(2)) .GT. nbasmax ) THEN
+!       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
+!!
+!> BRIEF        The aim of this subroutine 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.  
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+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
+    !
+    INTEGER(i_std)                              :: tokill        !!
+    INTEGER(i_std)                              :: totakeover    !!
+    INTEGER(i_std)                              :: nbpt          !! Domain size  (unitless)
+    INTEGER(i_std)                              :: ib            !! Current basin (unitless)
+    !
+    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 !! Water flow directions in the basin (unitless)
+    REAL(r_std), DIMENSION(nbpt,nwbas)          :: basin_area    !!
+    REAL(r_std), DIMENSION(nbpt,nwbas)          :: basin_topoind !! Topographic index of the residence time for a basin (m)
+    REAL(r_std), DIMENSION(nbpt,nwbas)          :: fetch_basin   !!
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)       :: outflow_grid  !! Type of outflow on the grid box (unitless)
+    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 VARIABLES
+    INTEGER(i_std)                              :: inf, ibs, ing, inb, ibasf, igrif, it !! Indices (unitless)
+    LOGICAL                                     :: doshift       !! (true/false)
+
+!_ ================================================================================================================================
+    !
+    ! 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
+!!
+!> BRIEF         This subroutine lists the name of the largest basins which are explicitly listed in the basin
+!!               description file used by ORCHIDEE.
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE routing_names(numlar, basin_names)
+    !
+    IMPLICIT NONE
+    !
+    ! Arguments
+    !
+    INTEGER(i_std), INTENT(in)             :: numlar              !!
+    CHARACTER(LEN=*), INTENT(inout)        :: basin_names(numlar) !! Name of the basins (unitless)
+!! PARAMETERS
+    INTEGER(i_std), PARAMETER              :: listleng=349        !!
+    !
+!! LOCAL VARIABLES
+    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) = "Erg Iguidi (Sahara)"
+    list_names(13) = "Chang Jiang (Yangtze)"
+    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) = "Komadugu Yobe (Tchad)"
+    list_names(41) = "Kolyma"
+    list_names(42) = "Sao Francisco"
+    list_names(43) = "Amu-Darya"
+    list_names(44) = "GHAASBasin51"
+    list_names(45) = "Dnepr"
+    list_names(46) = "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) = "GHAASBasin75"
+    list_names(61) = "Parnaiba"
+    list_names(62) = "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) = "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) = "GHAASBasin95"
+    list_names(84) = "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) = "GHAASBasin122"
+    list_names(93) = "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) = "GHAASBasin47"
+    list_names(100) = "GHAASBasin127"
+    list_names(101) = "Hong"
+    list_names(102) = "GHAASBasin97"
+    list_names(103) = "Swan-Avon"
+    list_names(104) = "Rhine"
+    list_names(105) = "Cuanza"
+    list_names(106) = "GHAASBasin106"
+    list_names(107) = "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) = "GHAASBasin165"
+    list_names(115) = "Pyasina"
+    list_names(116) = "Fitzroy East"
+    list_names(117) = "GHAASBasin173"
+    list_names(118) = "Albany"
+    list_names(119) = "Sanaga"
+    list_names(120) = "GHAASBasin120"
+    list_names(121) = "GHAASBasin178"
+    list_names(122) = "GHAASBasin148"
+    list_names(123) = "Brazos (Tex)"
+    list_names(124) = "GHAASBasin124"
+    list_names(125) = "Alabama"
+    list_names(126) = "GHAASBasin174"
+    list_names(127) = "GHAASBasin179"
+    list_names(128) = "Balsas"
+    list_names(129) = "GHAASBasin172"
+    list_names(130) = "Burdekin"
+    list_names(131) = "Colorado (Texas)"
+    list_names(132) = "GHAASBasin150"
+    list_names(133) = "Odra"
+    list_names(134) = "Loire"
+    list_names(135) = "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
+!!
+!> BRIEF         This  subroutine interpolates the 0.5x0.5 degree based map of irrigated areas to the resolution of the model.
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE routing_irrigmap (nbpt, index, lalo, neighbours, resolution, contfrac, &
+       &                       init_irrig, irrigated, init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id)
+    !
+    IMPLICIT NONE
+    !
+!! PARAMETERS
+    INTEGER(r_std), PARAMETER                      :: ilake = 1             !! Number of type of lakes area (unitless)
+    INTEGER(r_std), PARAMETER                      :: idam = 2              !! Number of type of dams area (unitless)
+    INTEGER(r_std), PARAMETER                      :: iflood = 3            !! Number of type of floodplains area (unitless)
+    INTEGER(r_std), PARAMETER                      :: iswamp = 4            !! Number of type of swamps area (unitless)
+    INTEGER(r_std), PARAMETER                      :: isal = 5              !! Number of type of salines area (unitless)
+    INTEGER(r_std), PARAMETER                      :: ipond = 6             !! Number of type of ponds area (unitless)
+    INTEGER(r_std), PARAMETER                      :: ntype = 6             !! Number of types of flooded surfaces (unitless)
+
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT(in)                     :: nbpt                  !! Domain size  (unitless)
+    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 of each grid box in X and Y (m)
+    REAL(r_std), INTENT(in)                        :: contfrac(nbpt)        !! Fraction of land in each grid box (unitless;0-1)
+    INTEGER(i_std), INTENT(in)                     :: hist_id               !! Access to history file (unitless)
+    INTEGER(i_std), INTENT(in)                     :: hist2_id              !! Access to history file 2 (unitless)
+    LOGICAL, INTENT(in)                            :: init_irrig            !! Logical to initialize the irrigation (true/false)
+    LOGICAL, INTENT(in)                            :: init_flood            !! Logical to initialize the floodplains (true/false)
+    LOGICAL, INTENT(in)                            :: init_swamp            !! Logical to initialize the swamps (true/false)
+    !
+!! OUTPUT VARIABLES
+    REAL(r_std), INTENT(out)                       :: irrigated(:)          !! Irrigated surface in each grid box (m^2)
+    REAL(r_std), INTENT(out)                       :: floodplains(:)        !! Surface which can be inundated in each grid box (m^2)
+    REAL(r_std), INTENT(out)                       :: swamp(:)              !! Surface which can be swamp in each grid box (m^2)
+    !
+!! LOCAL VARIABLES
+    ! Interpolation variables
+    ! 
+    INTEGER(i_std)                                 :: nbpmax, nix, njx, fopt !!
+    CHARACTER(LEN=30)                              :: callsign              !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:)     :: resol_lu              !! Resolution read on the map
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)    :: mask                  !! Mask to exclude some points (unitless)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)       :: sub_area              !! Area on the fine grid (m^2)
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:)  :: sub_index             !! Indices of the points we need on the fine grid (unitless)
+    INTEGER                                        :: ALLOC_ERR             !!
+    LOGICAL                                        :: ok_interpol = .FALSE. !! Flag for interpolation (true/false)
+    !
+    CHARACTER(LEN=80)                              :: filename              !! Name of the netcdf file (unitless)
+    INTEGER(i_std)                                 :: iml, jml, lml, tml, fid, ib, ip, jp, itype !! Indices (unitless)
+    REAL(r_std)                                    :: lev(1), date, dt, coslat !!
+    INTEGER(i_std)                                 :: itau(1)               !!
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)       :: latrel                !! Latitude
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)       :: lonrel                !! Longitude
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)       :: irrigated_frac        !! Irrigated fraction of the grid box (unitless;0-1)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:)     :: flood_fracmax         !! Maximal flooded fraction of the grid box (unitless;0-1)
+    REAL(r_std)                                    :: area_irrig            !! Irrigated surface in the grid box (m^2)
+    REAL(r_std)                                    :: area_flood(ntype)     !! Flooded surface in the grid box (m^2)
+!!$    REAL(r_std)                                :: irrigmap(nbpt)
+!!$    REAL(r_std)                                :: floodmap(nbpt)
+!!$    REAL(r_std)                                :: swampmap(nbpt)
+
+!_ ================================================================================================================================
+
+    !
+    !Config Key   = IRRIGATION_FILE
+    !Config Desc  = Name of file which contains the map of irrigated areas
+    !Config Def   = floodplains.nc
+    !Config If    = DO_IRRIGATION OR DO_FLOODPLAINS
+    !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).
+    !Config Units = [FILE]
+    !
+    filename = 'floodplains.nc'
+    CALL getin_p('IRRIGATION_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)
+    !
+    !
+    ALLOC_ERR=-10
+    ALLOCATE (latrel(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of latrel : ",ALLOC_ERR, iml, jml
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE (lonrel(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lonrel : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE (irrigated_frac(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of irrigated_frac : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE (flood_fracmax(iml,jml,ntype), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of flood_fracmax : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    !
+    IF (is_root_prc) CALL flinopen(filename, .FALSE., iml, jml, lml, lonrel, latrel, lev, tml, itau, date, dt, fid)
+    CALL bcast(lonrel)
+    CALL bcast(latrel)
+    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, 'lake', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,ilake))
+    IF (is_root_prc) CALL flinget(fid, 'dam', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,idam))
+    IF (is_root_prc) CALL flinget(fid, 'flood', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iflood))
+    IF (is_root_prc) CALL flinget(fid, 'swamp', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iswamp))
+    IF (is_root_prc) CALL flinget(fid, 'saline', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,isal))
+    CALL bcast(flood_fracmax)
+    !
+    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
+          !
+          DO itype=1,ntype
+             IF ( flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN
+                flood_fracmax(ip,jp,itype) = flood_fracmax(ip,jp,itype)/100
+                IF ( flood_fracmax(ip,jp,itype) < 0.005 )  flood_fracmax(ip,jp,itype) = zero
+             ENDIF
+          ENDDO
+          !
+       ENDDO
+    ENDDO
+    !
+    WRITE(numout,*) 'lonrel : ', MAXVAL(lonrel), MINVAL(lonrel)
+    WRITE(numout,*) 'latrel : ', MAXVAL(latrel), MINVAL(latrel)
+    WRITE(numout,*) 'irrigated_frac : ', MINVAL(irrigated_frac, MASK=irrigated_frac .GT. 0), &
+         &                          MAXVAL(irrigated_frac, MASK=irrigated_frac .LT. undef_sechiba)
+    WRITE(numout,*) 'flood_fracmax : ', MINVAL(flood_fracmax, MASK=flood_fracmax .GT. 0), &
+         &                      MAXVAL(flood_fracmax, MASK=flood_fracmax .LT. undef_sechiba)
+    !
+    ! Consider all points a priori
+    !
+    ALLOC_ERR=-1
+    ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of resol_lu : ",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
+    !
+    mask(:,:) = 0
+    !
+    DO ip=1,iml
+       DO jp=1,jml
+          !
+          ! Exclude the points where we are close to the missing value.
+          !
+!MG This condition cannot be applied in floodplains/swamps configuration because
+!   the same mask would be used for the interpolation of irrigation, floodplains and swamps maps.
+!          IF ( irrigated_frac(ip,jp) < undef_sechiba ) THEN
+             mask(ip,jp) = 1
+!          ENDIF
+          !
+          ! Resolution in longitude
+          !
+          coslat = MAX( COS( latrel(ip,jp) * pi/180. ), mincos )     
+          IF ( ip .EQ. 1 ) THEN
+             resol_lu(ip,jp,1) = ABS( lonrel(ip+1,jp) - lonrel(ip,jp) ) * pi/180. * R_Earth * coslat
+          ELSEIF ( ip .EQ. iml ) THEN
+             resol_lu(ip,jp,1) = ABS( lonrel(ip,jp) - lonrel(ip-1,jp) ) * pi/180. * R_Earth * coslat
+          ELSE
+             resol_lu(ip,jp,1) = ABS( lonrel(ip+1,jp) - lonrel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat
+          ENDIF
+          !
+          ! Resolution in latitude
+          !
+          IF ( jp .EQ. 1 ) THEN
+             resol_lu(ip,jp,2) = ABS( latrel(ip,jp) - latrel(ip,jp+1) ) * pi/180. * R_Earth
+          ELSEIF ( jp .EQ. jml ) THEN
+             resol_lu(ip,jp,2) = ABS( latrel(ip,jp-1) - latrel(ip,jp) ) * pi/180. * R_Earth
+          ELSE
+             resol_lu(ip,jp,2) =  ABS( latrel(ip,jp-1) - latrel(ip,jp+1) )/2. * pi/180. * R_Earth
+          ENDIF
+          !
+       ENDDO
+    ENDDO
+    !
+    ! The number of maximum vegetation map points in the GCM grid is estimated.
+    ! Some lmargin is taken.
+    !
+    IF (is_root_prc) THEN
+       nix=INT(MAXVAL(resolution_g(:,1))/MAXVAL(resol_lu(:,:,1)))+2
+       njx=INT(MAXVAL(resolution_g(:,2))/MAXVAL(resol_lu(:,:,2)))+2
+       nbpmax = nix*njx
+    ENDIF
+    CALL bcast(nbpmax)
+    !
+    callsign = 'Irrigation map'
+    ok_interpol = .FALSE.
+    !
+    WRITE(numout,*) "Projection arrays for ",callsign," : "
+    WRITE(numout,*) "nbpmax = ",nbpmax, nix, njx
+    !
+    ALLOC_ERR=-1
+    ALLOCATE(sub_index(nbpt, nbpmax, 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, nbpmax), 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, lonrel, latrel, mask, callsign, &
+         &                nbpmax, sub_index, sub_area, ok_interpol)
+    !
+    !
+    WHERE (sub_area < 0) sub_area=zero
+    !  
+    !
+    DO ib=1,nbpt
+                   !
+       area_irrig = 0.0
+       area_flood = 0.0
+       ! 
+       fopt=1
+       !
+       DO WHILE ( sub_area(ib,fopt) > zero ) 
+          !
+          ip = sub_index(ib, fopt, 1)
+          jp = sub_index(ib, fopt, 2)
+          !
+          IF (irrigated_frac(ip,jp) .LT. undef_sechiba-1.) THEN
+             area_irrig = area_irrig + sub_area(ib,fopt)*irrigated_frac(ip,jp)
+          ENDIF
+          !
+          DO itype=1,ntype
+             IF (flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN
+                area_flood(itype) = area_flood(itype) + sub_area(ib,fopt)*flood_fracmax(ip,jp,itype)
+             ENDIF
+          ENDDO
+          !
+          fopt = fopt + 1
+          !
+       ENDDO
+       !
+       ! Put the total 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(iflood)+area_flood(idam)+area_flood(isal), &
+               & 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
+!!$          ! Compute a diagnostic of the map.
+!!$          IF(contfrac(ib).GT.zero) THEN
+!!$             floodmap(ib) = floodplains(ib) / ( resolution(ib,1)*resolution(ib,2)*contfrac(ib) )
+!!$          ELSE
+!!$             floodmap(ib) = 0.0
+!!$          ENDIF
+       ENDIF
+       !
+       IF ( init_swamp ) THEN
+          swamp(ib) = MIN(area_flood(iswamp), resolution(ib,1)*resolution(ib,2)*contfrac(ib))
+          IF ( swamp(ib) < 0 ) THEN
+             WRITE(numout,*) 'We have a problem here : ', swamp(ib) 
+             WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
+             WRITE(numout,*) area_flood
+             STOP
+          ENDIF
+!!$          ! Compute a diagnostic of the map.
+!!$          IF(contfrac(ib).GT.zero) THEN
+!!$             swampmap(ib) = swamp(ib) / ( resolution(ib,1)*resolution(ib,2)*contfrac(ib) )
+!!$          ELSE
+!!$             swampmap(ib) = zero
+!!$          ENDIF
+       ENDIF
+       !
+       !
+    ENDDO
+    !
+    !
+    
+    IF ( init_irrig ) WRITE(numout,*) "Diagnostics irrigated :", MINVAL(irrigated), MAXVAL(irrigated)
+    IF ( init_flood ) WRITE(numout,*) "Diagnostics floodplains :", MINVAL(floodplains), MAXVAL(floodplains)
+    IF ( init_swamp ) WRITE(numout,*) "Diagnostics swamp :", MINVAL(swamp), MAXVAL(swamp)
+!
+! No compensation is done for overlapping floodplains, swamp and irrig. At least overlapping will not
+! happen between floodplains and swamp alone
+!    IF ( init_irrig .AND. init_flood ) THEN
+!       DO ib = 1, nbpt
+!          surp = (floodplains(ib)+swamp(ib)+irrigated(ib)) / (resolution(ib,1)*resolution(ib,2)*contfrac(ib))
+!          IF ( surp .GT. un ) THEN
+!             floodplains(ib) = floodplains(ib) / surp
+!             swamp(ib) = swamp(ib) / surp
+!             irrigated(ib) = irrigated(ib) / surp
+!          ENDIF
+!       ENDDO
+!    ENDIF
+    !
+    DEALLOCATE (sub_area)
+    DEALLOCATE (sub_index)
+    !
+    DEALLOCATE (mask)
+    DEALLOCATE (resol_lu)
+    !
+    DEALLOCATE (lonrel)
+    DEALLOCATE (latrel)
+    !
+  END SUBROUTINE routing_irrigmap
+  !
+!! ================================================================================================================================
+!! SUBROUTINE 	: routing_waterbal
+!!
+!> BRIEF         This subroutine checks the water balance in the routing module.
+!!
+!! DESCRIPTION (definitions, functional, design, flags) : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE routing_waterbal(nbpt, firstcall, floodout, runoff, drainage, returnflow, &
+               & reinfiltration, irrigation, riverflow, coastalflow)
+    !
+    IMPLICIT NONE
+    !
+!! INPUT VARIABLES
+    INTEGER(i_std), INTENT(in) :: nbpt                 !! Domain size  (unitless)
+    LOGICAL, INTENT(in)        :: firstcall            !! Controls behaviour (true/false)
+    REAL(r_std), INTENT(in)    :: floodout(nbpt)       !! Grid-point flow out of floodplains (kg/m^2/dt)
+    REAL(r_std), INTENT(in)    :: runoff(nbpt)         !! Grid-point runoff (kg/m^2/dt)
+    REAL(r_std), INTENT(in)    :: drainage(nbpt)       !! Grid-point drainage (kg/m^2/dt)
+    REAL(r_std), INTENT(in)    :: returnflow(nbpt)     !! The water flow from lakes and swamps which returns to the grid box.
+                                                       !! This water will go back into the hydrol or hydrolc module to allow re-evaporation (kg/m^2/dt)
+    REAL(r_std), INTENT(in)    :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
+    REAL(r_std), INTENT(in)    :: irrigation(nbpt)     !! Irrigation flux. This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt)
+    REAL(r_std), INTENT(in)    :: riverflow(nbpt)      !! Outflow of the major rivers. The flux will be located on the continental grid but this should be a coastal point (kg/dt)
+    REAL(r_std), INTENT(in)    :: coastalflow(nbpt)    !! Outflow on coastal points by small basins. This is the water which flows in a disperse way into the ocean (kg/dt)
+    !
+    ! We sum-up all the water we have in the warious reservoirs
+    !
+    REAL(r_std), SAVE          :: totw_flood           !! Sum of all the water amount in the floodplains reservoirs (kg)
+!$OMP THREADPRIVATE(totw_flood)
+    REAL(r_std), SAVE          :: totw_stream          !! Sum of all the water amount in the stream reservoirs (kg)
+!$OMP THREADPRIVATE(totw_stream)
+    REAL(r_std), SAVE          :: totw_fast            !! Sum of all the water amount in the fast reservoirs (kg)
+!$OMP THREADPRIVATE(totw_fast)
+    REAL(r_std), SAVE          :: totw_slow            !! Sum of all the water amount in the slow reservoirs (kg)
+!$OMP THREADPRIVATE(totw_slow)
+    REAL(r_std), SAVE          :: totw_lake            !! Sum of all the water amount in the lake reservoirs (kg)
+!$OMP THREADPRIVATE(totw_lake)
+    REAL(r_std), SAVE          :: totw_pond            !! Sum of all the water amount in the pond reservoirs (kg)
+!$OMP THREADPRIVATE(totw_pond)
+    REAL(r_std), SAVE          :: totw_in              !! Sum of the water flow in to the routing scheme
+!$OMP THREADPRIVATE(totw_in)
+    REAL(r_std), SAVE          :: totw_out             !! Sum of the water flow out to the routing scheme
+!$OMP THREADPRIVATE(totw_out)
+    REAL(r_std), SAVE          :: totw_return          !! 
+!$OMP THREADPRIVATE(totw_return)
+    REAL(r_std), SAVE          :: totw_irrig           !! 
+!$OMP THREADPRIVATE(totw_irrig)
+    REAL(r_std), SAVE          :: totw_river           !! 
+!$OMP THREADPRIVATE(totw_river)
+    REAL(r_std), SAVE          :: totw_coastal         !! 
+!$OMP THREADPRIVATE(totw_coastal)
+    REAL(r_std)                :: totarea              !! Total area of basin (m^2)
+    REAL(r_std)                :: area                 !! Total area of routing (m^2)
+    INTEGER(i_std)             :: ig                   !! 
+    !
+    ! Just to make sure we do not get too large numbers !
+    !
+!! PARAMETERS
+    REAL(r_std), PARAMETER     :: scaling = 1.0E+6     !!
+    REAL(r_std), PARAMETER     :: allowed_err = 50.    !!
+
+!_ ================================================================================================================================
+    !
+    IF ( firstcall ) THEN
+       !
+       totw_flood = zero
+       totw_stream = zero
+       totw_fast = zero
+       totw_slow = zero
+       totw_lake = zero
+       totw_pond = zero 
+       totw_in = zero
+       !
+       DO ig=1,nbpt
+          !
+          totarea = SUM(routing_area(ig,:))
+          !
+          totw_flood = totw_flood + SUM(flood_reservoir(ig,:)/scaling)
+          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_pond = totw_pond + pond_reservoir(ig)/scaling
+          !
+          totw_in = totw_in + (runoff(ig)*totarea + drainage(ig)*totarea - floodout(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_flood = totw_flood - SUM(flood_reservoir(ig,:)/scaling)
+          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_pond = totw_pond - pond_reservoir(ig)/scaling
+          !
+          totw_return = totw_return + (reinfiltration(ig)+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_flood + totw_stream + totw_fast + totw_slow + totw_lake + totw_pond) - &
+            & (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 : flood stream fast ', totw_flood, totw_stream, totw_fast
+          WRITE(numout,*) '--Water-- change : slow, lake ', totw_slow, totw_lake
+          WRITE(numout,*) '--Water>>> change in the routing res. : ', totw_flood + 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_flood + totw_stream + totw_fast + totw_slow + totw_lake) - (totw_out - totw_in))/area
+
+          ! Stop the model
+          CALL ipslerr_p(3, 'routing_waterbal', 'Water is not conserved in routing.','','')
+       ENDIF
+       !
+    ENDIF
+    !
+  END SUBROUTINE routing_waterbal
+  !
+  !
+END MODULE routing
Index: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/sechiba.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/sechiba.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/sechiba.f90	(revision 7236)
@@ -0,0 +1,3681 @@
+!  ==============================================================================================================================\n
+!  MODULE 	: sechiba
+! 
+!  CONTACT     : orchidee-help _at_ ipsl.jussieu.fr
+!
+!  LICENCE      : IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        Structures the calculation of atmospheric and hydrological 
+!! variables by calling diffuco_main, enerbil_main, hydrolc_main (or hydrol_main),
+!! enerbil_fusion, condveg_main and thermosoil_main. Note that sechiba_main
+!! calls slowproc_main and thus indirectly calculates the biogeochemical
+!! processes as well.
+!!
+!!\n DESCRIPTION  : :: shumdiag, :: litterhumdiag and :: stempdiag are not 
+!! saved in the restart file because at the first time step because they 
+!! are recalculated. However, they must be saved as they are in slowproc 
+!! which is called before the modules which calculate them.
+!! 
+!! RECENT CHANGE(S): None 
+!! 
+!! REFERENCE(S) : None
+!!   
+!! SVN     :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_sechiba/sechiba.f90 $ 
+!! $Date: 2015-02-22 16:18:16 +0100 (Sun, 22 Feb 2015) $
+!! $Revision: 2555 $
+!! \n
+!_ ================================================================================================================================
+  
+MODULE sechiba
+ 
+  USE ioipsl
+  USE xios_orchidee
+  
+  ! modules used :
+  USE constantes
+  USE constantes_soil
+  USE pft_parameters
+  USE structures
+  USE diffuco
+  USE condveg
+  USE enerbil
+  USE hydrol     
+  USE hydrolc
+  USE sechiba_hydrol_arch
+  USE thermosoil
+  USE sechiba_io
+  USE slowproc
+  USE routing
+  USE ioipsl_para
+  USE stomate_laieff
+!+++ TEMP ++++
+  USE function_library
+!+++++++
+
+
+  IMPLICIT NONE
+
+  ! Private and public routines
+
+  PRIVATE
+  PUBLIC sechiba_main,sechiba_clear
+
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexveg       !! indexing array for the 3D fields of vegetation
+!$OMP THREADPRIVATE(indexveg)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexlai       !! indexing array for the 3D fields of vegetation
+!$OMP THREADPRIVATE(indexlai)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexnobio     !! indexing array for the 3D fields of other surfaces (ice,
+                                                                     !! lakes, ...)
+!$OMP THREADPRIVATE(indexnobio)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexsoil      !! indexing array for the 3D fields of soil types
+!$OMP THREADPRIVATE(indexsoil)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexgrnd      !! indexing array for the 3D ground heat profiles
+!$OMP THREADPRIVATE(indexgrnd)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexlayer     !! indexing array for the 3D fields of soil layers 
+!$OMP THREADPRIVATE(indexlayer)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexalb       !! indexing array for the 2 fields of albedo
+!$OMP THREADPRIVATE(indexalb)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexcan       !! indexing array for the level fields of the canopy
+!$OMP THREADPRIVATE(indexcan)
+
+INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexnbdl      !! indexing array for the 3D fields of diagnostic soil layers (kjpindex     *nbdl)
+ !$OMP THREADPRIVATE(indexnbdl)
+
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: veget          !! Fraction of vegetation type (unitless, 0-1)       
+!$OMP THREADPRIVATE(veget)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: veget_max      !! Max. fraction of vegetation type (LAI -> infty, unitless)
+!$OMP THREADPRIVATE(veget_max)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: height         !! Vegetation Height (m)
+!$OMP THREADPRIVATE(height)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: totfrac_nobio  !! Total fraction of continental ice+lakes+cities+...
+                                                                     !! (unitless, 0-1)
+!$OMP THREADPRIVATE(totfrac_nobio)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: floodout       !! Flow out of floodplains from hydrol
+!$OMP THREADPRIVATE(floodout)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: runoff         !! Surface runoff calculated by hydrol or hydrolc 
+                                                                     !! @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(runoff)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: drainage       !! Deep drainage calculatedd by hydrol or hydrolc 
+                                                                     !! @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(drainage)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: returnflow     !! Water flow from lakes and swamps which returns to 
+                                                                     !! the grid box @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(returnflow)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: reinfiltration !! Routed water which returns into the soil
+!$OMP THREADPRIVATE(reinfiltration)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: irrigation     !! Irrigation flux taken from the routing reservoirs and 
+                                                                     !! being put into the upper layers of the soil 
+                                                                     !! @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(irrigation)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: emis           !! Surface emissivity (unitless)
+!$OMP THREADPRIVATE(emis)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: z0             !! Surface roughness (m)
+!$OMP THREADPRIVATE(z0)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: z0_veg         !! Surface roughness of vegetated part (m) 
+!$OMP THREADPRIVATE(z0_veg)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: roughheight    !! Effective height for roughness (m)
+!$OMP THREADPRIVATE(roughheight)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: reinf_slope    !! slope coefficient (reinfiltration) 
+!$OMP THREADPRIVATE(reinf_slope)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: shumdiag       !! Mean relative soil moisture in the different levels used 
+                                                                     !! by thermosoil.f90 (unitless, 0-1)
+!$OMP THREADPRIVATE(shumdiag)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: k_litt         !! litter cond.
+
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: shumdiag_perma !!Saturation degree of the soil 
+!$OMP THREADPRIVATE(shumdiag_perma)
+
+
+!$OMP THREADPRIVATE(k_litt)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: litterhumdiag  !! Litter dryness factor (unitless, 0-1)
+!$OMP THREADPRIVATE(litterhumdiag)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: stempdiag      !! Temperature which controls canopy evolution (K)
+!$OMP THREADPRIVATE(stempdiag)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: qsintveg       !! Water on vegetation due to interception 
+                                                                     !! @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(qsintveg)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: vbeta2         !! Interception resistance (unitless,0-1)
+!$OMP THREADPRIVATE(vbeta2)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: vbeta3         !! Vegetation resistance (unitless,0-1)
+!$OMP THREADPRIVATE(vbeta3)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: vbeta3pot      !! Potential vegetation resistance
+!$OMP THREADPRIVATE(vbeta3pot)
+ ! REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: vbetaco2       !! STOMATE:Vegetation resistance to CO2 (unitless,0-1)
+!!$OMP THREADPRIVATE(vbetaco2)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: gsmean         !! Mean stomatal conductance for CO2 (umol m-2 s-1)
+!$OMP THREADPRIVATE(gsmean)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: cimean         !! STOMATE: mean intercellular CO2 concentration (ppm)
+!$OMP THREADPRIVATE(cimean)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: vevapwet       !! Interception loss over each PFT 
+                                                                     !! @tex $(kg m^{-2} days^{-1})$ @endtex
+!$OMP THREADPRIVATE(vevapwet)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: transpir       !! Transpiration @tex $(kg m^{-2} days^{-1})$ @endtex
+!$OMP THREADPRIVATE(transpir)
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: transpir_supply  !! Supply of water for transpiration @tex$$(mm dt^{-1})$ @endtex
+!$OMP THREADPRIVATE(transpir_supply)
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: vir_transpir_supply !! Supply of water for transpiration @tex$$(mm dt^{-1})$ @endtex
+!$OMP THREADPRIVATE(transpir_supply)
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: stressed      !! Adjusted ecosystem functioning. Takes the unit of the variable
+                                                                     !! used as a proxy for waterstress
+!$OMP THREADPRIVATE(stressed)
+
+! tzjwb
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: mc_layh        !!Volumetric soil moisture for each layer in hydrol(liquid + ice) (m3/m3)
+!$OMP THREADPRIVATE(mc_layh)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: mcl_layh       !!Volumetric soil moisture for each layer in hydrol(liquid) (m3/m3)
+!$OMP THREADPRIVATE(mcl_layh)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: tmc_layh       !! Total soil moisture content for each layer in hydrol(liquid + ice) (mm)
+!$OMP THREADPRIVATE(tmc_layh)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)  :: cgrnd_snow   !! Integration coefficient for snow numerical scheme
+!$OMP THREADPRIVATE(cgrnd_snow)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)  :: dgrnd_snow   !! Integration coefficient for snow numerical scheme
+!$OMP THREADPRIVATE(dgrnd_snow)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)    :: lambda_snow  !! Coefficientof the linear extrapolation of surface temperature 
+                                                                  !! from the
+                                                                  !first and
+                                                                  !second snow
+                                                                  !layers
+!$OMP THREADPRIVATE(lambda_snow)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)    :: gtemp        !! soil surface temperature
+!$OMP THREADPRIVATE(gtemp)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: pgflux       !! net energy into snow pack
+!$OMP THREADPRIVATE(pgflux)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)    :: temp_sol_add !! Additional energy to melt snow for snow ablation case (K)
+!$OMP THREADPRIVATE(temp_sol_add)
+
+
+!! ------------------------------------------------- tzjh 
+
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: vl  !! tzjh test
+!$OMP THREADPRIVATE(vl)
+
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: vx  !! tzjh test
+!$OMP THREADPRIVATE(vx)
+
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: vr  !! tzjh test
+!$OMP THREADPRIVATE(vr)
+
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: psi_leaf  !! tzjh test
+!$OMP THREADPRIVATE(psi_leaf)
+
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: psi_stem  !! tzjh test
+!$OMP THREADPRIVATE(psi_stem)
+
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: psi_root  !! tzjh test
+!$OMP THREADPRIVATE(psi_root)
+   ! added by Yitong Yao 06 Jan 2020 10:15
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: stem_plc  !! tzjh test
+   ! added by Yitong Yao 06 Jan 2020 10:!5
+!! ------------------------------------------------- tzjh 
+   ! added by yitong yao 13 Jan 2020 18:17
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)     :: transpir_tot
+   ! added by yitong yao 13 Jan 2020 18:18 above lines
+   
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:)    :: gsh 
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:)    :: tzj_supply
+  
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)     :: VPD_tzj
+  
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: unstressed    !! Initial ecosystem functioning after the first calculation and 
+                                                                     !! before any recalculations. Takes the unit of the variable used
+                                                                     !! as a proxy for unstressed.
+!$OMP THREADPRIVATE(unstressed)
+!!$   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: vir_transpir_mod !! potential transpiration (transpot) divided by veget_max
+!!$!$OMP THREADPRIVATE(vir_transpir_mod)
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: transpot      !! Potential transpiration (needed for irrigation)
+!$OMP THREADPRIVATE(transpot)
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: qsintmax      !! Maximum amount of water in the canopy interception 
+                                                                     !! reservoir @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(qsintmax)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: rveget         !! Surface resistance for the vegetation 
+                                                                     !! @tex $(s m^{-1})$ @endtex
+!$OMP THREADPRIVATE(rveget)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: rstruct        !! Vegetation structural resistance
+!$OMP THREADPRIVATE(rstruct)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: warnings     !! Holds a count of how many warnings we run into
+                                                                     !! of different types.  It will get reset at the
+                                                                     !! end of each period since we don't wish to restart it.
+                                                                     !! Purely a technical diagnostic variable.
+!$OMP THREADPRIVATE(warnings)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: snow_nobio     !! Snow mass of non-vegetative surfaces 
+                                                                     !! @tex $(kg m^{-2})$ @endtex
+!$OMP THREADPRIVATE(snow_nobio)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: snow_nobio_age !! Snow age on non-vegetative surfaces (days)
+!$OMP THREADPRIVATE(snow_nobio_age)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: frac_nobio     !! Fraction of non-vegetative surfaces (continental ice, 
+                                                                     !! lakes, ...) (unitless, 0-1)
+!$OMP THREADPRIVATE(frac_nobio)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: albedo         !! Surface albedo for visible and near-infrared 
+                                                                     !! (unitless, 0-1)
+!$OMP THREADPRIVATE(albedo)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:) &
+                                                   :: albedo_pft     !! Albedo (two stream radiation transfer model)
+                                                                     !! for visible and near-infrared range 
+                                                                     !! for each PFT (unitless)
+!$OMP THREADPRIVATE(albedo_pft)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:):: assim_param    !! min+max+opt temps, vcmax, vjmax for photosynthesis
+!$OMP THREADPRIVATE(assim_param)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: lai            !! Surface foliaire
+!$OMP THREADPRIVATE(lai)
+  TYPE(laieff_type), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: laieff_fit   !! The parameters for fitting the effective
+                                                                     !! LAI function
+!$OMP THREADPRIVATE(laieff_fit)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: gpp            !! STOMATE: GPP. gC/m**2 of total area
+!$OMP THREADPRIVATE(gpp)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)     :: temp_growth    !! Growth temperature (Â°C) - Is equal to t2m_month
+!$OMP THREADPRIVATE(temp_growth)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: humrel         !! Relative humidity
+!$OMP THREADPRIVATE(humrel)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: vegstress      !! Vegetation moisture stress (only for vegetation growth)
+!$OMP THREADPRIVATE(vegstress)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:):: frac_age       !! Age efficacity from STOMATE for isoprene 
+!$OMP THREADPRIVATE(frac_age)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: soiltile       !! Fraction of each soil tile (0-1, unitless)
+!$OMP THREADPRIVATE(soiltile)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: njsc           !! Index of the dominant soil textural class in the grid cell (1-nscm, unitless)
+!$OMP THREADPRIVATE(njsc)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: vbeta1         !! Snow resistance 
+!$OMP THREADPRIVATE(vbeta1)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: vbeta4         !! Bare soil resistance
+!$OMP THREADPRIVATE(vbeta4)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: vbeta5         !! Floodplains resistance
+!$OMP THREADPRIVATE(vbeta5)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: soilcap        !!
+!$OMP THREADPRIVATE(soilcap)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: soilflx        !!
+!$OMP THREADPRIVATE(soilflx)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: temp_sol       !! Soil temperature
+!$OMP THREADPRIVATE(temp_sol)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: qsurf          !! near soil air moisture
+!$OMP THREADPRIVATE(qsurf)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: flood_res      !! flood reservoir estimate
+!$OMP THREADPRIVATE(flood_res)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: flood_frac     !! flooded fraction
+!$OMP THREADPRIVATE(flood_frac)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: snow           !! Snow mass [Kg/m^2]
+!$OMP THREADPRIVATE(snow)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: snow_age       !! Snow age
+!$OMP THREADPRIVATE(snow_age)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: drysoil_frac   !! Fraction of visibly (albedo) Dry soil (Between 0 and 1)
+!$OMP THREADPRIVATE(drysoil_frac)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: rsol           !! resistance to bare soil evaporation
+!$OMP THREADPRIVATE(rsol)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: evap_bare_lim  !! Bare soil stress
+!$OMP THREADPRIVATE(evap_bare_lim)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) ::swc            !! Soil water content (a copy of mc) m3 m-3
+!$OMP THREADPRIVATE(swc)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) ::ksave            !! Soil conductivity (copy of k mm/d)
+!$OMP THREADPRIVATE(ksave)
+
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) ::veg_soiltext  !! Percentage of each veg. type on each soil type
+!$OMP THREADPRIVATE(veg_soiltext)                                      !! of each grid point (copy of corr_veg_soil)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: co2_flux       !! CO2 flux (gC/m**2 of average ground/s)
+!$OMP THREADPRIVATE(co2_flux)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: evapot         !! Soil Potential Evaporation
+!$OMP THREADPRIVATE(evapot)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: evapot_corr    !! Soil Potential Evaporation Correction (Milly 1992)
+!$OMP THREADPRIVATE(evapot_corr)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: vevapflo       !! Floodplains evaporation
+!$OMP THREADPRIVATE(vevapflo)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: vevapsno       !! Snow evaporation
+!$OMP THREADPRIVATE(vevapsno)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: vevapnu        !! Bare soil evaporation
+!$OMP THREADPRIVATE(vevapnu)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: t2mdiag        !! 2 meter temperature
+!$OMP THREADPRIVATE(t2mdiag)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: tot_melt       !! Total melt
+!$OMP THREADPRIVATE(tot_melt)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: vbeta          !! Resistance coefficient
+!$OMP THREADPRIVATE(vbeta)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: valpha         !! Resistance coefficient
+!$OMP THREADPRIVATE(valpha)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: fusion         !!
+!$OMP THREADPRIVATE(fusion)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: rau            !! Density
+!$OMP THREADPRIVATE(rau)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: deadleaf_cover !! Fraction of soil covered by dead leaves
+!$OMP THREADPRIVATE(deadleaf_cover)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: ptnlev1        !! 1st level Different levels soil temperature
+!$OMP THREADPRIVATE(ptnlev1)
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: lai_split        !! TEMPORARY
+!$OMP THREADPRIVATE(lai_split)
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: Isotrop_Abs_Tot_p  !! Absorbed radiation per level for photosynthesis
+!$OMP THREADPRIVATE(Isotrop_Abs_Tot_p)
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: Isotrop_Tran_Tot_p  !! Transmitted radiation per level for photosynthesis
+!$OMP THREADPRIVATE(Isotrop_Tran_Tot_p)
+
+
+
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)      :: flux_h_grid 
+!$OMP THREADPRIVATE(flux_h_grid)
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)      :: flux_le_grid
+!$OMP THREADPRIVATE(flux_le_grid)
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)      :: t_a_next_grid
+!$OMP THREADPRIVATE(t_a_next_grid)
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)      :: q_a_next_grid 
+!$OMP THREADPRIVATE(q_a_next_grid)
+
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)      :: temp_atmos_pres_grid       ! atmospheric temperature down the column (K) PRESENT STEP
+!$OMP THREADPRIVATE(temp_atmos_pres_grid)
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)      :: q_atmos_pres_grid          ! atmospheric specific humididy down the column (kg/kg) PRESENT STEP
+!$OMP THREADPRIVATE(q_atmos_pres_grid)
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)      :: temp_leaf_pres_grid        ! leaf temperature down the column (K) PRESENT STEP
+!$OMP THREADPRIVATE(temp_leaf_pres_grid)
+
+
+
+
+
+ ! these following two quantities are never calculated explicitly, they always have values passed from
+ ! stomate...they need to be saved, though, since stomate is only called once a day
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) :: circ_class_biomass !! Stem diameter 
+                                                                             !! @tex $(m)$ @endtex
+!$OMP THREADPRIVATE(circ_class_biomass)
+
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:)           :: circ_class_n       !! Number of trees within each circumference
+!$OMP THREADPRIVATE(circ_class_n)
+
+
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: biomass                !! PFT total biomass 
+!$OMP THREADPRIVATE(biomass)                                                  !! @tex $(gC m^{-2})$ @endtex
+
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ind                    !! Number of individuals at the stand level
+!$OMP THREADPRIVATE(ind)                                                      !! @tex $(m^{-2})$ @endtex
+
+!$OMP THREADPRIVATE(circ_class_n)
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: lai_per_level !! The LAI per vertical level
+                                                                  !! @tex $(m^2 / m^2)$ @endtex
+!$OMP THREADPRIVATE(lai_per_level)
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)   :: frac_snow_veg !! The fraction of vegetation covered
+                                                                  !! by snow.
+                                                                  !! @tex $-$ @endtex
+!$OMP THREADPRIVATE(frac_snow_veg)
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)   :: frac_snow_nobio !! The fraction of non-bio land covered
+                                                                  !! by snow.
+                                                                  !! @tex $-$ @endtex
+!$OMP THREADPRIVATE(frac_snow_nobio)
+REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)     :: frac_snow_pix !! The fraction of the whole pixel covered
+                                                                  !! by snow.  This is computed from the above
+                                                                  !! two.
+                                                                  !! @tex $-$ @endtex
+!$OMP THREADPRIVATE(frac_snow_pix)
+  LOGICAL, SAVE                                    :: l_first_sechiba = .TRUE. !! Flag controlling the intialisation (true/false)
+
+!$OMP THREADPRIVATE(l_first_sechiba)
+  LOGICAL, SAVE                                    :: river_routing            !! Flag that decides if we route surface runoff 
+                                                                               !! and deep drainage to the ocean through the 
+                                                                               !! rivers
+!$OMP THREADPRIVATE(river_routing)
+  LOGICAL, SAVE                                    :: hydrol_cwrr              !! Flag that decides if we use the 11-layer 
+                                                                               !! hydrology module. If not, Choisnel module is 
+                                                                               !! taken.
+!$OMP THREADPRIVATE(hydrol_cwrr)
+  LOGICAL, SAVE                                    :: myfalse=.FALSE.          !! Local flag (true/false)
+!$OMP THREADPRIVATE(myfalse)
+  LOGICAL, SAVE                                    :: mytrue=.TRUE.            !! Local flag (true/false)
+!$OMP THREADPRIVATE(mytrue)
+
+
+  LOGICAL, SAVE                                    :: james_netcdf_flag = .TRUE.      !! Flag that controls the activation of alternate enerbil scheme (true/false)
+!$OMP THREADPRIVATE(james_netcdf_flag)
+  INTEGER, SAVE                                    :: james_count = 0          !! count how many times to run jdriver
+!$OMP THREADPRIVATE(james_count)
+  LOGICAL, SAVE                                    :: hydrol_flag = .TRUE.    !! Flag that recalculates the energy budget for the new supply term (true/false)    
+!$OMP THREADPRIVATE(hydrol_flag)
+  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: sum_veget_diff          !! The is the difference between the total
+                                                                              !! vegetation fraction in the new and old
+                                                                              !! land cover maps.  Useful for land cover
+                                                                              !! changes. [-]
+!$OMP THREADPRIVATE(sum_veget_diff)
+
+
+CONTAINS
+
+!! ==============================================================================================================================\n
+!! SUBROUTINE 	: sechiba_main
+!!
+!>\BRIEF        Main routine for the sechiba module performing three functions:
+!! variable initialization (during the first call only), calculating temporal
+!! evolution of all variables (every call including the first call) and preparation
+!! of output and restart files (during the last call only)
+!!
+!!\n DESCRIPTION : Main routine for the sechiba module. This module is called 
+!! two times:
+!! - a first time to set initial values
+!! - a second time to compute the entire algorithm.\n 
+!! Every time the module is called, three major if/then loops are checked:
+!! - initialization (first call only),
+!! - time step evolution of all variables (every call including the first),
+!! - preparation of output and storage for the restart arrays (last call only).\n
+!! One time step evolution consists of:
+!! - call sechiba_var_init to do some initialization,
+!! - call slowproc_main to do some daily initialization,
+!! - call diffuco_main for diffusion coefficient calculation,
+!! - call enerbil_main for energy budget calculation,
+!! - call hydrolc_main (or hydrol_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 previous to new fields.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): Hydrological variables (:: coastalflow and :: riverflow),
+!! components of the energy budget (:: tsol_rad, :: vevapp, :: fluxsens, 
+!! :: temp_sol_new and :: fluxlat), surface characteristics (:: z0_out, :: emis_out, 
+!! :: tq_cdrag and :: albedo_out) and land use related CO2 fluxes (:: netco2flux and 
+!! :: fco2_lu)            
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART    : 
+!! \latexonly 
+!! \includegraphics[scale = 0.5]{sechibamainflow.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE sechiba_main (kjit, kjpij, kjpindex, index, dtradia, date0, &
+       & ldrestart_read, ldrestart_write, control_in, &
+       & lalo, contfrac, neighbours, resolution,&
+       ! First level conditions
+       & 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, sinang, pb, &
+       ! Output : Fluxes
+       & vevapp, fluxsens, fluxlat, coastalflow, riverflow, netco2flux, fco2_lu, &
+       ! 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)
+
+!! 0.1 Input variables
+    
+    INTEGER(i_std), INTENT(in)                               :: kjit              !! Time step number (unitless)
+    INTEGER(i_std), INTENT(in)                               :: kjpij             !! Total size of the un-compressed grid 
+                                                                                  !! (unitless)
+    INTEGER(i_std), INTENT(in)                               :: kjpindex          !! Domain size - terrestrial pixels only 
+                                                                                  !! (unitless)
+    INTEGER(i_std),INTENT (in)                               :: rest_id           !! _Restart_ file identifier (unitless)
+    INTEGER(i_std),INTENT (in)                               :: hist_id           !! _History_ file identifier (unitless)
+    INTEGER(i_std),INTENT (in)                               :: hist2_id          !! _History_ file 2 identifier (unitless)
+    INTEGER(i_std),INTENT (in)                               :: rest_id_stom      !! STOMATE's _Restart_ file identifier 
+                                                                                  !! (unitless)
+    INTEGER(i_std),INTENT (in)                               :: hist_id_stom      !! STOMATE's _History_ file identifier 
+                                                                                  !! (unitless)
+    INTEGER(i_std),INTENT(in)                                :: hist_id_stom_IPCC !! STOMATE's IPCC _history_ file file 
+                                                                                  !! identifier (unitless)
+    REAL(r_std), INTENT (in)                                 :: dtradia           !! Time step (s)
+    REAL(r_std), INTENT (in)                                 :: date0             !! Initial date (??unit??)
+    LOGICAL, INTENT(in)                                      :: ldrestart_read    !! Logical for _restart_ file to read 
+                                                                                  !! (true/false)
+    LOGICAL, INTENT(in)                                      :: ldrestart_write   !! Logical for _restart_ file to write 
+                                                                                  !! (true/false)
+    TYPE(control_type), INTENT(in)                           :: control_in        !! Flags that (de)activate parts of the model
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (in)          :: lalo              !! Geographic coordinates (latitude,longitude)
+                                                                                  !! for grid cells (degrees)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: contfrac          !! Fraction of continent in the grid 
+                                                                                  !! (unitless, 0-1)
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)         :: index             !! Indices of the pixels on the map. 
+                                                                                  !! Sechiba uses a reduced grid excluding oceans
+                                                                                  !! ::index contains the indices of the 
+                                                                                  !! terrestrial pixels only! (unitless)
+    INTEGER(i_std), DIMENSION (kjpindex,8), INTENT(in)       :: neighbours        !! Neighboring grid points if land!(unitless)
+    REAL(r_std), DIMENSION (kjpindex,2), INTENT(in)          :: resolution        !! Size in x and y of the grid (m)
+    
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u                 !! Lowest level wind speed in direction u 
+                                                                                  !! @tex $(m.s^{-1})$ @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: v                 !! Lowest level wind speed in direction v 
+                                                                                  !! @tex $(m.s^{-1})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: zlev              !! Height of first layer (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qair              !! Lowest level specific humidity 
+                                                                                  !! @tex $(kg kg^{-1})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q2m               !! 2m specific humidity 
+                                                                                  !! @tex $(kg kg^{-1})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: t2m               !! 2m air temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: precip_rain       !! Rain precipitation 
+                                                                                  !! @tex $(kg m^{-2})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: precip_snow       !! Snow precipitation 
+                                                                                  !! @tex $(kg m^{-2})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: lwdown            !! Down-welling long-wave flux 
+                                                                                  !! @tex $(W m^{-2})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: sinang            !! Sine of the solar angle (unitless)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: swnet             !! Net surface short-wave flux 
+                                                                                  !! @tex $(W m^{-2})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: swdown            !! Down-welling surface short-wave flux 
+                                                                                  !! @tex $(W m^{-2})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_air          !! Air temperature (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: epot_air          !! Air potential energy (??J)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: ccanopy           !! CO2 concentration in the canopy (ppm)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: petAcoef          !! Coefficients A for T from the Planetary 
+                                                                                  !! Boundary Layer
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: peqAcoef          !! Coefficients A for q from the Planetary 
+                                                                                  !! Boundary Layer
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: petBcoef          !! Coefficients B for T from the Planetary 
+                                                                                  !! Boundary Layer
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: peqBcoef          !! Coefficients B for q from the Planetary 
+                                                                                  !! Boundary Layer
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: pb                !! Lowest level pressure (hPa)
+    
+    REAL(r_std),DIMENSION (kjpindex)                         :: beta_diffuco
+
+
+!! 0.2 Output variables
+    REAL(r_std), DIMENSION(kjpindex,nvm,ncirc)               :: dia               !! Variable to temporarily store stand structure
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: coastalflow       !! Outflow on coastal points by small basins.
+                                                                                  !! This is the water which flows in a disperse 
+                                                                                  !! way into the ocean
+                                                                                  !! @tex $(kg dt_routing^{-1})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: riverflow         !! Outflow of the major rivers.
+                                                                                  !! The flux will be located on the continental 
+                                                                                  !! grid but this should be a coastal point  
+                                                                                  !! @tex $(kg dt_routing^{-1})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: tsol_rad          !! Radiative surface temperature 
+                                                                                  !! @tex $(W m^{-2})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: vevapp            !! Total of evaporation 
+                                                                                  !! @tex $(kg m^{-2} days^{-1})$ @endtex
+    
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: qsurf_out         !! Surface specific humidity 
+                                                                                  !! @tex $(kg kg^{-1})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: z0_out            !! Surface roughness (output diagnostic, m)
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (out)         :: albedo_out        !! VIS and NIR albedo (output diagnostic, 
+                                                                                  !! unitless)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fluxsens          !! Sensible heat flux 
+                                                                                  !! @tex $(W m^{-2})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fluxlat           !! Latent heat flux 
+                                                                                  !! @tex $(W m^{-2})$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: emis_out          !! Emissivity (unitless)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: netco2flux        !! Sum CO2 flux over PFTs 
+                                                                                  !! ??(gC m^{-2} s^{-1})??
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fco2_lu           !! Land Cover Change CO2 flux 
+    
+    REAL(r_std),DIMENSION (kjpindex)                         :: netrad_out        !! Net radiation flux add by YC 20140313
+    REAL(r_std),DIMENSION (kjpindex)                         :: soilflx_out       !! Soil heat flux add by YC 20140313
+    
+    LOGICAL, DIMENSION (kjpindex)                            :: hydrol_flag2      !! flag that 'trips' the alternative energy budget for each grid square
+    LOGICAL, DIMENSION (kjpindex, nvm)                       :: hydrol_flag3      !! flag that 'trips' the alternative energy budget for each grid square
+
+!! 0.3 Modified
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: tq_cdrag          !! Surface drag coefficient 
+                                                                                  !! @tex $(m.s^{-1})$ @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: temp_sol_new      !! New ground temperature (K)
+
+!! 0.4 local variables
+    REAL(r_std), DIMENSION (kjpindex,nvm,nlai)               :: leaf_ci    !! intercellular CO2 concentration (ppm)
+
+    INTEGER(i_std)                                           :: ji, jv, icir,ilevel      !! Index (unitless)
+
+    REAL(r_std), ALLOCATABLE, DIMENSION (:)                  :: runoff1           !! ??Temporary surface runoff calculated by 
+                                                                                  !! hydrol @tex $(kg m^{-2})$ @endtex
+    REAL(r_std), ALLOCATABLE, DIMENSION (:)                  :: drainage1         !! ??Temporary deep drainage calculatedd by 
+                                                                                  !! hydrol @tex $(kg m^{-2})$ @endtex
+    REAL(r_std), ALLOCATABLE, DIMENSION (:)                  :: soilcap1          !! ??Temporary soil heat capacity 
+                                                                                  !! @tex $(J K^{-1})$ @endtex
+    REAL(r_std), ALLOCATABLE, DIMENSION (:)                  :: soilflx1          !! ??Temporary soil heat flux 
+                                                                                  !! @tex $(W m^{-2})$ @endtex
+    REAL(r_std), ALLOCATABLE, DIMENSION (:,:)                :: shumdiag1         !! ??Temporary relative soil moisture 
+                                                                                  !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(kjpindex)                         :: histvar           !! Computations for history files (unitless)
+    CHARACTER(LEN=80)                                        :: var_name          !! To store variables names for I/O (unitless)
+    REAL(r_std), DIMENSION(kjpindex)                         :: sum_treefrac      !! Total fraction occupied by trees (0-1, uniless) 
+    REAL(r_std), DIMENSION(kjpindex)                         :: sum_grassfrac     !! Total fraction occupied by grasses (0-1, unitless)
+    REAL(r_std), DIMENSION(kjpindex)                         :: sum_cropfrac      !! Total fraction occcupied by crops (0-1, unitess)
+!    REAL(r_std), ALLOCATABLE, DIMENSION (:,:,:)             :: swc               !! soil water content m3 m-3 (copy of mc in hydrol_main)
+!    REAL(r_std), DIMENSION (kjpindex,nslm,nstm)             :: swc               !! soil water content m3 m-3 (copy of mc in hydrol_main)
+    INTEGER(i_std), DIMENSION(kjpindex,nvm,nstm)             :: veg_soiltext      !! Percentage of each veg. type on each soil type
+                                                                                  !! of each grid point (copy of corr_veg_soil)
+    LOGICAL                                                  :: hydrol_flag       !! flag that 'trips' the alternative energy budget for each grid square
+
+    REAL(r_std)                                              :: isotrop_angle     
+
+    REAL(r_std),DIMENSION (kjpindex,nvm)                     :: vbeta23          !! Beta for fraction of wetted foliage that will
+                                                                                  !! transpire once intercepted water has evaporated (-)
+   
+
+    REAL(r_std), DIMENSION(ncirc)                       :: diameters_temp
+    INTEGER :: ivm,ipts
+    REAL(r_std), DIMENSION(kjpindex)                    :: laieff_pix                 !! LAIeff at the pixel level for optimization
+    REAL(r_std), DIMENSION(nlevels_tot,kjpindex,nvm)    :: laieff_isotrop             !! Effective LAI
+    REAL(r_std), DIMENSION(kjpindex,nvm)                :: laieff_pft                 !! Effective LAI 
+ 
+
+    ! %%% begin variables for the enerbil and hydrol interface %%%%
+
+    INTEGER                                             :: i, inno
+    INTEGER, SAVE                                       :: james_step_count         !$OMP THREADPRIVATE(james_step_count)
+
+    REAL(r_std)                                         :: flux_ground_h            ! sensible heat flux at surface (W^{m^2})
+    REAL(r_std)                                         :: flux_ground_le           ! latent heat flux at surface (W^{m^2})
+    REAL(r_std)                                         :: temp_surface_next_out    ! check for surface temperature at next timestep (K)
+
+    REAL(r_std), DIMENSION(kjpindex)                    :: vbeta2sum             ! sum of vbeta2 coefficients across all PFTs (-)
+    REAL(r_std), DIMENSION(kjpindex)                    :: vbeta3sum             ! sum of vbete3 coefficients across all PFTs (-)
+
+    REAL(r_std), SAVE                                   :: temp_surf_pres        ! temperature at surface for the present timestep (K)
+!$OMP THREADPRIVATE(temp_surf_pres)
+    REAL(r_std), SAVE                                   :: temp_surf_next        ! temperature at surface for the next timestep (K)
+!$OMP THREADPRIVATE(temp_surf_next)
+
+    REAL(r_std), DIMENSION (kjpindex,nvm,nlevels_tot)       :: gs_distribution
+    REAL(r_std), DIMENSION (kjpindex,nvm,nlevels_tot)       :: gs_diffuco_output
+    REAL(r_std), DIMENSION (kjpindex,nvm,nlevels_tot)       :: gstot_component
+    REAL(r_std), DIMENSION (kjpindex,nvm,nlevels_tot)       :: gstot_frac
+
+
+    ! variables introduced as a consequence of running enerbil twice (if needed, as a result of restriction of transpiration by
+    !    the supply term). If running for the second time, we should start with the same input variables as the first run
+    
+    REAL(r_std), DIMENSION (kjpindex)        :: evapot_save           !! Soil Potential Evaporation (mm day^{-1})
+    REAL(r_std), DIMENSION (kjpindex)        :: evapot_corr_save      !! Soil Potential Evaporation Correction (mm day^{-1})
+    REAL(r_std), DIMENSION (kjpindex)        :: temp_sol_save         !! Soil temperature (K)
+    REAL(r_std), DIMENSION (kjpindex)        :: qsurf_save            !! Surface specific humidity (kg kg^{-1})     
+    REAL(r_std), DIMENSION (kjpindex)        :: fluxsens_save         !! Sensible heat flux (W m^{-2})
+    REAL(r_std), DIMENSION (kjpindex)        :: fluxlat_save          !! Latent heat flux (W m^{-2})
+    REAL(r_std), DIMENSION (kjpindex)        :: tsol_rad_save         !! Tsol_rad (W m^{-2})
+    REAL(r_std), DIMENSION (kjpindex)        :: vevapp_save           !! Total of evaporation (mm day^{-1})
+    REAL(r_std), DIMENSION (kjpindex,nvm)    :: gpp_save              !! Assimilation ((gC m^{-2}), total area)     
+    REAL(r_std), DIMENSION (kjpindex)        :: temp_sol_new_save     !! New soil temperature (K)
+    REAL(r_std), DIMENSION (kjpindex)        :: vbeta2sum_save        !! sum of vbeta2 coefficients across all PFTs (-)
+    REAL(r_std), DIMENSION (kjpindex)        :: vbeta3sum_save        !! sum of vbeta3 coefficients across all PFTs (-)
+    REAL(r_std), DIMENSION (kjpindex,nvm)    :: unstressed            !! Adjusted ecosystem functioning. Takes the unit of the variable
+                                                                      !! used as a proxy for waterstress
+    REAL(r_std), DIMENSION (kjpindex,nvm)    :: stressed              !! Initial ecosystem functioning after the first calculation and 
+                                                                      !! before any recalculations. Takes the unit of the variable used
+                                                                      !! as a proxy for unstressed.
+    REAL(r_std), DIMENSION (kjpindex,nvm)    :: vbeta3_save           !! Beta for Transpiration (unitless)
+    REAL(r_std), DIMENSION (kjpindex,nvm)    :: vbeta3pot_save        !! Beta for Potential Transpiration
+    REAL(r_std), DIMENSION (kjpindex,nvm)    :: rveget_save           !! stomatal resistance of vegetation 
+    REAL(r_std), DIMENSION (kjpindex,nvm)    :: rstruct_save          !! structural resistance @tex ($s m^{-1}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex,nvm)    :: cimean_save           !! mean intercellular CO2 concentration
+    REAL(r_std), DIMENSION (kjpindex,nvm)    :: gsmean_save           !! mean stomatal conductance to CO2 (umol m-2 s-1)
+   ! REAL(r_std), DIMENSION (kjpindex,nvm)   :: gpp_save
+    REAL(r_std), DIMENSION (kjpindex)        :: qsol_sat_new_out      !! New saturated surface air moisture (kg kg^{-1})
+    REAL(r_std),DIMENSION (kjpindex)         :: qair_new
+    REAL(r_std),DIMENSION (kjpindex)         :: delta_temp_save
+    REAL(r_std), DIMENSION (kjpindex,nvm)    :: vbeta3_oldvalue
+    REAL(r_std), DIMENSION (kjpindex)        :: vbeta3_save_test
+    
+    REAL(r_std), DIMENSION (kjpindex,nvm)    :: transpir_init        !! Temperate storage variable for the transpiration before limited by transpiration supply  
+    ! %%% end variables for the enerbil and hydrol interface %%%%
+    CHARACTER(LEN=10)                                      :: part_str 
+    INTEGER(i_std)              :: icirc 
+!_ ================================================================================================================================
+
+    IF (long_print) WRITE(numout,*) ' sechiba kjpindex =',kjpindex
+
+!! 1. Initialize variables on first call!
+
+    IF (l_first_sechiba) THEN
+
+       !+++++++ TEMP +++++++++
+       ! It is good to leave this in here.  It is only written out once,
+       ! it takes almost no time, and it's necessary for identifying a 
+       ! problem pixel.
+       DO ipts=1,kjpindex
+          WRITE(numout,'(A,I6,10F20.10)') 'lalo sechiba: ',ipts,lalo(ipts,1:2)
+       ENDDO
+       !++++++++++++++++
+      
+       james_step_count = 0
+
+       !! 1.1 Initialize most of sechiba's variables
+       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))
+        
+       ! These are data that are passed from stomate to sechiba for
+       ! the effective LAI calculation...however it seems that they
+       ! are not always initialized before the effective lai routine
+       ! in condveg is called
+       circ_class_biomass=val_exp
+       circ_class_n=val_exp
+
+       !! 1.2 Initialize some variables of energy budget from restart file     
+       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_p('UNITS', '-')
+          CALL ioconf_setatt_p('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_p('UNITS', '-')
+          CALL ioconf_setatt_p('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_p('UNITS', '-')
+          CALL ioconf_setatt_p('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 ! ldrestart_read
+
+
+       !! 1.3 Initialize stomate's variables
+       ! This variable needs to be defined before going into slowproc.
+       Isotrop_Tran_Tot_p(:,:,:)=zero
+       CALL slowproc_main (kjit, kjpij, kjpindex, dtradia, date0, &
+           ldrestart_read, ldrestart_write, control_in%ok_co2, control_in%ok_stomate, index, &
+           indexveg, lalo, neighbours, resolution, contfrac, &
+           soiltile, reinf_slope, t2mdiag, t2mdiag, temp_sol, &
+           stempdiag, vegstress, shumdiag, litterhumdiag, precip_rain, &
+           precip_snow, gpp, deadleaf_cover, assim_param, lai, &
+           frac_age, height, veget, frac_nobio, njsc, &
+           veget_max, totfrac_nobio, qsintmax, rest_id, hist_id, &
+           hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC, co2_flux, &
+           fco2_lu, sinang, circ_class_biomass, circ_class_n, &
+           transpir, stressed, unstressed, transpir_supply, &
+           biomass, ind, lai_per_level, laieff_fit,  &
+           vir_transpir_supply, temp_growth, Isotrop_Tran_Tot_p,&
+           sum_veget_diff,stem_plc,psi_stem,psi_leaf, psi_root)
+
+       netco2flux(:) = zero
+
+       !+++CHECK+++
+       ! If co2flux contains soil respiration the loop should include the bare soil
+       ! because after a land cover change PFT1 can contain litter and soil carbon
+       DO jv = 2,nvm
+          netco2flux(:) = netco2flux(:) + co2_flux(:,jv)*veget_max(:,jv)
+       ENDDO
+       !+++++++++++
+      
+      !! 1.4 Initialize diffusion coefficients
+       CALL diffuco_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, indexlai, u, v, &
+            & zlev, z0, roughheight, temp_sol, temp_air, temp_growth, rau, tq_cdrag, qsurf, qair, q2m, t2m, pb ,  &
+            & rsol, evap_bare_lim, evapot, evapot_corr, snow, flood_frac, flood_res, frac_nobio, snow_nobio, totfrac_nobio, &
+            & swnet, swdown, sinang, ccanopy, humrel, vegstress, veget, veget_max, biomass, qsintveg, qsintmax, assim_param, &
+            & vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta3pot, vbeta4, vbeta5, gsmean, rveget, rstruct, cimean, gpp, &
+            & lalo, neighbours, resolution, ptnlev1, precip_rain, frac_age,  &
+            & rest_id, hist_id, hist2_id, vbeta2sum, vbeta3sum, Isotrop_Abs_Tot_p, Isotrop_Tran_Tot_p,&
+            lai_per_level, lai, vbeta23, leaf_ci, gs_distribution, gs_diffuco_output, gstot_component, gstot_frac, warnings)
+
+       !write(numout, *) "YC: Initialize remaining variables of energy budget"
+       !! 1.5 Initialize remaining variables of energy budget
+       !!       First calling "enerbil_main" for initializing variables
+       CALL enerbil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
+            & index, indexveg, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
+            & qair, peqAcoef, peqBcoef, pb, rau, vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta3pot, vbeta4, vbeta5, &
+            & emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
+!!$            & cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
+            & vevapp, transpir, transpot, vevapnu, vevapwet, vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, &
+!!$            & vevapp, transpir, transpot, gpp, vevapnu, vevapwet, vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, &
+            & temp_sol_new, qsurf, evapot, evapot_corr, rest_id, hist_id, hist2_id, jr_enerbil, beta_diffuco, &
+            & james_write)  
+
+       ! initialise some multilayer energy budget variables 
+        
+       temp_leaf_pres_grid(:,:) = 300.0d0  ! this is the leaf temperature for the first time step 
+                                           !     (for the multi-level energy budget)
+
+       DO i = 1, kjpindex
+          temp_atmos_pres_grid(i,:) = temp_air(i)
+          q_atmos_pres_grid(i,:) = qair(i)
+       END DO ! i = 1, kjpindex
+
+
+       ! for sechiba_hydrol_arch
+       swc(:,:,:) = 0.0d0
+       ksave(:,:,:)=min_sechiba
+
+       !! 1.6 Initialize some hydrological variables from restart file
+       IF (ldrestart_read) THEN
+          
+          var_name='runoff' ;
+          CALL ioconf_setatt_p('UNITS', 'mm/d')
+          CALL ioconf_setatt_p('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_p('UNITS', 'mm/d')
+          CALL ioconf_setatt_p('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 ! ldrestart_read
+       
+       !! 1.7 Initialize remaining hydrological variables
+       IF ( .NOT. hydrol_cwrr ) THEN
+          ! 1.7.1 Initialize remaining hydrological variables from Choisnel module (2 soil layers)
+          CALL hydrolc_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, control_in, &
+               & temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max,&
+               & qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
+               & tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
+               & vegstress, rsol, drysoil_frac, evapot, evapot_corr, flood_frac, flood_res, shumdiag, litterhumdiag, &
+               & soilcap, rest_id, hist_id, hist2_id) 
+
+          evap_bare_lim(:) = -un
+          k_litt(:) = huit
+       ELSE
+          !! 1.7.2 Initialize remaining hydrological variables from CWRR module (11 soil layers)
+!          CALL hydrol_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
+!               & index, indexveg, indexsoil, indexlayer, control_in, &
+!               & temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max, njsc, &
+!               & qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
+!               & tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
+!               & vegstress, drysoil_frac, evapot, evapot_corr, evap_bare_lim, flood_frac, flood_res, &
+!               & shumdiag, k_litt, litterhumdiag, soilcap, soiltile, reinf_slope, rest_id, hist_id, hist2_id, swc, veg_soiltext)
+
+!tzjwb
+!  CALL hydrol_main (kjit, kjpindex, &
+!       & index, indexveg, indexsoil, indexlayer, indexnbdl, &
+!       & temp_sol_new, floodout, runoff, drainage, frac_nobio,totfrac_nobio,vevapwet, veget, veget_max, njsc, &
+!      & qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age,snow_nobio, snow_nobio_age,  &
+!       & tot_melt, transpir, precip_rain, precip_snow, returnflow,reinfiltration, irrigation, &
+!       & humrel, vegstress, drysoil_frac, evapot, evapot_corr, evap_bare_lim,flood_frac, flood_res, &
+!       & shumdiag,shumdiag_perma, k_litt, litterhumdiag, soilcap, soiltile, reinf_slope, rest_id, hist_id, hist2_id,&
+!       & stempdiag, &
+!       & temp_air, pb, u, v, swnet, pgflux, &
+!       & gtemp,tot_bare_soil, temp_sol_add, &
+!       & mc_layh, mcl_layh, tmc_layh,control_in )
+
+
+       CALL  hydrol_initialize ( kjit,           kjpindex,  index, rest_id,          &
+                                 njsc,           soiltile,  veget, veget_max,&
+                                 humrel,         vegstress, drysoil_frac,&
+                                 shumdiag_perma, k_litt,    qsintveg,&
+                                 evap_bare_lim,  snow,      snow_age, snow_nobio,       &
+                                 snow_nobio_age,  &
+                                 mc_layh,       mcl_layh,  tmc_layh)
+
+
+       ENDIF !hydrol_cwrr
+
+       !! 1.8 Initialize some water balance variables from restart file
+       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 ! ldrestart_read
+        
+       !! 1.9 Initialize surface parameters (emissivity, albedo and roughness)
+       CALL condveg_main (kjit, kjpindex, dtradia, 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,  emis, albedo, z0, roughheight, &
+            rest_id, hist_id, hist2_id, lai, &
+            sinang, circ_class_biomass, circ_class_n, &
+            lai_split,z0_veg, Isotrop_Abs_Tot_p, Isotrop_Tran_Tot_p, laieff_fit,&
+            albedo_pft, frac_snow_nobio, frac_snow_veg)
+
+       !! 1.10 Initialization of soil thermodynamics
+!       CALL thermosoil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
+!            & index, indexgrnd, temp_sol_new, snow, soilcap, soilflx, shumdiag, stempdiag, ptnlev1, rest_id, hist_id, hist2_id) 
+
+ ! tzjwb
+!       CALL thermosoil_main (kjit, kjpindex, &
+!       index, indexgrnd, &
+!       temp_sol_new, snow, soilcap, soilflx, &
+!       shumdiag_perma, stempdiag, ptnlev1, rest_id, hist_id, hist2_id, &
+!       gtemp,pb,&
+!       mc_layh, mcl_layh, tmc_layh, njsc, frac_snow_veg,frac_snow_nobio,totfrac_nobio,temp_sol_add, &
+!       lambda_snow, cgrnd_snow, dgrnd_snow)
+
+        CALL thermosoil_initialize (kjit,          kjpindex,   rest_id,&
+                                    temp_sol_new,  snow,       shumdiag_perma,&
+                                    soilcap,       soilflx,    stempdiag,&
+                                    gtemp,                   &
+                                    mc_layh,       mcl_layh,   tmc_layh, njsc,     &
+                                    frac_snow_veg,frac_snow_nobio,totfrac_nobio, &
+                                    !snowdz, snowrho, snowtemp, lambda_snow,
+                                    !cgrnd_snow, dgrnd_snow, pb)
+                                    lambda_snow, cgrnd_snow, dgrnd_snow, pb)
+
+
+
+
+       !! 1.11 Initialize some soil thermodynamics from restart file
+       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 ! ldrestart_read
+
+       !! 1.12 Initialize river routing
+       IF ( river_routing .AND. nbp_glo .GT. 1) THEN
+          !! 1.12.1 Initialize river routing
+          CALL routing_main (kjit, kjpindex, dtradia, control_in, ldrestart_read, ldrestart_write, index, &
+               & lalo, neighbours, resolution, contfrac, totfrac_nobio, veget_max, floodout, runoff, &
+               & drainage, transpot, precip_rain, humrel, k_litt, flood_frac, flood_res, &
+               & stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, &
+               & rest_id, hist_id, hist2_id)
+       ELSE
+          !! 1.12.2 No routing, set variables to zero
+          riverflow(:) = zero
+          coastalflow(:) = zero
+          returnflow(:) = zero
+          reinfiltration(:) = zero
+          irrigation(:) = zero
+          flood_frac(:) = zero
+          flood_res(:) = zero
+       ENDIF
+
+       !! 1.13 Write internal variables to output fields
+       z0_out(:) = z0(:)
+       emis_out(:) = emis(:)
+       albedo_out(:,:) = albedo(:,:) 
+       qsurf_out(:) = qsurf(:)
+
+       !! 1.14 Deallocate memory
+       DEALLOCATE(runoff1,drainage1,soilcap1,soilflx1)
+       DEALLOCATE(shumdiag1)
+       
+
+       !! 1.15 Some variables need to be initialized here, since
+       !! slowproc is not called in this loop.  These variables
+       !! are used in diffuco, which is called before slowproc.
+       temp_growth(:)=zero
+
+       RETURN ! Out of sechiba main (should remain the last line!)
+ 
+
+    ENDIF ! l_first_sechiba
+
+
+!! 2. Computes SECHIBA's variables
+
+    !! 2.1 Initialize variables at each time step
+    CALL sechiba_var_init (kjpindex, rau, pb, temp_air) 
+
+
+
+
+    !! 2.2 Compute diffusion coefficients
+    CALL diffuco_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, indexveg, indexlai, u, v, &
+!        & zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, pb ,  &  !!?? could this line be deleted?
+         & zlev, z0, roughheight, temp_sol, temp_air, temp_growth, rau, tq_cdrag, qsurf, qair, q2m, t2m, pb ,  &
+         & rsol, evap_bare_lim, evapot, evapot_corr, snow, flood_frac, flood_res, frac_nobio, snow_nobio, totfrac_nobio, &
+         & swnet, swdown, sinang, ccanopy, humrel, vegstress, veget, veget_max, biomass, qsintveg, qsintmax, assim_param, &
+         & vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta3pot, vbeta4, vbeta5, gsmean, rveget, rstruct, cimean, gpp, &
+         & lalo, neighbours, resolution, ptnlev1, precip_rain, frac_age,  &
+         & rest_id, hist_id, hist2_id, vbeta2sum, vbeta3sum, Isotrop_Abs_Tot_p, Isotrop_Tran_Tot_p,&
+         lai_per_level, lai, vbeta23, leaf_ci, gs_distribution, gs_diffuco_output, gstot_component, gstot_frac, warnings)
+        !DO ji = 1, kjpindex
+        !    write(*,*) 'vbeta3_diffuco_main',vbeta3(ji,2)
+        !    write(*,*) 'speed_diffuco_main',SQRT (u(ji)*u(ji) + v(ji)*v(ji))
+        !    write(*,*) 'tq_cdrag_diffuco_main',tq_cdrag(ji)
+        !    write(*,*) 'rveget_diffuco_main',rveget(ji,2)
+        !ENDDO
+    !! 2.3 Compute energy balance
+
+    IF (control_in%ok_nenerbil) THEN
+    !IF (jr_enerbil) THEN
+
+       hydrol_flag = .FALSE.
+       hydrol_flag2 = .FALSE.
+       hydrol_flag3 = .FALSE.
+       
+       ! ---------------------------------------------------------------------------------------------------
+       ! before first calling diffuco_trans_co2 again, store output values from the first call to diffuco
+  
+       vbeta3_save(:,:) = vbeta3(:,:)           !! Beta for Transpiration (unitless)
+       vbeta3pot_save(:,:) = vbeta3pot(:,:)     !! Beta for Potential Transpiration
+       rveget_save(:,:) = rveget(:,:)           !! stomatal resistance of vegetation 
+       rstruct_save(:,:) = rstruct(:,:)         !! structural resistance @tex ($s m^{-1}$) @endtex
+       cimean_save(:,:) = cimean(:,:)           ! mean intercellular CO2 concentration
+       gsmean_save(:,:) = gsmean(:,:)           ! mean stomatal conductance to CO2 (umol m-2 s-1)
+       gpp_save(:,:) = gpp(:,:)                 !! gross primary production
+       ! ---------------------------------------------------------------------------------------------------
+
+       ! WRITE(numout,*) '100114 before copy TO temp_sol_new_save, temp_sol_new(1) is: ', temp_sol_new(1)
+       ! WRITE(numout,*) '100114 before copy TO temp_sol_new_save, temp_sol_new(2) is: ', temp_sol_new(2)
+       
+       ! ---------------------------------------------------------------------------------------------------
+       ! before first call to enerbil, store initial values
+  
+        evapot_save(:) = evapot(:)                !! Soil Potential Evaporation (mm day^{-1})
+        evapot_corr_save(:) = evapot_corr(:)      !! Soil Potential Evaporation Correction (mm day^{-1})
+        qsurf_save(:) = qsurf(:)                  !! Surface specific humidity (kg kg^{-1})
+
+        temp_sol_save(:) = temp_sol(:)            !! Soil temperature (K)
+        temp_sol_new_save(:) = temp_sol_new(:)    !! New soil temperature (K)
+        tsol_rad_save(:) = tsol_rad(:)            !! Tsol_rad (W m^{-2})
+        vevapp_save(:) = vevapp(:)                !! Total of evaporation (mm day^{-1})
+        gpp_save(:,:) = gpp(:,:)                  !! Assimilation ((gC m^{-2}), total area)
+        vbeta2sum_save(:) = vbeta2sum(:) 
+        vbeta3sum_save(:) = vbeta3sum(:)
+        ! ---------------------------------------------------------------------------------------------------
+        CALL jdriver (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
+             & index, indexveg, zlev, lwdown, swnet, epot_air, temp_air, &
+             & u, v, petAcoef, petBcoef, qair, peqAcoef, peqBcoef, pb, rau, &
+             & vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta3pot, vbeta4, vbeta5, &
+             & emis, soilflx, soilcap, tq_cdrag, humrel, &
+!!$             & cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, &
+             & fluxsens, fluxlat, vevapp, transpir, transpot, vevapnu, vevapwet, &
+!!$             & fluxsens, fluxlat, vevapp, transpir, transpot, gpp, vevapnu, vevapwet, &
+             & vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, temp_sol_new, qsurf, &
+             & evapot, evapot_corr, rest_id, hist_id, hist2_id, jr_enerbil, & 
+             & flux_ground_h, flux_ground_le, flux_h_grid, flux_le_grid, t_a_next_grid, q_a_next_grid, & 
+             & james_write, temp_surf_next, temp_atmos_pres_grid, q_atmos_pres_grid, &
+             & james_netcdf_flag, james_step_count, temp_leaf_pres_grid, temp_surf_pres, &
+             & transpir_supply, hydrol_flag, hydrol_flag2, &
+             & hydrol_flag3, vbeta2sum, vbeta3sum, veget_max, qsol_sat_new_out, qair_new, delta_temp_save, netrad_out, veget)   
+        
+       ! write(*,*) 'second_flag',1
+       ! DO ji = 1, kjpindex
+       !     write(*,*) 'transpir_2call',transpir(ji,2)
+       !     write(*,*) 'transpir_supiply_2call',transpir_supply(ji,2)
+       !     write(*,*) 'qsatt_2call',qsol_sat_new_out(ji)
+       !     write(*,*) 'qair_2call',qair_new(ji)
+       !     write(*,*) 'rau_2call',rau(ji)
+       !     write(*,*) 'q_cdrag_2call',tq_cdrag(ji)
+       !     write(*,*) 'speed_2call',SQRT (u(ji)*u(ji) + v(ji)*v(ji))
+       !     write(*,*) 'vbeta3_2call',vbeta3(ji,2)
+       !     write(*,*) 'vbeta_2call',vbeta(ji)
+       !     write(*,*) 'valpha_2call',valpha(ji)
+       !     write(*,*) 'vbeta2_2call',vbeta2(ji,2)
+       !     write(*,*) 'vbeta4_2call',vbeta4(ji)
+       !     write(*,*) 'vevapp_2call',vevapp(ji)
+       ! ENDDO
+
+
+        delta_temp_save = temp_surf_next - temp_sol
+
+        ! JR 260314 these are calculated in the first call to the jdriver, but may be required if it is called again
+        fluxsens_save(:) = fluxsens(:)            !! Sensible heat flux (W m^{-2})
+        fluxlat_save(:) = fluxlat(:)              !! Latent heat flux (W m^{-2})
+
+       
+        !+++CHECK+++
+        ! Store the proxy for unstressed ecosystem functioning. This could be gpp, transpiration,
+        ! evaporation. They all differ conceptually and numerically but the idea is the same.
+        ! In the initial approcah we tried to calculate the stress as a ratio of the initial 
+        ! transpiration over water supplied through the plant.  This approach resulted
+        ! in inconsistencies likely because the many feedbacks in the calculation of transpir. 
+        ! Similar issues were observed when using transpot. For this reason it was decided to drop
+        ! this approach and use the ratio between the initial and adjusted gpp instead. After
+        ! all this ratio will be used in stomate to adjust the allocation.
+        ! Note that the feedback on gpp is calculated based on the ratio between ::transpir_supply 
+        ! and transpir at the halmf hourly time step. In stomate we use the ratio between stressed
+        ! and unstressed but at the daily time step. Night time values should be ignored in the
+        ! daily calculation. If night time values are considered to unstressed this will skew
+        ! the result.
+        unstressed(:,:) = gpp(:,:)
+        !+++++++++++
+        
+
+        IF (control_in%ok_hydrol_arch) THEN
+! tzj tzjh add agurments 
+
+           CALL hydrol_arch (kjpindex,rest_id,ldrestart_read, ldrestart_write, circ_class_biomass, circ_class_n, temp_sol_new, &
+                temp_air, swc, transpir_supply, dtradia, njsc, biomass, ind, soiltile, &
+                vir_transpir_supply, veget, kjit, indexveg, hist_id, indexlayer, qsurf, pb, &
+                vl, vx, vr, psi_leaf, psi_stem, psi_root,swdown,ksave,stem_plc,transpir_tot,VPD_tzj,gsh,tzj_supply)
+           
+
+    
+           ! transpir_supply is provided in mm per timestep (dtradia)
+           hydrol_flag2(:) = .FALSE.
+           hydrol_flag3(:,:) = .FALSE.
+           transpir_init(:,:) = zero
+ 
+           DO ji = 1, kjpindex
+
+              !don't restrict gs during night
+              !WRITE(numout,*) 'sinang, is zero when night',sinang(ji)
+              DO jv = 1, nvm
+                 IF (sinang(ji) .LT. min_sechiba) THEN
+                    ! Night time we will never recalculate the energy budget
+                    hydrol_flag2(ji) = .FALSE.
+                    hydrol_flag3(ji,jv) = .FALSE.
+                    transpir_init(ji, jv)= zero
+                 ELSE
+                    ! The ratio between ::transpir_supply and ::transpir is used to decide
+                    ! whether we will recalculate gpp, transpir, ... (thus enerbil). This
+                    ! is done every half hour. The waterstress that will be passed to stomate
+                    ! to adjust the allocation will be calculated at the daily time step.
+                    ! It is important NOT to include night time values in the daily mean
+                    ! because more southern sides have shorter days during the growing season
+                    ! the number of half hours with day light biases the waterstress if it 
+                    ! is assumed that there is no waterstress at night.
+
+                    IF (veget_max(ji,jv) .GT. zero .AND. &
+                         veget(ji,jv) .GT. zero) THEN  
+                        transpir_init(ji, jv)= (transpir(ji,jv)/veget_max(ji,jv)) 
+                       !comparing the transpiration in tree-stand scale   
+                       ! Naudts - > Emilie Joetzjer 13 Jan 2020
+                       IF ( transpir_supply(ji,jv) .LT. transpir_init(ji,jv) ) THEN 
+                          IF(ld_enerbil .OR. ld_wstress) WRITE(numout,*) '091013 hydrol_flag2&3 set to TRUE, pft is: ', jv
+                          hydrol_flag2(ji) = .TRUE.
+                          hydrol_flag3(ji,jv) = .TRUE.
+                       ELSE
+                          IF(ld_enerbil .OR. ld_wstress) WRITE(numout,*) '091013 hydrol_flag2 set to FALSE, pft is: ', jv
+                       END IF
+                    ELSE
+                       ! There is no vegetation here, so we can skip it.
+                       ! the flag at the pixel level (::hydrol_flag2) should 
+                       ! not change its value.
+                       hydrol_flag3(ji,jv) = .FALSE.
+                       transpir_init(ji, jv)= zero
+                    ENDIF
+                    
+                    !---TEMP---
+                    IF(ld_wstress .AND. (jv.EQ.test_pft)) THEN
+                       WRITE(numout,*) 'YC transpir_init:',   transpir_init(ji, jv)
+                       WRITE(numout,*) 'transpir_supply, ',transpir_supply(ji,test_pft)
+                       IF (veget_max(ji,test_pft) .GT. zero) THEN  
+                          WRITE(numout,*) 'transpir modified, ', transpir(ji,test_pft)/veget_max(ji,test_pft) 
+                       ENDIF
+                    ENDIF
+                    !----------
+
+                 END IF
+
+              END DO ! jv = 1, nvm
+              !write(*,*) 'transpir_supply_sechiba',transpir_supply(ji,2)
+
+           END DO ! ji = 1, kjpindex
+        
+           ! now we call the module 'jdriver after transpir_supply', if there are grid squares
+           !   for which the condition is satisfied
+           
+           hydrol_flag = .FALSE.
+
+           DO ji = 1, kjpindex  ! grid point cycle
+
+              IF  (hydrol_flag2(ji)) THEN    ! this switch is 'tripped' if the above applies to any PFT at the
+                 ! grid point, as the whole energy budget for that grid point must
+                 ! then be recalculated
+                 hydrol_flag = .TRUE.
+              ELSE
+                 ! move on to the next PFT for the grid point in question
+              END IF
+              
+           END DO ! ji = 1, kjpindex
+           !write(*,*) 'hydrol_flag_yyt',hydrol_flag
+ 
+           ! to switch off the enerbil/hydrol interface it would be necessary to set here: hydrol_flag = .FALSE.
+           ! This is now externalized, so you can control it from the input file by specifying
+           ! SECHIBA_GS_FEEDBACK = n
+           IF(.NOT. control_in%ok_gs_feedback) hydrol_flag=.FALSE.
+
+           IF (hydrol_flag) THEN
+           
+              ! 011013 jdriver should be called here again (to recalculate the energy budget because of
+              !     supply term constriction
+           
+              ! WRITE(numout,*) '100114 before copy from temp_sol_new_save, temp_sol_new(1) is: ', temp_sol_new(1)
+
+              ! ---------------------------------------------------------------------------------------------------  
+              ! before 2nd call to enerbil, recall initial values (the ones un-changed from the first enerbil call)
+           
+              evapot(:) = evapot_save(:)                   !! Soil Potential Evaporation (mm day^{-1})
+              evapot_corr(:) = evapot_corr_save(:)         !! Soil Potential Evaporation Correction (mm day^{-1})
+              temp_sol(:) = temp_sol_save(:)               !! Soil temperature (K)
+              qsurf(:) = qsurf_save(:)                     !! Surface specific humidity (kg kg^{-1})
+              fluxsens(:) = fluxsens_save(:)               !! Sensible heat flux (W m^{-2})
+              fluxlat(:) = fluxlat_save(:)                 !! Latent heat flux (W m^{-2})
+              tsol_rad(:) = tsol_rad_save(:)               !! Tsol_rad (W m^{-2})
+              vevapp(:) = vevapp_save(:)                   !! Total of evaporation (mm day^{-1})
+              gpp(:,:) = gpp_save(:,:)                     !! Assimilation ((gC m^{-2}), total area)
+              temp_sol_new(:) = temp_sol_new_save(:)       !! New soil temperature (K)
+              vbeta2sum(:) = vbeta2sum_save(:) 
+              vbeta3sum(:) = vbeta3sum_save(:)   
+              ! ---------------------------------------------------------------------------------------------------
+           
+              DO ji = 1, kjpindex  ! grid point cycle
+                 
+                 ! 201013 calculate new series of beta_v3
+              
+                 IF (hydrol_flag) THEN  ! overall hydrol flag
+                    
+                    vbeta3_oldvalue(:, :) = 0.0d0
+                 
+                    ! vbeta2sum(:) = zero
+                    IF (hydrol_flag2(ji)) THEN
+                       DO jv = 1, nvm
+                          IF (.NOT. hydrol_flag3(ji, jv)) THEN 
+                             ! this is for cases when the supply term is higher than the 
+                             !     transpiration) - i.e. the normal state of affairs
+                          ELSE
+                             vbeta3_oldvalue(ji, jv) = vbeta3(ji, jv)
+                             ! Correction for the vbeta3 by replacing the "veget_max" to "veget"
+                             !vbeta3(ji,jv) = (transpir_supply(ji,jv) * veget_max(ji,jv) ) / &
+                             !     & ( dtradia * (1.0d0 - vbeta1(ji)) * (qsol_sat_new_out(ji) - qair_new(ji)) * &
+                             !     & ( rau(ji) * (MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))) * tq_cdrag(ji)) )
+                             ! vbeta3(ji,jv) = (transpir_supply(ji,jv) * veget(ji,jv) ) / &
+                             !     & ( dtradia * (1.0d0 - vbeta1(ji)) * (qsol_sat_new_out(ji) - qair_new(ji)) * &
+                             !      & ( rau(ji) * (MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))) * tq_cdrag(ji)) )
+                             
+                             !+++++++++CHECK++++++++++++++
+                             ! We calucalate the vbeta3 based on the ::transpir_supply term for each grid and pft
+                             ! We should keep the spatial weighting fraction,::veget_max, for vebta3. Even the calculation
+                             ! of ::transpir_supply is in tree stand scale.   
+                             IF (veget_max(ji,jv) .GT. zero .AND. veget(ji,jv) .GT. zero) THEN        
+                              ! Naudts - > Emilie Joetzjer 13 Jan 2020 
+                              vbeta3(ji,jv) = veget_max(ji, jv) * transpir_supply(ji,jv)  / &  
+                                   &  ( dtradia * (1.0d0 - vbeta1(ji)) * (qsol_sat_new_out(ji) - qair_new(ji)) * &
+                                   &  ( rau(ji) * (MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))) * tq_cdrag(ji)) )
+                             ELSE
+                               !No vegetation presenst for this condition, then set vbeta3 equal to zero. 
+                               vbeta3(ji,jv) = 0.0d0
+                             ENDIF
+                             !write(*,*) 'vbeta3_sechiba',vbeta3(ji,jv)
+                             !write(*,*) 'tq_cdrag_sechiba',tq_cdrag(ji)
+                             !++++++++++++++++++++++++++++ 
+                             !IF (jv == test_pft .AND. test_grid == 1) THEN    
+                             !   WRITE(numout, '(A40)'        ) '=======Water Stress On======'
+                             !   WRITE(numout, '(A20, I14)'   ) '=======PFT======:', jv
+                             !   WRITE(numout, '(A20, ES14.4)') 'Old_Vbeta3_value:', vbeta3_oldvalue(ji, jv)
+                             !   WRITE(numout, '(A20, ES14.4)') 'New_Vbeta3_value:', vbeta3(ji, jv)
+                             !ENDIF      
+ 
+                              IF ( ( vbeta3(ji, jv)/vbeta3_oldvalue(ji, jv) ) .gt. 1.0d0 ) THEN
+                                ! WRITE(numout,*) 'vbeta3 ratio is greater than 1!!'
+                             END IF
+                          END IF ! (hydrol_flag3(ji, jv) .eq. .FALSE.)
+                       ENDDO ! jv = 1, nvm
+                    ELSE
+                       ! do nothing
+                    END IF ! (hydrol_flag2(ji) .eq. .TRUE.)        
+                 END IF ! IF (hydrol_flag .eq. .TRUE.)  
+                 
+              END DO ! ji = 1, kjpindex
+              
+              ! now to approximate the stomatatal conductance, where it is constrained by the supply term.
+              ! This calculation takes place over the whole canopy, for now.
+
+              ! To calculate the gs_effective (the effective stomatal conductance), first we need to calculate
+              !   a constrained vbeta3, and work back from there, using a tweaked version of diffuco_trans_co2
+              !write(*,*) 'second_flag',2
+              CALL jdriver (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
+                   & index, indexveg, zlev, lwdown, swnet, epot_air, temp_air, &
+                   & u, v, petAcoef, petBcoef, qair, peqAcoef, peqBcoef, pb, rau, &
+                   & vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta3pot, vbeta4, vbeta5, &
+                   & emis, soilflx, soilcap, tq_cdrag, humrel, &
+!!$                   & cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, &
+                   & fluxsens, fluxlat, vevapp, transpir, transpot, vevapnu, vevapwet, &
+!!$                   & fluxsens, fluxlat, vevapp, transpir, transpot, gpp, vevapnu, vevapwet, &
+                   & vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, temp_sol_new, qsurf, &
+                   & evapot, evapot_corr, rest_id, hist_id, hist2_id, jr_enerbil, & 
+                   & flux_ground_h, flux_ground_le, flux_h_grid, flux_le_grid, t_a_next_grid, q_a_next_grid, & 
+                   & james_write, temp_surf_next, temp_atmos_pres_grid, q_atmos_pres_grid, &
+                   & james_netcdf_flag, james_step_count, temp_leaf_pres_grid, temp_surf_pres, &
+                   & transpir_supply, hydrol_flag, hydrol_flag2, &
+                   & hydrol_flag3, vbeta2sum, vbeta3sum, veget_max, qsol_sat_new_out, qair_new, &
+                   & delta_temp_save, netrad_out, veget) 
+
+             !DO ji = 1, kjpindex
+                !write(*,*) 'transpir_2call',transpir(ji,2) 
+                !write(*,*) 'transpir_supiply_2call',transpir_supply(ji,2)
+               ! write(*,*) 'qsatt_2call',qsol_sat_new_out(ji)
+               ! write(*,*) 'qair_2call',qair_new(ji)
+               ! write(*,*) 'rau_2call',rau(ji)
+               ! write(*,*) 'q_cdrag_2call',tq_cdrag(ji)
+               ! write(*,*) 'speed_2call',SQRT (u(ji)*u(ji) + v(ji)*v(ji))
+               ! write(*,*) 'vbeta3_2call',vbeta3(ji,2)
+               ! write(*,*) 'vbeta_2call',vbeta(ji)
+               ! write(*,*) 'valpha_2call',valpha(ji)
+               ! write(*,*) 'vbeta2_2call',vbeta2(ji,2)
+               ! write(*,*) 'vbeta4_2call',vbeta4(ji)
+               ! write(*,*) 'vevapp_2call',vevapp(ji)
+             !ENDDO
+                 ! we need to pass on the new vbeta3 to jdiffuco_trans_co2
+                         
+             CALL jdiffuco_trans_co2 (kjpindex, dtradia, swdown, temp_sol, pb, qsurf, &
+                   & q2m, t2m, temp_growth, rau, u, v, tq_cdrag, vegstress, &
+                   & assim_param, ccanopy, veget_max, lai, qsintveg, qsintmax, &
+                   & vbeta3, vbeta3pot, rveget, rstruct, cimean, gsmean, gpp, &
+                   & vbeta23, Isotrop_Abs_Tot_p, Isotrop_Tran_Tot_p, lai_per_level, &
+                   & leaf_ci, hydrol_flag2, hydrol_flag3, gs_distribution, gs_diffuco_output, &
+                   & james_netcdf_flag, gstot_component, gstot_frac, warnings, veget, biomass)
+              
+
+              DO ji = 1, kjpindex
+
+                 DO  jv = 1, nvm
+
+                    IF (hydrol_flag3(ji,jv)) THEN
+
+                       ! do nothing (as the relevant values were calculated in jdiffuco_trans_co2)
+                       
+                    ELSE
+                       ! ------------------------------------------------------------------------------------------
+                       ! restore saved values for PFTs and grid squares not affected by water stress
+
+                       vbeta3(ji,jv) = vbeta3_save(ji,jv)        !! Beta for Transpiration (unitless)
+                       vbeta3pot(ji,jv) = vbeta3pot_save(ji,jv)  !! Beta for Potential Transpiration
+                       rveget(ji,jv) = rveget_save(ji,jv)        !! stomatal resistance of vegetation 
+                       rstruct(ji,jv) = rstruct_save(ji,jv)      !! structural resistance @tex ($s m^{-1}$) @endtex
+                       cimean(ji,jv) = cimean_save(ji,jv)        ! mean intercellular CO2 concentration
+                       gsmean(ji,jv) = gsmean_save(ji,jv)        ! mean stomatal conductance to CO2 (umol m-2 s-1)
+                       gpp(ji,jv) = gpp_save(ji,jv)              !! gross primary production
+                       ! ------------------------------------------------------------------------------------------
+
+                    END IF
+
+                 END DO ! jv = 1, nvm
+                 
+              END DO ! ji = 1, kjpindex
+
+           ELSE
+              ! do nothing
+           END IF
+
+           !+++CHECK+++
+           ! Store the proxy for stressed ecosystem functioning. This value is used in stomate
+           ! to calculate the waterstress used in allocation
+           stressed(:,:) = gpp(:,:)
+           !+++++++++++
+           
+        END IF   ! IF (control_in%ok_hydrol_arch) THEN
+
+        ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+        james_count = james_count + 1
+      
+        !! 2.3.1 Write some data to the history files.
+!!$        CALL enerbil_write (kjit, kjpindex, index, lwdown, ccanopy, temp_sol, &
+        CALL enerbil_write (kjit, kjpindex, index, lwdown, temp_sol, &
+            & temp_sol_new, evapot, evapot_corr, hist_id, hist2_id)
+
+
+     ELSE
+    
+       !! 2.3.1 Compute energy balance using standard method if control%ok_enerbil is FALSE
+       !!       Second calling "enerbil_main" using standard method and and write varibles out to history file 
+       !!	write(numout, *) "YC: Compute energy balance using standard method 
+       CALL enerbil_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, &
+            & index, indexveg, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef, &
+            & qair, peqAcoef, peqBcoef, pb, rau, vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta3pot, vbeta4, vbeta5, &
+            & emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
+!!$            & cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
+            & vevapp, transpir, transpot, vevapnu, vevapwet, vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, &
+!!$            & vevapp, transpir, transpot, gpp, vevapnu, vevapwet, vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, &
+            & temp_sol_new, qsurf, evapot, evapot_corr, rest_id, hist_id, hist2_id, jr_enerbil, beta_diffuco, &
+            & james_write)
+
+    ! END IF ! (jr_enerbil)
+    END IF ! (control_in%ok_nenerbil)
+    
+    soilflx_out=soilflx !add by YC 20140313 copy the soilflx to soilflx_out
+
+    !! 2.4 Compute hydrology
+    IF ( .NOT. hydrol_cwrr ) THEN
+       ! 2.4.1 Water balance from Choisnel module (2 soil layers)
+       CALL hydrolc_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, indexveg, control_in,&
+            & temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max,&
+            & qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
+            & tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
+            & vegstress, rsol, drysoil_frac, evapot, evapot_corr, flood_frac, flood_res, shumdiag, litterhumdiag, &
+            & soilcap, rest_id, hist_id, hist2_id) 
+
+       evap_bare_lim(:) = -un
+       k_litt(:) = huit
+    ELSE
+       !! 2.4.1 Water balance from CWRR module (11 soil layers)
+!       CALL hydrol_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, &
+!            & index, indexveg, indexsoil, indexlayer, control_in, &
+!            & temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max, njsc,&
+!            & qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
+!            & tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
+!            & vegstress, drysoil_frac, evapot, evapot_corr, evap_bare_lim, flood_frac, flood_res, &
+!            & shumdiag, k_litt, litterhumdiag, soilcap, soiltile, reinf_slope, rest_id, hist_id, hist2_id, swc, veg_soiltext)
+
+!tzjwb   tzjswc
+  CALL hydrol_main (kjit, kjpindex, &
+       & index, indexveg, indexsoil, indexlayer, indexnbdl, &
+       & temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio,vevapwet, veget, veget_max, njsc, &
+       & qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age,snow_nobio, snow_nobio_age,  &
+       & tot_melt, transpir, precip_rain, precip_snow, returnflow,reinfiltration, irrigation, &
+       & humrel, vegstress, drysoil_frac, evapot, evapot_corr, evap_bare_lim,flood_frac, flood_res, &
+       & shumdiag,shumdiag_perma, k_litt, litterhumdiag, soilcap, soiltile, reinf_slope, rest_id, hist_id, hist2_id,&
+       & stempdiag, &
+       & temp_air, pb, u, v, swnet, pgflux, &
+       & gtemp,tot_bare_soil, temp_sol_add, &
+       & mc_layh, mcl_layh, tmc_layh,control_in,swc, ksave )
+
+
+       rsol(:) = -un
+
+    ENDIF
+
+    IF ( .NOT. control_in%ok_nenerbil) THEN
+    ! IF ( .NOT. jr_enerbil) THEN
+        IF (control_in%ok_hydrol_arch) THEN
+            !!+++CHECK: move to enerbill?+++
+! tzj tzjh add arguments
+            CALL hydrol_arch (kjpindex,rest_id,ldrestart_read, ldrestart_write, circ_class_biomass, circ_class_n, temp_sol_new, &
+                 temp_air, swc, transpir_supply, dtradia, njsc, biomass, ind, soiltile, &
+                 vir_transpir_supply, veget, kjit, indexveg, hist_id, indexlayer ,qsurf, pb, & 
+                 vl, vx, vr, psi_leaf, psi_stem, psi_root,swdown, ksave,stem_plc,transpir_tot,VPD_tzj,gsh,tzj_supply)
+            !!+++++++++++
+        ENDIF
+    END IF ! ( .NOT. control_in%ok_nenerbil)
+  
+    !! 2.5 Compute remaining components of the energy balance
+    CALL enerbil_fusion (kjpindex, dtradia, tot_melt, soilcap, temp_sol_new, fusion)
+
+    !! 2.6 Compute surface variables (emissivity, albedo and roughness)
+    CALL condveg_main (kjit, kjpindex, dtradia, 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,  emis, albedo, z0, roughheight, &
+         rest_id, hist_id, hist2_id, lai, &
+         sinang, circ_class_biomass, circ_class_n, &
+         lai_split, z0_veg, Isotrop_Abs_Tot_p, Isotrop_Tran_Tot_p, laieff_fit,&
+         albedo_pft, frac_snow_nobio, frac_snow_veg)
+
+    !! 2.7 Compute soil thermodynamics
+!    CALL thermosoil_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, indexgrnd, &
+!         & temp_sol_new, snow, soilcap, soilflx, shumdiag, stempdiag, ptnlev1, rest_id, hist_id, hist2_id) 
+
+ ! tzjwb
+       CALL thermosoil_main (kjit, kjpindex, &
+       index, indexgrnd, &
+       temp_sol_new, snow, soilcap, soilflx, &
+       shumdiag_perma, stempdiag, ptnlev1, rest_id, hist_id, hist2_id, &
+       !snowdz,snowrho,snowtemp,gtemp,pb,&
+       gtemp,pb,&
+       mc_layh, mcl_layh, tmc_layh, njsc, frac_snow_veg,frac_snow_nobio,totfrac_nobio,temp_sol_add, &
+       lambda_snow, cgrnd_snow, dgrnd_snow)
+
+    !! 2.8 Compute river routing 
+    IF ( river_routing .AND. nbp_glo .GT. 1) THEN
+       !! 2.8.1 River routing
+       CALL routing_main (kjit, kjpindex, dtradia, control_in, ldrestart_read, myfalse, index, &
+            & lalo, neighbours, resolution, contfrac, totfrac_nobio, veget_max, floodout, runoff, &
+            & drainage, transpot, precip_rain, humrel, k_litt, flood_frac, flood_res, &
+            & stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
+    ELSE
+       !! 2.8.2 No routing, set variables to zero
+       riverflow(:) = zero
+       coastalflow(:) = zero
+       returnflow(:) = zero
+       reinfiltration(:) = zero
+       irrigation(:) = zero
+       flood_frac(:) = zero
+       flood_res(:) = zero
+    ENDIF
+
+    !! 2.9 Compute slow processes (i.e. 'daily' and annual time step)
+    ! ::ok_co2 and ::ok_stomate are flags that determine whether the
+    ! forcing files are written.
+    CALL slowproc_main (kjit, kjpij, kjpindex, dtradia, date0, &
+         ldrestart_read, myfalse, control_in%ok_co2, control_in%ok_stomate, index, &
+         indexveg, lalo, neighbours, resolution, contfrac, &
+         soiltile, reinf_slope, t2mdiag, t2mdiag, temp_sol, &
+         stempdiag, vegstress, shumdiag, litterhumdiag, precip_rain, &
+         precip_snow, gpp, deadleaf_cover, assim_param, lai, &
+         frac_age, height, veget, frac_nobio, njsc, &
+         veget_max, totfrac_nobio, qsintmax, rest_id, hist_id, &
+         hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC, co2_flux, &
+         fco2_lu, sinang, circ_class_biomass, circ_class_n, &
+         transpir, stressed, unstressed, transpir_supply, &
+         biomass, ind, lai_per_level, laieff_fit, &
+         vir_transpir_supply, temp_growth, Isotrop_Tran_Tot_p,&
+         sum_veget_diff,stem_plc,psi_stem, psi_leaf, psi_root)
+
+    !! 2.9 Compute global CO2 flux
+    !+++CHECK+++
+    ! If co2flux contains soil respiration the loop should include the bare soil
+    ! because after a land cover change PFT1 can contain litter and soil carbon
+    netco2flux(:) = zero
+    DO jv = 2,nvm
+       netco2flux(:) = netco2flux(:) + co2_flux(:,jv)*veget_max(:,jv)
+    ENDDO
+    !+++++++++++
+ 
+    !! 2.10 Swap old for newly computed values 
+    CALL sechiba_end (kjpindex, dtradia, temp_sol, temp_sol_new)
+  
+!WRITE(numout,*) 'tzjE temp_sol sechiba',temp_sol
+ 
+    !! 2.11 Write internal variables to output fields
+    z0_out(:) = z0(:)
+    emis_out(:) = emis(:)
+    albedo_out(:,:) = albedo(:,:) 
+    qsurf_out(:) = qsurf(:)
+ 
+    !! 2.12 Write global variables to history files
+    sum_treefrac(:) = zero
+    sum_grassfrac(:) = zero
+    sum_cropfrac(:) = zero
+    DO jv = 2, nvm 
+       IF (is_tree(jv) .AND. natural(jv)) THEN
+          sum_treefrac(:) = sum_treefrac(:) + veget_max(:,jv)
+       ELSE IF ((.NOT. is_tree(jv))  .AND. natural(jv)) THEN
+          sum_grassfrac(:) = sum_grassfrac(:) + veget_max(:,jv)
+       ELSE 
+          sum_cropfrac = sum_cropfrac(:) + veget_max(:,jv)
+       ENDIF
+    ENDDO
+
+
+! initialize dia 
+dia(:,:,:)= zero
+    ! This is to print the tree density in each circumference class to the history file.
+    ! Originally this was just temporary, but it may serve a good purpose.
+    DO icir=1,ncirc
+       WRITE (var_name,"('CCN_',i3.3)") icir
+       CALL histwrite_p(hist_id_stom, var_name, kjit, circ_class_n(:,:,icir), kjpindex*nvm, indexveg)
+    ENDDO
+    
+    ! This is to print the tree diameter in each circumference class to the history file.
+    DO ipts=1,kjpindex
+        DO ivm=2,nvm
+            IF ( is_tree(ivm) ) THEN
+                dia(ipts,ivm,:)=wood_to_dia(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)   
+            ELSE
+                dia(ipts,ivm,:)=zero
+            ENDIF
+            !write(*,*) 'diayyt', dia(ipts,ivm,1)
+            !write(*,*) 'circbiomass',circ_class_biomass(ipts,ivm,1,isapabove,icarbon)
+        ENDDO
+    ENDDO 
+ 
+!WRITE(*,*)"dia1",  dia(:,:,:)   
+    
+      ! Write it to the netcdf
+    DO icir=1,ncirc
+       WRITE (var_name,"('CCD_',i3.3)") icir
+       CALL histwrite_p(hist_id_stom, var_name, kjit, dia(:,:,icir),kjpindex*nvm, indexveg)
+    ENDDO 
+    
+    
+    ! This is to print the tree diameter in each circumference class to the history file.
+    DO ipts=1,kjpindex
+        DO ivm=2,nvm
+            IF ( is_tree(ivm) ) THEN
+                dia(ipts,ivm,:)=wood_to_height(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)   
+            ELSE
+                dia(ipts,ivm,:)=zero
+            ENDIF
+        ENDDO
+    ENDDO 
+
+! WRITE(*,*)"dia2",  dia(:,:,:)   
+    
+    ! Write it to the netcdf
+    DO icir=1,ncirc
+       WRITE (var_name,"('CCH_',i3.3)") icir
+       CALL histwrite_p(hist_id_stom, var_name, kjit, dia(:,:,icir),kjpindex*nvm, indexveg)
+    ENDDO 
+    
+    ! This is to print the tree diameter in each circumference class to the history file.
+    DO ipts=1,kjpindex
+        DO ivm=2,nvm
+            IF ( is_tree(ivm) ) THEN
+                dia(ipts,ivm,:)=wood_to_cn(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)   
+            ELSE
+                dia(ipts,ivm,:)=zero
+            ENDIF
+        ENDDO
+    ENDDO 
+    
+    ! Write it to the netcdf
+    DO icir=1,ncirc
+       WRITE (var_name,"('CCC_',i3.3)") icir
+       CALL histwrite_p(hist_id_stom, var_name, kjit, dia(:,:,icir),kjpindex*nvm, indexveg)
+    ENDDO
+    
+    DO ipts=1,kjpindex
+        DO ivm=2,nvm
+            IF ( is_tree(ivm) ) THEN
+                dia(ipts,ivm,:)=circ_class_biomass(ipts,ivm,:,isapabove,icarbon)+circ_class_biomass(ipts,ivm,:,iheartabove,icarbon)
+            ELSE
+                dia(ipts,ivm,:)=zero
+            ENDIF
+        ENDDO
+    ENDDO 
+    
+    ! Write it to the netcdf
+    DO icir=1,ncirc
+       WRITE (var_name,"('CCB_',i3.3)") icir
+       CALL histwrite_p(hist_id_stom, var_name, kjit, dia(:,:,icir),kjpindex*nvm, indexveg)
+    ENDDO
+
+    CALL xios_orchidee_send_field("evapnu",vevapnu*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("snow",snow)
+    CALL xios_orchidee_send_field("snowage",snow_age)
+    CALL xios_orchidee_send_field("snownobio",snow_nobio)
+    CALL xios_orchidee_send_field("snownobioage",snow_nobio_age)
+    CALL xios_orchidee_send_field("reinf_slope",reinf_slope)
+    CALL xios_orchidee_send_field("soilindex",REAL(njsc, r_std))
+! tzjtexture
+!WRITE(*,*) "tzjtexture soilindex", nscm, njsc
+!
+!DO jv=1,nscm
+!IF (njsc(jv) .EQ. 6) njsc(jv)=7
+!ENDDO
+!
+!WRITE(*,*) "tzjtexture soilindex new", njsc
+
+    CALL xios_orchidee_send_field("vegetfrac",veget)
+    CALL xios_orchidee_send_field("maxvegetfrac",veget_max)
+    !CALL xios_orchidee_send_field("nobiofrac",frac_nobio)
+    CALL xios_orchidee_send_field("soiltile",soiltile)
+    CALL xios_orchidee_send_field("rstruct",rstruct)
+    CALL xios_orchidee_send_field("gpp",gpp/dt_sechiba)
+    CALL xios_orchidee_send_field("nee",co2_flux/dt_sechiba)
+    CALL xios_orchidee_send_field("drysoil_frac",drysoil_frac)
+    CALL xios_orchidee_send_field("evapflo",vevapflo*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("evapflo_alma",vevapflo/dt_sechiba)
+    CALL xios_orchidee_send_field("k_litt",k_litt)
+    CALL xios_orchidee_send_field("beta",vbeta)
+    CALL xios_orchidee_send_field("vbeta1",vbeta1)
+    CALL xios_orchidee_send_field("vbeta2",vbeta2)
+    CALL xios_orchidee_send_field("vbeta3",vbeta3)
+    CALL xios_orchidee_send_field("vbeta4",vbeta4)
+    CALL xios_orchidee_send_field("vbeta5",vbeta5)
+!    CALL xios_orchidee_send_field("vbetaco2",vbetaco2)
+    CALL xios_orchidee_send_field("gsmean",gsmean) 
+    CALL xios_orchidee_send_field("cimean",cimean)
+    CALL xios_orchidee_send_field("rveget",rveget)
+    CALL xios_orchidee_send_field("rsol",rsol)
+
+! Note that 0.0005555556 is used instead of one_day/dt temporary to have the same 
+! order of cacluation as using IOIPSL for compairing of resluts. This will be changed in futur update.   
+    histvar(:)=SUM(vevapwet(:,:),dim=2)
+    CALL xios_orchidee_send_field("evspsblveg",histvar/dt_sechiba)
+    histvar(:)= vevapnu(:)+vevapsno(:)
+    CALL xios_orchidee_send_field("evspsblsoi",histvar/dt_sechiba)
+    histvar(:)=SUM(transpir(:,:),dim=2)
+    CALL xios_orchidee_send_field("tran",histvar/dt_sechiba)
+    !histvar(:)= sum_treefrac(:)*100*contfrac(:)
+    !CALL xios_orchidee_send_field("treeFrac",histvar)
+    !histvar(:)= sum_grassfrac(:)*100*contfrac(:)
+    !CALL xios_orchidee_send_field("grassFrac",histvar)
+    !histvar(:)= sum_cropfrac(:)*100*contfrac(:)
+    !CALL xios_orchidee_send_field("cropFrac",histvar)
+    !histvar(:)=veget_max(:,1)*100*contfrac(:)
+    !CALL xios_orchidee_send_field("baresoilFrac",histvar)
+    !histvar(:)=SUM(frac_nobio(:,1:nnobio),dim=2)*100*contfrac(:)
+    !CALL xios_orchidee_send_field("residualFrac",histvar)
+
+    CALL xios_orchidee_send_field("tsol_rad",tsol_rad-273.15)
+    CALL xios_orchidee_send_field("qsurf",qsurf)
+    CALL xios_orchidee_send_field("albedo",albedo)
+    CALL xios_orchidee_send_field("albedo_pft",albedo_pft)
+    CALL xios_orchidee_send_field("emis",emis)
+    CALL xios_orchidee_send_field("z0",z0)
+    CALL xios_orchidee_send_field("roughheight",roughheight)
+    CALL xios_orchidee_send_field("lai",lai)
+    CALL xios_orchidee_send_field("subli",vevapsno*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("vevapnu",vevapnu*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("vevapnu_alma",vevapnu/dt_sechiba)
+    CALL xios_orchidee_send_field("transpir",transpir*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("transpot",transpot*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("inter",vevapwet*one_day/dt_sechiba)
+    CALL xios_orchidee_send_field("Qf",fusion)
+    
+    CALL xios_orchidee_send_field("fluxnet",netrad_out)    ! 20140313 Add by YC
+    CALL xios_orchidee_send_field("fluxsoil", soilflx_out) ! 20140313 Add by YC
+         !CALL xios_orchidee_send_field("LAIPIX", laipix)        !20140521 Add by YC
+    CALL xios_orchidee_send_field("swe",snow)    
+    
+
+    ! test transpir
+    !DO ji = 1, kjpindex
+        !write(*,*) 'transpir_main',transpir(ji,2)
+        !write(*,*) 'transpir_oneday',transpir(ji,2)*one_day/dt_sechiba
+    !ENDDO
+    ! 
+
+
+     
+    histvar(:)=zero
+    DO jv=1,nvm
+      histvar(:) = histvar(:) + vevapwet(:,jv)
+    ENDDO
+    CALL xios_orchidee_send_field("ECanop",histvar/dt_sechiba)
+    histvar(:)=zero
+    DO jv=1,nvm
+      histvar(:) = histvar(:) + transpir(:,jv)
+    ENDDO
+    CALL xios_orchidee_send_field("TVeg",histvar/dt_sechiba)
+    CALL xios_orchidee_send_field("ACond",tq_cdrag)
+
+    IF ( .NOT. almaoutput ) THEN
+       ! Write history file in IPSL-format
+       CALL histwrite_p(hist_id, 'beta', kjit, vbeta, kjpindex, index)
+       CALL histwrite_p(hist_id, 'z0', kjit, z0, kjpindex, index)
+       CALL histwrite_p(hist_id, 'roughheight', kjit, roughheight, kjpindex, index)
+       CALL histwrite_p(hist_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
+      ! laipix(:) = zero
+       laieff_pix (:) = zero
+       laieff_isotrop (:,:,:) = zero
+       laieff_pft (:,:) = zero
+      ! lai(:,1) = zero
+      ! laipix(:) = SUM(lai(:,:)*veget_max(:,:),2)
+      ! !WRITE (numout,*) 'lai'
+      ! WRITE (numout,*) 'lai per pixel', laipix 
+      ! CALL histwrite_p(hist_id_stom, 'laipix', kjit, laipix, kjpindex, index)
+       isotrop_angle=COS(60.0/180.0*pi)
+       DO ipts=1,kjpindex
+          DO ivm=1,nvm
+             DO ilevel=1,nlevels_tot
+                laieff_isotrop(ilevel,ipts,ivm)=calculate_laieff_fit(isotrop_angle,laieff_fit(ipts,ivm,ilevel))
+                ! Because we are fitting these values, it's possible that some will 
+                ! drop below zero.  This causes a serious problem here,
+                ! so let's make sure this doesn't happen.  Unfortunately, by
+                ! doing this, we lose a test of things going wrong (an unfitted
+                ! negative LAIeff can be the sign of another problem), but we
+                ! don't really have a choice.
+                IF(laieff_isotrop(ilevel,ipts,ivm) .LT. min_stomate) &
+                     laieff_isotrop(ilevel,ipts,ivm)=zero
+             ENDDO
+          ENDDO
+       ENDDO
+       laieff_pft(:,:) = SUM(laieff_isotrop(:,:,:),1)
+       laieff_pix(:)=SUM(laieff_pft(:,:)*veget_max(:,:),2)
+       CALL histwrite_p(hist_id, 'laieffpix',kjit,laieff_pix,kjpindex, index)
+       CALL histwrite_p(hist_id, 'maxvegetfrac', kjit, veget_max, kjpindex*nvm, indexveg)     
+       !CALL histwrite_p(hist_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
+       CALL histwrite_p(hist_id, 'lai', kjit, lai, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'subli', kjit, vevapsno, kjpindex, index)
+       CALL histwrite_p(hist_id, 'evapnu', kjit, vevapnu, kjpindex, index)
+       CALL histwrite_p(hist_id, 'transpir', kjit, transpir, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'transpot', kjit, transpot, kjpindex*nvm, indexveg)
+       IF (control_in%ok_hydrol_arch) THEN
+          CALL histwrite_p(hist_id, 'transpir_supply', kjit, transpir_supply, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'transpir_supplysec', kjit, transpir_supply, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'transpir_init', kjit, transpir_init, kjpindex*nvm, indexveg)
+       ENDIF
+       CALL histwrite_p(hist_id, 'inter', kjit, vevapwet, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'vbeta1', kjit, vbeta1, kjpindex, index)
+       CALL histwrite_p(hist_id, 'vbeta2', kjit, vbeta2, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'vbeta3', kjit, vbeta3, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'vbeta3pot', kjit, vbeta3pot, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'vbeta4', kjit, vbeta4, kjpindex, index)    
+       CALL histwrite_p(hist_id, 'vbeta5', kjit, vbeta5, kjpindex, index)    
+       CALL histwrite_p(hist_id, 'drysoil_frac', kjit, drysoil_frac, kjpindex, index)
+       CALL histwrite_p(hist_id, 'rveget', kjit, rveget, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'rstruct', kjit, rstruct, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'photo_warn', kjit, warnings(:,:,iwphoto), kjpindex*nvm, indexveg)
+       !+++++++++++++++++++++++++++++++++++++++++++++++++++
+       ! Adde by YC 20140313  For Checking Energy Budget    
+       CALL histwrite_p(hist_id, 'fluxnet',  kjit, netrad_out,  kjpindex, index) 
+       CALL histwrite_p(hist_id, 'fluxsoil', kjit, soilflx_out, kjpindex, index) 
+       !+++++++++++++++++++++++++++++++++++++++++++++++++++ 
+       CALL histwrite_p(hist_id, 'swe',      kjit, snow,        kjpindex, index)
+              
+       IF ( .NOT. control_in%hydrol_cwrr ) THEN
+          CALL histwrite_p(hist_id, 'rsol', kjit, rsol, kjpindex, index)
+       ENDIF
+       CALL histwrite_p(hist_id, 'snow', kjit, snow, kjpindex, index)
+       CALL histwrite_p(hist_id, 'snowage', kjit, snow_age, kjpindex, index)
+       CALL histwrite_p(hist_id, 'snownobio', kjit, snow_nobio, kjpindex*nnobio, indexnobio)
+       CALL histwrite_p(hist_id, 'snownobioage', kjit, snow_nobio_age, kjpindex*nnobio, indexnobio)
+       !
+       CALL histwrite_p(hist_id, 'soiltile',  kjit, soiltile, kjpindex*nstm, indexsoil)
+       !
+       IF ( control_in%hydrol_cwrr ) THEN
+          CALL histwrite_p(hist_id, 'soilindex',  kjit, REAL(njsc, r_std), kjpindex, index)
+          CALL histwrite_p(hist_id, 'reinf_slope',  kjit, reinf_slope, kjpindex, index)
+          CALL histwrite_p(hist_id, 'k_litt', kjit, k_litt, kjpindex, index)
+       ENDIF
+       IF ( control_in%do_floodplains ) THEN
+          CALL histwrite_p(hist_id, 'evapflo', kjit, vevapflo, kjpindex, index)
+          CALL histwrite_p(hist_id, 'flood_frac', kjit, flood_frac, kjpindex, index)
+       ENDIF
+       IF ( control_in%ok_co2 ) THEN
+          CALL histwrite_p(hist_id, 'gsmean', kjit, gsmean, kjpindex*nvm, indexveg)    
+          CALL histwrite_p(hist_id, 'gpp', kjit, gpp, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'cimean', kjit, cimean, kjpindex*nvm, indexveg)    
+       ENDIF
+       IF ( control_in%ok_stomate ) THEN
+          CALL histwrite_p(hist_id, 'nee', kjit, co2_flux, kjpindex*nvm, indexveg)    
+       ENDIF
+       
+       ! This is a tricky variable.  It's related to the canopy structure
+       ! and won't have a value if stomate is not activated.  However, it's
+       ! updated at every sechiba timestep.  So I have to put it here.
+       DO ivm=1,nvm
+          WRITE(var_name,'(A,I3.3)') 'ABS_CANOPY_LIGHT_',ivm
+          CALL histwrite_p (hist_id, var_name, kjit, &
+               Isotrop_Abs_Tot_p(:,ivm,:), kjpindex*nlevels_tot, indexcan) 
+       ENDDO
+
+       histvar(:)=SUM(vevapwet(:,:),dim=2)
+       CALL histwrite_p(hist_id, 'evspsblveg', kjit, histvar, kjpindex, index)
+
+       histvar(:)= vevapnu(:)+vevapsno(:)
+       CALL histwrite_p(hist_id, 'evspsblsoi', kjit, histvar, kjpindex, index)
+
+       histvar(:)=SUM(transpir(:,:),dim=2)
+       CALL histwrite_p(hist_id, 'tran', kjit, histvar, kjpindex, index)
+
+       !histvar(:)= sum_treefrac(:)*100*contfrac(:)
+       !CALL histwrite_p(hist_id, 'treeFrac', kjit, histvar, kjpindex, index) 
+
+       !histvar(:)= sum_grassfrac(:)*100*contfrac(:)
+       !CALL histwrite_p(hist_id, 'grassFrac', kjit, histvar, kjpindex, index) 
+
+       !histvar(:)= sum_cropfrac(:)*100*contfrac(:)
+       !CALL histwrite_p(hist_id, 'cropFrac', kjit, histvar, kjpindex, index)
+
+       !histvar(:)=veget_max(:,1)*100*contfrac(:)
+       !CALL histwrite_p(hist_id, 'baresoilFrac', kjit, histvar, kjpindex, index)
+
+       !histvar(:)=SUM(frac_nobio(:,1:nnobio),dim=2)*100*contfrac(:)
+       !CALL histwrite_p(hist_id, 'residualFrac', kjit, histvar, kjpindex, index)
+       ! For the snow fraction, we combine the snow fraction calculated for the
+       ! vegetated and non-vegetated fractions to get a value for the whole pixel.
+       frac_snow_pix(:)=zero
+       DO ivm=1,nvm
+          frac_snow_pix(:)=frac_snow_pix(:)+frac_snow_veg(:,ivm)*veget_max(:,ivm)
+       ENDDO
+       DO inno=1,nnobio
+          frac_snow_pix(:)=frac_snow_pix(:)+frac_snow_nobio(:,inno)*frac_nobio(:,inno)
+       ENDDO
+       CALL histwrite_p(hist_id, 'snowfrac', kjit, frac_snow_pix, kjpindex, index)
+       !+++++ CHECK +++++++
+       ! At one time we were having negative snow fractions.  I think that is
+       ! fixed, but I'm leaving this check in here for a little longer.
+       DO ipts=1,kjpindex
+          IF(frac_snow_pix(ipts) .LT. 0.0)THEN
+             WRITE(numout,*) 'SNOWFRAC ipts ',ipts,frac_snow_pix(ipts)
+             DO ivm=1,nvm
+                WRITE(numout,*) ivm,frac_snow_veg(ipts,ivm),veget_max(ipts,ivm)
+             ENDDO
+             WRITE(numout,*) 'NOBIO '
+             DO inno=1,nnobio
+                WRITE(numout,*) ivm,frac_snow_nobio(ipts,inno),frac_nobio(ipts,inno)
+             ENDDO
+             CALL ipslerr_p (3,'sechiba', 'snow frac error','','')
+          ENDIF
+       ENDDO
+       
+       !++++++++++++++++++
+
+    ELSE
+       ! Write history file in ALMA format 
+       CALL histwrite_p(hist_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'maxvegetfrac', kjit, veget_max, kjpindex*nvm, indexveg)
+       CALL histwrite_p(hist_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
+       CALL histwrite_p(hist_id, 'Qf', kjit, fusion, kjpindex, index)
+       CALL histwrite_p(hist_id, 'ESoil', kjit, vevapnu, kjpindex, index)
+       CALL histwrite_p(hist_id, 'EWater', kjit, vevapflo, kjpindex, index)
+       CALL histwrite_p(hist_id, 'SWE', kjit, snow, kjpindex, index)
+       histvar(:)=zero
+       DO jv=1,nvm
+          histvar(:) = histvar(:) + transpir(:,jv)
+       ENDDO
+       CALL histwrite_p(hist_id, 'TVeg', kjit, histvar, kjpindex, index)
+       histvar(:)=zero
+       DO jv=1,nvm
+          histvar(:) = histvar(:) + vevapwet(:,jv)
+       ENDDO
+       CALL histwrite_p(hist_id, 'ECanop', kjit, histvar, kjpindex, index)
+       CALL histwrite_p(hist_id, 'ACond', kjit, tq_cdrag, kjpindex, index)
+       !
+       CALL histwrite_p(hist_id, 'Z0', kjit, z0, kjpindex, index)
+       CALL histwrite_p(hist_id, 'EffectHeight', kjit, roughheight, kjpindex, index)
+       !
+       IF ( control_in%do_floodplains ) THEN
+          CALL histwrite_p(hist_id, 'Qflood', kjit, vevapflo, kjpindex, index)
+          CALL histwrite_p(hist_id, 'FloodFrac', kjit, flood_frac, kjpindex, index)
+       ENDIF
+       !
+       IF ( control_in%ok_co2 ) THEN
+          CALL histwrite_p(hist_id, 'GPP', kjit, gpp, kjpindex*nvm, indexveg)
+       ENDIF
+       IF ( control_in%ok_stomate ) THEN
+             CALL histwrite_p(hist_id, 'NEE', kjit, co2_flux, kjpindex*nvm, indexveg)    
+       ENDIF
+    ENDIF ! almaoutput
+    
+
+    !! 2.13 Write additional output file with higher frequency
+    IF ( hist2_id > 0 ) THEN
+       IF ( .NOT. almaoutput ) THEN
+          ! Write history file in IPSL-format
+!! enstzj          CALL histwrite_p(hist2_id, 'sinang', kjit, 180/pi*acos(sinang), kjpindex, index)
+          CALL histwrite_p(hist2_id, 'alb_vis_pft',kjit,albedo_pft(:,:,ivis),kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'alb_nir_pft',kjit,albedo_pft(:,:,inir),kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'tsol_rad', kjit, tsol_rad, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'qsurf', kjit, qsurf, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'emis', kjit, emis, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'beta', kjit, vbeta, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'z0', kjit, z0, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'roughheight', kjit, roughheight, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'maxvegetfrac', kjit, veget_max, kjpindex*nvm, indexveg)
+          !CALL histwrite_p(hist2_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
+          CALL histwrite_p(hist2_id, 'lai', kjit, lai, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'subli', kjit, vevapsno, kjpindex, index)
+          IF ( control_in%do_floodplains ) THEN
+             CALL histwrite_p(hist2_id, 'vevapflo', kjit, vevapflo, kjpindex, index)
+             CALL histwrite_p(hist2_id, 'flood_frac', kjit, flood_frac, kjpindex, index)
+          ENDIF
+          CALL histwrite_p(hist2_id, 'vevapnu', kjit, vevapnu, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'transpir', kjit, transpir, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'transpot', kjit, transpot, kjpindex*nvm, indexveg)
+          IF (control_in%ok_hydrol_arch) THEN
+             CALL histwrite_p(hist2_id, 'transpir_supply', kjit, transpir_supply, kjpindex*nvm, indexveg)
+          ENDIF
+          CALL histwrite_p(hist2_id, 'inter', kjit, vevapwet, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'vbeta1', kjit, vbeta1, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'vbeta2', kjit, vbeta2, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'vbeta3', kjit, vbeta3, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'vbeta3pot', kjit, vbeta3pot, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'vbeta4', kjit, vbeta4, kjpindex, index)    
+          CALL histwrite_p(hist2_id, 'vbeta5', kjit, vbeta5, kjpindex, index)    
+          CALL histwrite_p(hist2_id, 'drysoil_frac', kjit, drysoil_frac, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'rveget', kjit, rveget, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'rstruct', kjit, rstruct, kjpindex*nvm, indexveg)
+          !+++++++++++++++++++++++++++++++++++++++++++++++++++
+          ! Adde by YC 20140313  For Checking Energy Budget        
+          CALL histwrite_p(hist2_id, 'fluxnet',  kjit, netrad_out,  kjpindex, index) 
+          CALL histwrite_p(hist2_id, 'fluxsoil', kjit, soilflx_out, kjpindex, index) 
+          !+++++++++++++++++++++++++++++++++++++++++++++++++++ 
+          CALL histwrite_p(hist2_id, 'swe',      kjit, snow,        kjpindex, index) 
+          
+          IF ( .NOT. control_in%hydrol_cwrr ) THEN
+             CALL histwrite_p(hist2_id, 'rsol', kjit, rsol, kjpindex, index)
+          ENDIF
+          CALL histwrite_p(hist2_id, 'snowage', kjit, snow_age, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'snownobio', kjit, snow_nobio, kjpindex*nnobio, indexnobio)
+          CALL histwrite_p(hist2_id, 'snownobioage', kjit, snow_nobio_age, kjpindex*nnobio, indexnobio)
+          !
+          IF (  control_in%hydrol_cwrr ) THEN
+             CALL histwrite_p(hist2_id, 'soilindex',  kjit, REAL(njsc, r_std), kjpindex, index)
+             CALL histwrite_p(hist2_id, 'reinf_slope',  kjit, reinf_slope, kjpindex, index)
+          ENDIF
+          !
+          IF ( control_in%ok_co2 ) THEN               
+             CALL histwrite_p(hist2_id, 'gsmean', kjit, gsmean, kjpindex*nvm, indexveg)    
+             CALL histwrite_p(hist2_id, 'gpp', kjit, gpp, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'cimean', kjit, cimean, kjpindex*nvm, indexveg)    
+          ENDIF
+          IF ( control_in%ok_stomate ) THEN
+             CALL histwrite_p(hist2_id, 'nee', kjit, co2_flux, kjpindex*nvm, indexveg)    
+          ENDIF
+          ! For the snow fraction, we combine the snow fraction calculated for the
+          ! vegetated and non-vegetated fractions to get a value for the whole pixel.
+          frac_snow_pix(:)=zero
+          DO ivm=1,nvm
+             frac_snow_pix(:)=frac_snow_pix(:)+frac_snow_veg(:,ivm)*veget_max(:,ivm)
+          ENDDO
+          DO inno=1,nnobio
+             frac_snow_pix(:)=frac_snow_pix(:)+frac_snow_nobio(:,inno)*frac_nobio(:,inno)
+          ENDDO
+          CALL histwrite_p(hist2_id, 'snowfrac', kjit, frac_snow_pix, kjpindex, index)
+       ELSE
+          ! Write history file in ALMA format
+! enstzj          CALL histwrite_p(hist2_id, 'sinang', kjit, 180/pi*acos(sinang), kjpindex, index)
+          CALL histwrite_p(hist2_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'maxvegetfrac', kjit, veget_max, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist2_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
+          CALL histwrite_p(hist2_id, 'Qf', kjit, fusion, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'ESoil', kjit, vevapnu, kjpindex, index)
+          IF ( control_in%do_floodplains ) THEN
+             CALL histwrite_p(hist2_id, 'EWater', kjit, vevapflo, kjpindex, index)
+             CALL histwrite_p(hist2_id, 'FloodFrac', kjit, flood_frac, kjpindex, index)
+          ENDIF
+          CALL histwrite_p(hist2_id, 'SWE', kjit, snow, kjpindex, index)
+          histvar(:)=zero
+          DO jv=1,nvm
+             histvar(:) = histvar(:) + transpir(:,jv)
+          ENDDO
+          CALL histwrite_p(hist2_id, 'TVeg', kjit, histvar, kjpindex, index)
+          histvar(:)=zero
+          DO jv=1,nvm
+             histvar(:) = histvar(:) + vevapwet(:,jv)
+          ENDDO
+          CALL histwrite_p(hist2_id, 'ECanop', kjit, histvar, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'ACond', kjit, tq_cdrag, kjpindex, index)
+          IF ( control_in%ok_co2 ) THEN
+             CALL histwrite_p(hist2_id, 'GPP', kjit, gpp, kjpindex*nvm, indexveg)
+          ENDIF
+          IF ( control_in%ok_stomate ) THEN
+             CALL histwrite_p(hist2_id, 'NEE', kjit, co2_flux, kjpindex*nvm, indexveg)    
+          ENDIF
+       ENDIF ! almaoutput
+    ENDIF ! hist2_id
+    
+    
+
+
+!! 3. Write restart file for the next simulation from SECHIBA and other modules
+    IF (ldrestart_write) THEN
+
+       ! Only called during the last run
+       IF (long_print) WRITE (numout,*) ' we have to write a restart file '
+       !! 3.1 Call diffuco_main to write restart files
+       CALL diffuco_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, indexlai, u, v, &
+            & zlev, z0, roughheight, temp_sol, temp_air, temp_growth, rau, tq_cdrag, qsurf, qair, q2m, t2m, pb ,  &
+            & rsol, evap_bare_lim, evapot, evapot_corr, snow, flood_frac, flood_res, frac_nobio, snow_nobio, totfrac_nobio, &
+            & swnet, swdown, sinang, ccanopy, humrel, vegstress, veget, veget_max, biomass, qsintveg, qsintmax, assim_param, &
+            & vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta3pot, vbeta4, vbeta5, gsmean, rveget, rstruct, cimean, gpp, &
+            & lalo, neighbours, resolution, ptnlev1, precip_rain, frac_age,  &
+            & rest_id, hist_id, hist2_id, vbeta2sum, vbeta3sum, Isotrop_Abs_Tot_p, Isotrop_Tran_Tot_p,&
+            lai_per_level, lai, vbeta23, leaf_ci, gs_distribution, gs_diffuco_output, gstot_component, gstot_frac, warnings)
+
+       !! 3.2 Call energy budget to write restart files
+       !!     The third calling "enerbil_main" for writing restart files
+       CALL enerbil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
+            & index, indexveg, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
+            & qair, peqAcoef, peqBcoef, pb, rau, vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta3pot, vbeta4, vbeta5, &
+            & emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
+!!$            & cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
+            & vevapp, transpir, transpot, vevapnu, vevapwet, vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, &
+!!$            & vevapp, transpir, transpot, gpp, vevapnu, vevapwet, vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, &
+            & temp_sol_new, qsurf, evapot, evapot_corr, rest_id, hist_id, hist2_id, jr_enerbil, beta_diffuco, &
+            & james_write) 
+
+       !! 3.3 Call hydrology to write restart files
+       IF ( .NOT. hydrol_cwrr ) THEN
+          !! 3.3.1 Call water balance from Choisnel module (2 soil layers) to write restart file
+          CALL hydrolc_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, control_in, &
+               & temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max,&
+               & qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
+               & tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, &
+               & humrel, vegstress, rsol, drysoil_frac, evapot, evapot_corr, flood_frac, flood_res, shumdiag, litterhumdiag, &
+               & soilcap, rest_id, hist_id, hist2_id)
+          evap_bare_lim(:) = -un
+          k_litt(:) = huit
+       ELSE
+          !! 3.3.2 Call water balance from CWRR module (11 soil layers) to write restart file
+ !         CALL hydrol_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
+ !              & index, indexveg, indexsoil, indexlayer, control_in, &
+ !              & temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max, njsc, &
+ !              & qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
+ !              & tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
+ !              & vegstress, drysoil_frac, evapot, evapot_corr, evap_bare_lim, flood_frac, flood_res, &
+ !              & shumdiag, k_litt, litterhumdiag, soilcap, soiltile, reinf_slope, rest_id, hist_id, hist2_id, swc, veg_soiltext)
+
+
+!  CALL hydrol_main (kjit, kjpindex, &
+!       & index, indexveg, indexsoil, indexlayer, indexnbdl, &
+!       & temp_sol_new, floodout, runoff, drainage, frac_nobio,totfrac_nobio,vevapwet, veget, veget_max, njsc, &
+!       & qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age,snow_nobio, snow_nobio_age,  &
+!       & tot_melt, transpir, precip_rain, precip_snow, returnflow,reinfiltration, irrigation, &
+!       & humrel, vegstress, drysoil_frac, evapot, evapot_corr, evap_bare_lim,flood_frac, flood_res, &
+!       & shumdiag,shumdiag_perma, k_litt, litterhumdiag, soilcap, soiltile, reinf_slope, rest_id, hist_id, hist2_id,&
+!       & stempdiag, &
+!       & temp_air, pb, u, v, swnet, pgflux, &
+!       & gtemp,tot_bare_soil, temp_sol_add, &
+!       & mc_layh, mcl_layh, tmc_layh,control_in )
+
+  CALL hydrol_finalize( kjit, kjpindex,   rest_id,  vegstress,&
+                              qsintveg,       humrel,     snow,     snow_age, snow_nobio, &
+                              snow_nobio_age,  &
+                              drysoil_frac, evap_bare_lim)
+
+          rsol(:) = -un
+       ENDIF ! hydrol_cwrr
+   
+       !! 3.4 Call condveg to write surface variables to restart files
+       CALL condveg_main (kjit, kjpindex, dtradia, 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,  emis, albedo, z0, roughheight, &
+            rest_id, hist_id, hist2_id, lai, &
+            sinang, circ_class_biomass, circ_class_n, &
+            lai_split, z0_veg, Isotrop_Abs_Tot_p, Isotrop_Tran_Tot_p, laieff_fit,&
+            albedo_pft, frac_snow_nobio, frac_snow_veg)
+ 
+       !! 3.5 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, ptnlev1, rest_id, hist_id, hist2_id) 
+
+ ! tzjwb
+ !      CALL thermosoil_main (kjit, kjpindex, &
+ !      index, indexgrnd, &
+ !      temp_sol_new, snow, soilcap, soilflx, &
+ !      shumdiag_perma, stempdiag, ptnlev1, rest_id, hist_id, hist2_id, &
+ !      gtemp,pb,&
+ !      mc_layh, mcl_layh, tmc_layh, njsc, frac_snow_veg,frac_snow_nobio,totfrac_nobio,temp_sol_add, &
+ !      lambda_snow, cgrnd_snow, dgrnd_snow)
+
+       CALL thermosoil_finalize (kjit,    kjpindex, rest_id, gtemp, &
+                                  soilcap, soilflx, lambda_snow, cgrnd_snow, dgrnd_snow)
+ 
+
+       !! 3.6 Add river routing to restart files  
+       IF ( river_routing .AND. nbp_glo .GT. 1) THEN
+          !! 3.6.1 Call river routing to write restart files 
+          CALL routing_main (kjit, kjpindex, dtradia, control_in, ldrestart_read, ldrestart_write, index, &
+               & lalo, neighbours, resolution, contfrac, totfrac_nobio, veget_max, floodout, runoff, &
+               & drainage, transpot, precip_rain, humrel, k_litt, flood_frac, flood_res, &
+               & stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, &
+               & rest_id, hist_id, hist2_id)
+       ELSE
+          !! 3.6.2 No routing, set variables to zero
+          riverflow(:) = zero
+          coastalflow(:) = zero
+          reinfiltration(:) = zero
+          returnflow(:) = zero
+          irrigation(:) = zero
+          flood_frac(:) = zero
+          flood_res(:) = zero
+       ENDIF ! river_routing
+
+       !! 3.7 Call slowproc_main to add 'daily' and annual variables to restart file
+       CALL slowproc_main (kjit, kjpij, kjpindex, dtradia, date0, &
+            ldrestart_read, ldrestart_write, control_in%ok_co2, control_in%ok_stomate, index, &
+            indexveg, lalo, neighbours, resolution, contfrac, &
+            soiltile, reinf_slope, t2mdiag, t2mdiag, temp_sol, &
+            stempdiag, vegstress, shumdiag, litterhumdiag, precip_rain, &
+            precip_snow, gpp, deadleaf_cover, assim_param, lai, &
+            frac_age, height, veget, frac_nobio, njsc, &
+            veget_max, totfrac_nobio, qsintmax, rest_id, hist_id, &
+            hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC, co2_flux, &
+            fco2_lu, sinang, circ_class_biomass, circ_class_n, &
+            transpir, stressed, unstressed, transpir_supply, &
+            biomass, ind, lai_per_level, laieff_fit, &
+            vir_transpir_supply, temp_growth, Isotrop_Tran_Tot_p, &
+            sum_veget_diff,stem_plc,psi_stem, psi_leaf, psi_root)
+
+       ! Compute global CO2 flux 
+       !+++CHECK+++
+       ! If co2flux contains soil respiration the loop should include the bare soil
+       ! because after a land cover change PFT1 can contain litter and soil carbon
+       netco2flux(:) = zero
+       DO jv = 2,nvm
+          netco2flux(:) = netco2flux(:) + co2_flux(:,jv)*veget_max(:,jv)
+       ENDDO
+       !+++++++++++
+
+       !! 3.8 Add some remaining variables to the restart file
+       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 ! ldrestart_write 
+  
+   
+
+    IF (long_print) WRITE (numout,*) ' sechiba_main done '
+
+    ! WRITE(numout,*) '010114 end of sechiba_main, temp_atmos_pres_grid is: ', temp_atmos_pres_grid
+    
+    
+  END SUBROUTINE sechiba_main
+
+  
+!! ==============================================================================================================================\n
+!! SUBROUTINE 	: sechiba_init
+!!
+!>\BRIEF        Dynamic allocation of the variables, the dimensions of the 
+!! variables are determined by user-specified settings. If ::ldrestart_read is
+!! true, initial varaible values are read from the restart file.
+!! 
+!! DESCRIPTION  : The domain size (:: kjpindex) is used to allocate the correct
+!! dimensions to all variables in sechiba. Depending on the variable, its 
+!! dimensions are also determined by the number of PFT's (::nvm), number of 
+!! soil types (::nstm), number of non-vegetative surface types (::nnobio),
+!! number of soil levels (::ngrnd), number of soil layers in the hydrological 
+!! model (i.e. cwrr) (::nslm). Values for these variables are set in
+!! constantes_soil.f90 and constantes_veg.f90.\n
+!!
+!! Memory is allocated for all Sechiba variables and new indexing tables
+!! are build making use of both (::kjpij) and (::kjpindex). New indexing tables 
+!! are needed because a single pixel can contain several PFTs, soil types, etc.
+!! The new indexing tables have separate indices for the different
+!! PFTs, soil types, etc.\n
+!!
+!! The routine uses the flag ::ldrestart_read to retrieve initial variable 
+!! settings from the restart file.\n
+!!  
+!! ??Flags are getting swapped by it is not entirly clear why?? 
+!!
+!! RECENT CHANGE(S): None
+!! 
+!! MAIN OUTPUT VARIABLE(S): Strictly speaking the subroutine has no output 
+!! variables. However, the routine allocates memory and builds new indexing 
+!! variables for later use.
+!!
+!! REFERENCE(S)	: None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================ 
+
+  SUBROUTINE sechiba_init (kjit, ldrestart_read, kjpij, kjpindex, index, rest_id, control_in, lalo)
+
+!! 0.1 Input variables
+ 
+    INTEGER(i_std), INTENT (in)                         :: kjit               !! Time step number (unitless)
+    INTEGER(i_std), INTENT (in)                         :: kjpij              !! Total size of the un-compressed grid (unitless)
+    INTEGER(i_std), INTENT (in)                         :: kjpindex           !! Domain size - terrestrial pixels only (unitless)
+    INTEGER(i_std), INTENT (in)                         :: rest_id            !! _Restart_ file identifier (unitless)
+    TYPE(control_type), INTENT(in)                      :: control_in         !! Flags that (de)activate parts of the model
+    LOGICAL,INTENT (in)                                 :: ldrestart_read     !! Logical for restart file to read (true/false)
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)    :: index              !! Indeces of the points on the map (unitless)
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (in)     :: lalo               !! Geographical coordinates (latitude,longitude) 
+                                                                              !! for pixels (degrees)
+!! 0.2 Output variables
+
+!! 0.3 Modified variables
+
+!! 0.4 Local variables
+
+    INTEGER(i_std)                                      :: ier                !! Check errors in memory allocation (unitless)
+    INTEGER(i_std)                                      :: ji, jv, ilevel     !! Indeces (unitless)
+    INTEGER(i_std)                                      :: icir               !! Indeces (unitless)
+!_ ==============================================================================================================================
+
+!! 1. Initialize variables 
+    
+    ! Dynamic allocation with user-specified dimensions on first call
+    IF (l_first_sechiba) THEN 
+       l_first_sechiba=.FALSE.
+    ELSE 
+       WRITE (numout,*) ' l_first_sechiba false . we stop '
+       CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    ENDIF
+
+
+    !! 1.1 Initialize 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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (indexlai(kjpindex*(nlai+1)),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in indexlai allocation. We stop. We need kjpindex words = ',kjpindex*(nlai+1)
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (indexcan(kjpindex*nlevels_tot),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in indexcan allocation. We stop. We need kjpindex*nlevels_tot words = ',&
+            kjpindex*nlevels_tot
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+! tzjwb
+ ALLOCATE (indexnbdl(kjpindex*nbdl),stat=ier)
+     IF (ier /= 0) CALL ipslerr_p(3,'sechiba_init','Pb in alloc for indexnbdl','','')
+
+
+
+
+    !! 1.2  Initialize 1D array allocation with restartable value
+    IF (long_print) WRITE (numout,*) 'Allocation of 1D variables. We need for each kjpindex words = ',kjpindex
+    ALLOCATE (flood_res(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in flood_res allocation. We stop. We need kjpindex words = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    flood_res(:) = undef_sechiba
+
+    IF (long_print) WRITE (numout,*) 'Allocation of 1D variables. We need for each kjpindex words = ',kjpindex
+    ALLOCATE (flood_frac(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in flood_frac allocation. We stop. We need kjpindex words = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    flood_frac(:) = undef_sechiba
+
+    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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    vegstress(:,:) = undef_sechiba
+
+  !  ALLOCATE (laipix(kjpindex),stat=ier)
+  !  IF (ier.NE.0) THEN
+  !     WRITE (numout,*) ' error in laipix allocation. We stop. we need kjpindex words = ',kjpindex
+  !    CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+  !  END IF
+  !  laipix(:) = undef_sechiba
+
+  !  ALLOCATE (laieff_pix(kjpindex),stat=ier)
+  !  IF (ier.NE.0) THEN
+  !     WRITE (numout,*) ' error in laieff_pix allocation. We stop. We need kjpindex x nvm words = ',&
+  !          & kjpindex
+  !    CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+  !  END IF
+  !  laieff_pix(:) = zero
+
+    ALLOCATE (njsc(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in njsc allocation. We stop. we need kjpindex words = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    njsc(:)= undef_int
+
+    ALLOCATE (soiltile(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in soiltile allocation. We stop. we need kjpindex words = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    soiltile(:,:)=undef_sechiba
+
+    ALLOCATE (reinf_slope(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in reinf_slope allocation. We stop. we need kjpindex words = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    reinf_slope(:)=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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (vbeta5(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vbeta5 allocation. We stop. We need kjpindex words = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    qsurf(:) = undef_sechiba
+
+    !! 1.3 Initialize 2D 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 
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (vbeta3pot(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vbeta3pot allocation. We stop.We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (gsmean(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in gsmean allocation. We stop.We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    gpp(:,:) = undef_sechiba
+
+    ALLOCATE (temp_growth(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in temp_growth allocation. We stop.We need kjpindex words = ',&
+            & kjpindex,' = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    temp_growth(:) = 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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    lai(:,:)=undef_sechiba
+
+
+
+    ! Here I would rather declare a structure to pass around.  This way it's 
+    ! easier to change the function we fit this data to.
+    ALLOCATE (laieff_fit(kjpindex,nvm,nlevels_tot),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in laieff_fit allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',nlevels_tot*kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    CALL laieff_type_init(kjpindex, nlevels_tot, laieff_fit)
+    
+    ALLOCATE (frac_age(kjpindex,nvm,nleafages),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in frac_age allocation. We stop. We need kjpindex x nvm words = ',&
+             & kjpindex,' x ' ,nvm, 'x',nleafages,' = ',kjpindex*nvm*nleafages
+       CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    frac_age(:,:,:)=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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (albedo_pft(kjpindex,nvm,n_spectralbands),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in albedo_pft allocation. We stop. ' // &
+            'We need kjpindex*nvm*n_spectralbands = ',&
+            kjpindex*nvm*n_spectralbands
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    !! 1.4 Initialize 1D array allocation 
+    ALLOCATE (vevapflo(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vevapflo allocation. We stop. We need kjpindex words = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    vevapflo(:)=zero
+
+    ALLOCATE (vevapsno(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vevapsno allocation. We stop. We need kjpindex words = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (floodout(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in floodout allocation. We stop. We need kjpindex words = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    returnflow(:) = zero
+
+    ALLOCATE (reinfiltration(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in reinfiltration allocation. We stop. We need kjpindex words = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    reinfiltration(:) = zero
+
+    ALLOCATE (irrigation(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in irrigation allocation. We stop. We need kjpindex words = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (z0_veg(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in z0_veg allocation. We stop. We need kjpindex words = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    ! Initialize it here, otherwise it gets used somewhere before being
+    ! set.  I wasn't able to find where, though.
+    roughheight(:)=zero
+
+    ALLOCATE (emis(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in emis allocation. We stop. We need kjpindex words = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+! tzjwb
+    ALLOCATE (shumdiag_perma(kjpindex,nbdl),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'sechiba_init','Pb in alloc for shumdiag_perma','','')
+
+
+
+
+    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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (ptnlev1(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in ptnlev1 allocation. We stop. We need kjpindex words = ', kjpindex
+       CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (k_litt(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in k_litt allocation. We stop. We need kjpindex words = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    !! 1.5 Initialize 2D 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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    vevapwet(:,:)=undef_sechiba
+
+    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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (stressed(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in stressed allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    stressed(:,:) = zero
+
+     ALLOCATE (unstressed(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in unstressed allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    unstressed(:,:) = zero
+
+!!$    ALLOCATE (vir_transpir_mod(kjpindex,nvm),stat=ier)
+!!$    IF (ier.NE.0) THEN
+!!$       WRITE (numout,*) ' error in vir_transpir_mod allocation. We stop. We need kjpindex x nvm words = ',&
+!!$            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+!!$      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+!!$    END IF
+!!$    vir_transpir_mod(:,:) = zero 
+
+    ALLOCATE (transpir_supply(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in transpir_supply allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    transpir_supply(:,:) = zero
+
+! -----------------------------------------------------------------------------------------
+! hydraulic architecture tzjh
+
+    ALLOCATE (vl(kjpindex,nvm,ncirc),stat=ier)   
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vl allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    vl(:,:,:) = zero
+
+    ALLOCATE (vx(kjpindex,nvm,ncirc),stat=ier)   
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vx allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    vx(:,:,:) = zero
+
+    ALLOCATE (vr(kjpindex,nvm,ncirc),stat=ier)   
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vr allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    vr(:,:,:) = zero
+
+    ALLOCATE (psi_leaf(kjpindex,nvm,ncirc),stat=ier)   
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in psi_leaf  allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    psi_leaf(:,:,:) = zero
+
+    ALLOCATE (psi_stem(kjpindex,nvm,ncirc),stat=ier)   
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in psi_stem  allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    psi_stem(:,:,:) = zero
+
+    ALLOCATE (psi_root(kjpindex,nvm,ncirc),stat=ier)   
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in psi_root  allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    psi_root(:,:,:) = zero
+
+! added by Yitong Yao 06 Jan 2020 10:38
+    ALLOCATE (stem_plc(kjpindex,nvm,ncirc),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in stem_plc  allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    stem_plc(:,:,:) = zero
+! added bu yiTONG yAO 06 Jan 2020 above stem_plc
+
+! psi_stem is already allocated here 07 Jan 2020 11:13
+   
+   ! added by yitong yao 13 Jan 2020 18:21
+
+   ALLOCATE (transpir_tot(kjpindex,nvm),stat=ier)
+   IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in transpir_tot allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+   END IF
+   transpir_tot(:,:) = zero
+   ! added by yitong yao 13 Jan 2020 18:21 above lines
+
+   ALLOCATE (VPD_tzj(kjpindex),stat=ier)
+   IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in VPD_tzj allocation. We stop. We need kjpindex words = ',&
+            & kjpindex,' = ',kjpindex
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+   END IF
+   VPD_tzj(:) = zero
+
+   ALLOCATE (gsh(kjpindex,nvm,ncirc),stat=ier)
+   IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in gsh  allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+   END IF
+   gsh(:,:,:) = zero
+
+   ALLOCATE (tzj_supply(kjpindex,nvm,ncirc),stat=ier)
+   IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tzj_supply  allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+   END IF
+   tzj_supply(:,:,:) = zero
+
+
+
+
+! -----------------------------------------------------------------------------------------
+
+
+    ALLOCATE (vir_transpir_supply(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in transpir_supply allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    vir_transpir_supply(:,:) = zero
+
+    ALLOCATE (transpot(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in transpot allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+      CALL ipslerr_p (3,'sechiba','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 
+      CALL ipslerr_p (3,'sechiba','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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    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
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (warnings(kjpindex,nvm,nwarns),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in warnings allocation. We stop. We need kjpindex x nvm x nwarns words = ',&
+            & kjpindex,' x ' ,nvm, ' x ',nwarns,' = ',kjpindex*nvm*nwarns
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    ! We aren't restarting the warnings at the moment.
+    warnings(:,:,:)=zero
+
+
+    !! 1.? Initialize 3D array allocation
+    ALLOCATE (Isotrop_Abs_Tot_p(kjpindex,nvm,nlevels_tot),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in Isotrop_Abs_Tot_p allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' x ' , nlevels, ' = ',kjpindex*nvm*nlevels_tot
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    Isotrop_Abs_Tot_p(:,:,:)= zero
+
+    ALLOCATE (Isotrop_Tran_Tot_p(kjpindex,nvm,nlevels_tot),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in Isotrop_Tran_Tot_p allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' x ' , nlevels, ' = ',kjpindex*nvm*nlevels_tot
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+    Isotrop_Tran_Tot_p(:,:,:)= zero
+
+!tzjwb
+
+   ALLOCATE (pgflux(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'sechiba_init','Pb in alloc for pgflux','','')
+    pgflux(:)= 0.0
+
+    ALLOCATE (cgrnd_snow(kjpindex,nsnow),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'sechiba_init','Pb in alloc for cgrnd_snow','','')
+    cgrnd_snow(:,:) = 0
+
+    ALLOCATE (dgrnd_snow(kjpindex,nsnow),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'sechiba_init','Pb in alloc for dgrnd_snow','','')
+    dgrnd_snow(:,:) = 0
+
+    ALLOCATE (lambda_snow(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'sechiba_init','Pb in alloc for lambda_snow','','')
+    lambda_snow(:) = 0
+
+    ALLOCATE (temp_sol_add(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'sechiba_init','Pb in alloc for temp_sol_add','','')
+
+    ALLOCATE (gtemp(kjpindex),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'sechiba_init','Pb in alloc for gtemp','','')
+
+
+
+    ALLOCATE (mc_layh(kjpindex, nslm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'sechiba_init','Pb in alloc for mc_layh','','')
+
+    ALLOCATE (mcl_layh(kjpindex, nslm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'sechiba_init','Pb in alloc for mcl_layh','','')
+
+    ALLOCATE (tmc_layh(kjpindex, nslm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'sechiba_init','Pb in alloc for tmc_layh','','')
+
+
+
+    !! 1.6 Initialize 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, nlai+1
+          indexlai((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+       !
+       DO jv = 1, nvm
+          indexveg((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+       !      
+       DO jv = 1, nstm
+          indexsoil((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+       !      
+       DO jv = 1, nnobio
+          indexnobio((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+       !
+       DO jv = 1, ngrnd
+          indexgrnd((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+       !
+       DO jv = 1, nslm
+          indexlayer((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+       !
+       DO jv = 1, 2
+          indexalb((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+       !
+       DO jv = 1, nlevels_tot
+          indexcan((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+       !
+    ENDDO
+
+   !! 1.7 Initialize heights of the levels in the canopy
+    ALLOCATE(lai_split(1:nlevels),stat=ier)
+    IF (ier .NE. 0) THEN
+       WRITE (numout,*) ' error in lai_split allocation. We stop. We need nlevels words = ',nlevels
+       CALL ipslerr_p (3,'sechiba','config_sechiba_parameters','','')
+    ENDIF
+    IF(nlevels .GT. 1)THEN
+       !Config Key   = LAI_SPLIT
+       !Config Desc  = 
+       !Config If    = OK_SECHIBA
+       !Config Def   = 0.0
+       !Config Help  = 
+       !Config Units = [-]
+       lai_split(:)=zero
+       CALL getin_p('LAI_SPLIT',lai_split(:))
+
+       WRITE(numout,*) 'WARNING: Using a temporary value LAI_SPLIT'
+       WRITE(numout,*) '         There is no reason to use this until you are a developer!'
+    ELSE
+       lai_split(1)=zero
+    ENDIF
+
+    DO ilevel=1,nlevels
+       WRITE(numout,*) 'Albedo canopy level ',ilevel,' has a lower boundary at ',lai_split(ilevel),' meters.'
+    ENDDO
+
+    ! now we create and initialize some plant variables that need to be passed around sechiba and stomate
+    ALLOCATE(circ_class_n(kjpindex,nvm,ncirc),stat=ier)
+    IF (ier .NE. 0) THEN
+       WRITE(numout,*) 'Memory allocation error for circ_class_n. We stop. We need kjpindex*nvm*ncirc words', & 
+       &      kjpindex,nvm,ncirc
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    ENDIF
+    circ_class_n(:,:,:) = val_exp
+    
+    ALLOCATE(circ_class_biomass(kjpindex,nvm,ncirc,nparts,nelements),stat=ier)
+    IF (ier .NE. 0) THEN
+       WRITE(numout,*) 'Memory allocation error for circ_class_biomass.'
+       WRITE(numout,*) 'We stop. We need kjpindex*nvm*nparts*ncirc*nelmements words', & 
+       &      kjpindex,nvm,ncirc,nparts,nelements
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    ENDIF
+    circ_class_biomass(:,:,:,:,:) = val_exp
+
+
+    ALLOCATE(biomass(kjpindex,nvm,nparts,nelements),stat=ier)
+    IF (ier .NE. 0) THEN
+       WRITE(numout,*) 'Memory allocation error for biomass.'
+       WRITE(numout,*) 'We stop. We need kjpindex*nvm*nparts*nelmements words', & 
+       &      kjpindex,nvm,nparts,nelements
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    ENDIF
+    biomass(:,:,:,:) = val_exp
+
+    ALLOCATE(ind(kjpindex,nvm),stat=ier)
+    IF (ier .NE. 0) THEN
+       WRITE(numout,*) 'Memory allocation error for biomass.'
+       WRITE(numout,*) 'We stop. We need kjpindex*nvm words', & 
+       &      kjpindex,nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    ENDIF
+    ind(:,:) = val_exp
+
+
+    ALLOCATE(lai_per_level(kjpindex,nvm,nlevels_tot),stat=ier)
+    IF (ier .NE. 0) THEN
+       WRITE(numout,*) 'Memory allocation error for lai_per_level. We stop. ' //&
+            'We need kjpindex*nvm*nlevels_tot words', & 
+       &      kjpindex,nvm,nlevels_tot
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    ENDIF
+    lai_per_level(:,:,:)=val_exp
+
+    ALLOCATE(frac_snow_veg(kjpindex,nvm),stat=ier)
+    IF (ier .NE. 0) THEN
+       WRITE(numout,*) 'Memory allocation error for frac_snow_veg. We stop. ' //&
+            'We need kjpindex*nvm words', & 
+       &      kjpindex,nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    ENDIF
+    frac_snow_veg(:,:)=val_exp
+
+    ALLOCATE(frac_snow_nobio(kjpindex,nvm),stat=ier)
+    IF (ier .NE. 0) THEN
+       WRITE(numout,*) 'Memory allocation error for frac_snow_nobio. We stop. ' //&
+            'We need kjpindex*nvm words', & 
+       &      kjpindex,nvm
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    ENDIF
+    frac_snow_nobio(:,:)=val_exp
+
+    ALLOCATE(frac_snow_pix(kjpindex),stat=ier)
+    IF (ier .NE. 0) THEN
+       WRITE(numout,*) 'Memory allocation error for frac_snow_pix. We stop. ' //&
+            'We need kjpindex words', & 
+            &      kjpindex
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    ENDIF
+    frac_snow_pix(:)=val_exp
+
+    ! This is really just a debug vector.
+    ALLOCATE(sum_veget_diff(kjpindex),stat=ier)
+    IF (ier .NE. 0) THEN
+       WRITE(numout,*) 'Memory allocation error for sum_veget_diff. We stop. ' //&
+            'We need kjpindex words', & 
+            &      kjpindex
+      CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    ENDIF
+    sum_veget_diff(:)=val_exp
+
+
+    !multilayer allocations
+
+    ALLOCATE (flux_h_grid(kjpindex,jnlvls),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in flux_h_grid allocation. We stop. We need kjpindex words = ',jnlvls
+       CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (flux_le_grid(kjpindex,jnlvls),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in flux_le_grid allocation. We stop. We need kjpindex words = ',jnlvls
+       CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (temp_atmos_pres_grid(kjpindex,jnlvls),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in temp_atmos_pres_grid allocation. We stop. We need kjpindex words = ',jnlvls
+       CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (q_atmos_pres_grid(kjpindex,jnlvls),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in q_atmos_pres_grid allocation. We stop. We need kjpindex words = ',jnlvls
+       CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (temp_leaf_pres_grid(kjpindex,jnlvls),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in temp_leaf_pres_grid allocation. We stop. We need kjpindex words = ',jnlvls
+       CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (t_a_next_grid(kjpindex,jnlvls),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in t_a_next_grid allocation. We stop. We need kjpindex words = ',jnlvls
+       CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (q_a_next_grid(kjpindex,jnlvls),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in q_a_next_grid allocation. We stop. We need kjpindex words = ',jnlvls
+       CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+    END IF
+
+    ALLOCATE (swc(kjpindex,nslm,nstm))
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in swc allocation. We stop. We need kjpindex words = ',jnlvls
+       CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+   END IF
+
+   ALLOCATE (ksave(kjpindex,nslm,nstm))
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in ksave allocation. We stop. We need kjpindex words = ',jnlvls
+       CALL ipslerr_p (3,'sechiba','sechiba_init','','')
+
+    END IF
+
+
+!! 2. Read restart files to set initial variable values
+    
+    IF (ldrestart_read) THEN
+
+       IF (long_print) WRITE (numout,*) ' we have to read a restart file for SECHIBA variables'
+       ! Open restart file and read data
+       ! ?? Where is the code to open the restart file?? !!?? I guess, the IF just writes out the comment.
+       !!?? The single routines are called in sechiba_main. It would be more logical to put it in sechiba_main
+       ! Read the default value that will be put into variable which are not in the restart file
+       CALL ioget_expval(val_exp)
+
+    ENDIF
+
+!! 3. Swapping flags
+
+    !??What is going with the flags (also next section??). Why is this done?? Where are the values specified??
+    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%do_land_use = control_in%do_land_use
+    control%ok_pheno = control_in%ok_pheno
+    control%stomate_watchout = control_in%stomate_watchout
+    control%ok_functional_allocation = control_in%ok_functional_allocation
+    control%ok_constant_mortality = control_in%ok_constant_mortality
+    control%ok_herbivory = control_in%ok_herbivory
+    control%ok_constant_mortality = control_in%ok_constant_mortality
+    control%ok_cexchange = control_in%ok_cexchange
+    control%ok_inca = control_in%ok_inca                    
+    control%ok_leafage = control_in%ok_leafage         
+    control%ok_radcanopy = control_in%ok_radcanopy
+    control%ok_multilayer = control_in%ok_multilayer
+    control%ok_pulse_NOx = control_in%ok_pulse_NOx       
+    control%ok_bbgfertil_NOx = control_in%ok_bbgfertil_NOx     
+    control%ok_cropsfertil_NOx = control_in%ok_cropsfertil_NOx
+    control%forest_management = control_in%forest_management 
+    control%do_new_snow_albedo = control_in%do_new_snow_albedo
+    control%ok_hydrol_arch = control_in%ok_hydrol_arch
+    control%ok_nenerbil = control_in%ok_nenerbil
+    control%ok_gs_feedback = control_in%ok_gs_feedback
+    control%ok_dofoco = control_in%ok_dofoco
+    control%ok_recruitment = control_in%ok_recruitment
+    control%ok_daily_recruitment = control_in%ok_daily_recruitment
+
+
+ !tzjh
+
+       control%ok_joetzjer_hydro=control_in%ok_joetzjer_hydro
+
+    ! +++CHECK+++
+    ! The ok_land_use_change flag replace the old logical variable :lcchange
+    ! the use has not changed it is just more consistent to define all flags that
+    ! can alter the flow of the model in a control structure. 
+    control%ok_land_cover_change = control_in%ok_land_cover_change
+    ! The do_land_use flag is used in slow_proc.f90 but it looks like it should not
+    ! have been defined in this structure but simply as a local logical because
+    ! it is used to update the land use maps but it does not affect the flow of the 
+    ! code by itself as it is NOT set by the user
+    ! +++++++++++
+   IF (long_print) WRITE (numout,*) ' sechiba_init done '
+
+  END SUBROUTINE sechiba_init
+  
+
+!! ==============================================================================================================================\n
+!! SUBROUTINE 	: sechiba_clear
+!!
+!>\BRIEF        Deallocate memory of sechiba's variables
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): None 
+!!
+!! REFERENCE(S)	: None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================ 
+
+  SUBROUTINE sechiba_clear (forcing_name,cforcing_name)
+
+    CHARACTER(LEN=100), INTENT(in)           :: forcing_name       !! Name of forcing file (unitless)
+    CHARACTER(LEN=100), INTENT(in)           :: cforcing_name      !! Name of forcing file with carbon related variables (unitless)
+!_ ================================================================================================================================
+    
+!! 1. Initialize first run
+
+    l_first_sechiba=.TRUE.
+
+!! 2. Deallocate dynamic variables of sechiba
+
+    IF ( ALLOCATED (indexveg)) DEALLOCATE (indexveg)
+    IF ( ALLOCATED (indexlai)) DEALLOCATE (indexlai)
+    IF ( ALLOCATED (indexsoil)) DEALLOCATE (indexsoil)
+    IF ( ALLOCATED (indexnobio)) DEALLOCATE (indexnobio)
+    IF ( ALLOCATED (indexgrnd)) DEALLOCATE (indexgrnd)
+    IF ( ALLOCATED (indexlayer)) DEALLOCATE (indexlayer)
+    IF ( ALLOCATED (indexnbdl)) DEALLOCATE (indexnbdl)
+    IF ( ALLOCATED (indexalb)) DEALLOCATE (indexalb)
+    IF ( ALLOCATED (indexcan)) DEALLOCATE (indexcan)
+    IF ( ALLOCATED (flood_res)) DEALLOCATE (flood_res)
+    IF ( ALLOCATED (flood_frac)) DEALLOCATE (flood_frac)
+    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 (soiltile)) DEALLOCATE (soiltile)
+    IF ( ALLOCATED (njsc)) DEALLOCATE (njsc)
+    IF ( ALLOCATED (reinf_slope)) DEALLOCATE (reinf_slope)
+    IF ( ALLOCATED (vbeta1)) DEALLOCATE (vbeta1)
+    IF ( ALLOCATED (vbeta4)) DEALLOCATE (vbeta4)
+    IF ( ALLOCATED (vbeta5)) DEALLOCATE (vbeta5)
+    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 (vbeta3pot)) DEALLOCATE (vbeta3pot)
+    IF ( ALLOCATED (gsmean)) DEALLOCATE (gsmean)
+!    IF ( ALLOCATED (vbetaco2)) DEALLOCATE (vbetaco2)
+    IF ( ALLOCATED (cimean)) DEALLOCATE (cimean)
+    IF ( ALLOCATED (gpp)) DEALLOCATE (gpp)
+    IF ( ALLOCATED (temp_growth)) DEALLOCATE (temp_growth)
+    IF ( ALLOCATED (veget)) DEALLOCATE (veget)
+    IF ( ALLOCATED (veget_max)) DEALLOCATE (veget_max)
+    IF ( ALLOCATED (lai)) DEALLOCATE (lai)
+    IF ( ALLOCATED (laieff_fit)) DEALLOCATE (laieff_fit)
+    IF ( ALLOCATED (frac_age)) DEALLOCATE (frac_age)
+    IF ( ALLOCATED (height)) DEALLOCATE (height)
+    IF ( ALLOCATED (roughheight)) DEALLOCATE (roughheight)
+    IF ( ALLOCATED (z0_veg)) DEALLOCATE (z0_veg)
+    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 (vevapflo)) DEALLOCATE (vevapflo)
+    IF ( ALLOCATED (vevapsno)) DEALLOCATE (vevapsno)
+    IF ( ALLOCATED (vevapnu)) DEALLOCATE (vevapnu)
+    IF ( ALLOCATED (t2mdiag)) DEALLOCATE (t2mdiag)
+    IF ( ALLOCATED (totfrac_nobio)) DEALLOCATE (totfrac_nobio)
+    IF ( ALLOCATED (floodout)) DEALLOCATE (floodout)
+    IF ( ALLOCATED (runoff)) DEALLOCATE (runoff)
+    IF ( ALLOCATED (drainage)) DEALLOCATE (drainage)
+    IF ( ALLOCATED (reinfiltration)) DEALLOCATE (reinfiltration)
+    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 (shumdiag_perma)) DEALLOCATE (shumdiag_perma)
+
+    IF ( ALLOCATED (litterhumdiag)) DEALLOCATE (litterhumdiag)
+    IF ( ALLOCATED (ptnlev1)) DEALLOCATE (ptnlev1)
+    IF ( ALLOCATED (k_litt)) DEALLOCATE (k_litt)
+    IF ( ALLOCATED (vevapwet)) DEALLOCATE (vevapwet)
+    IF ( ALLOCATED (transpir)) DEALLOCATE (transpir)
+
+IF ( ALLOCATED (cgrnd_snow)) DEALLOCATE (cgrnd_snow)
+    IF ( ALLOCATED (dgrnd_snow)) DEALLOCATE (dgrnd_snow)
+    IF ( ALLOCATED (lambda_snow)) DEALLOCATE(lambda_snow)
+    IF ( ALLOCATED (gtemp)) DEALLOCATE (gtemp)
+    IF ( ALLOCATED (pgflux)) DEALLOCATE (pgflux)
+    IF ( ALLOCATED (mc_layh)) DEALLOCATE (mc_layh)
+    IF ( ALLOCATED (mcl_layh)) DEALLOCATE (mcl_layh)
+    IF ( ALLOCATED (tmc_layh)) DEALLOCATE (tmc_layh)
+!-----------------------------------------------------------------tzjh hydro
+    IF ( ALLOCATED (vl)) DEALLOCATE (vl)
+    IF ( ALLOCATED (vx)) DEALLOCATE (vx)
+    IF ( ALLOCATED (vr)) DEALLOCATE (vr)
+    
+    IF ( ALLOCATED (psi_leaf)) DEALLOCATE (psi_leaf)
+    IF ( ALLOCATED (psi_stem)) DEALLOCATE (psi_stem)
+    IF ( ALLOCATED (psi_root)) DEALLOCATE (psi_root)
+    IF ( ALLOCATED (stem_plc)) DEALLOCATE (stem_plc)
+    IF ( ALLOCATED (transpir_tot)) DEALLOCATE (transpir_tot)
+    IF ( ALLOCATED (VPD_tzj)) DEALLOCATE (VPD_tzj)
+    IF ( ALLOCATED (gsh)) DEALLOCATE (gsh)
+    IF ( ALLOCATED (tzj_supply)) DEALLOCATE (tzj_supply)
+!-----------------------------------------------------------------tzjh hydro
+
+
+    IF ( ALLOCATED (stressed)) DEALLOCATE (stressed)
+    IF ( ALLOCATED (unstressed)) DEALLOCATE (unstressed)
+!!$    IF ( ALLOCATED (vir_transpir_mod)) DEALLOCATE (vir_transpir_mod)
+    IF ( ALLOCATED (transpir_supply)) DEALLOCATE (transpir_supply)
+    IF ( ALLOCATED (vir_transpir_supply)) DEALLOCATE (vir_transpir_supply)
+    IF ( ALLOCATED (transpot)) DEALLOCATE (transpot)
+    IF ( ALLOCATED (qsintmax)) DEALLOCATE (qsintmax)
+    IF ( ALLOCATED (rveget)) DEALLOCATE (rveget)
+    IF ( ALLOCATED (rstruct)) DEALLOCATE (rstruct)
+    IF ( ALLOCATED (warnings)) DEALLOCATE (warnings)
+    IF ( ALLOCATED (lai_split)) DEALLOCATE (lai_split)
+    IF (ALLOCATED(lai_per_level)) DEALLOCATE(lai_per_level)
+    IF (ALLOCATED(circ_class_n)) DEALLOCATE(circ_class_n)
+    IF (ALLOCATED(circ_class_biomass)) DEALLOCATE(circ_class_biomass)
+    IF (ALLOCATED(biomass)) DEALLOCATE(biomass)
+    IF (ALLOCATED(ind)) DEALLOCATE(ind) 
+    IF (ALLOCATED(Isotrop_Abs_Tot_p)) DEALLOCATE(Isotrop_Abs_Tot_p)
+    IF (ALLOCATED(frac_snow_veg)) DEALLOCATE(frac_snow_veg)
+    IF (ALLOCATED(frac_snow_nobio)) DEALLOCATE(frac_snow_nobio)
+    IF (ALLOCATED(frac_snow_pix)) DEALLOCATE(frac_snow_pix)
+    IF (ALLOCATED(sum_veget_diff)) DEALLOCATE(sum_veget_diff)
+
+    IF (ALLOCATED(flux_h_grid)) DEALLOCATE(flux_h_grid)
+    IF (ALLOCATED(flux_le_grid)) DEALLOCATE(flux_le_grid)
+    IF (ALLOCATED(t_a_next_grid)) DEALLOCATE(t_a_next_grid)
+    IF (ALLOCATED(q_a_next_grid)) DEALLOCATE(q_a_next_grid)
+    IF (ALLOCATED(temp_atmos_pres_grid)) DEALLOCATE(temp_atmos_pres_grid)
+    IF (ALLOCATED(q_atmos_pres_grid)) DEALLOCATE(q_atmos_pres_grid)
+    IF (ALLOCATED(temp_leaf_pres_grid)) DEALLOCATE(temp_leaf_pres_grid)
+    IF (ALLOCATED(swc)) DEALLOCATE(swc)
+    IF (ALLOCATED(ksave)) DEALLOCATE(ksave)
+    IF (ALLOCATED(albedo_pft)) DEALLOCATE(albedo_pft)
+
+!! 3. Clear all allocated memory
+
+    CALL pft_parameters_clear
+    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
+
+  END SUBROUTINE sechiba_clear
+
+
+!! ==============================================================================================================================\n
+!! SUBROUTINE 	: sechiba_var_init
+!!
+!>\BRIEF        Calculate air density as a function of air temperature and 
+!! pressure for each terrestrial pixel.
+!! 
+!! RECENT CHANGE(S): None
+!! 
+!! MAIN OUTPUT VARIABLE(S): air density (::rau, kg m^{-3}).
+!! 
+!! REFERENCE(S)	: None
+!! 
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE sechiba_var_init (kjpindex, rau, pb, temp_air) 
+
+!! 0.1 Input variables
+
+    INTEGER(i_std), INTENT (in)                    :: kjpindex        !! Domain size - terrestrial pixels only (unitless)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)  :: pb              !! Lowest level pressure (hPa)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)  :: temp_air        !! Air temperature (K)
+    
+!! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: rau             !! Air density @tex $(kg m^{-3})$ @endtex
+
+!! 0.3 Modified variables
+
+!! 0.4 Local variables
+
+    INTEGER(i_std)                                 :: ji              !! Indices (unitless)
+!_ ================================================================================================================================
+    
+!! 1. Calculate intial air density (::rau)
+   
+    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
+
+
+!! ==============================================================================================================================\n
+!! SUBROUTINE 	: sechiba_end
+!!
+!>\BRIEF        Swap old for newly calculated soil temperature.
+!! 
+!! RECENT CHANGE(S): None
+!! 
+!! MAIN OUTPUT VARIABLE(S): soil temperature (::temp_sol; K)
+!! 
+!! REFERENCE(S)	: None
+!! 
+!! FLOWCHART    : None
+!! \n
+!! ================================================================================================================================ 
+
+  SUBROUTINE sechiba_end (kjpindex, dtradia, temp_sol, temp_sol_new)
+
+!! 0.1 Input variables
+
+    INTEGER(i_std), INTENT (in)                       :: kjpindex           !! Domain size - terrestrial pixels only (unitless)
+    REAL(r_std),INTENT (in)                           :: dtradia            !! Time step (seconds)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)     :: temp_sol_new       !! New soil temperature (K)
+    
+!! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)    :: temp_sol           !! Soil temperature (K)
+
+!! 0.3 Modified variables
+
+!! 0.4 Local variables
+
+!_ ================================================================================================================================
+    
+!! 1. Swap temperature
+
+    temp_sol(:) = temp_sol_new(:)
+
+    IF (long_print) WRITE (numout,*) ' sechiba_end done '
+
+  END SUBROUTINE sechiba_end
+
+END MODULE sechiba
Index: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/sechiba_hydrol_arch.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/sechiba_hydrol_arch.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/sechiba_hydrol_arch.f90	(revision 7236)
@@ -0,0 +1,4040 @@
+!==================================================================================================================================
+!  MODULE 	: sechiba_hydrol_arch
+! 
+!  CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+!  LICENCE      : IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF This module calculates the amount of water that is available for the leaves for transpiration,
+!        accounting for effects of hydraulic architecture following (Hickler et al. 2006)      
+!!
+!!\n DESCRIPTION  : (1) Calculate soil water potential from soil water content as calculated in hydrol.f90
+!!                  according to van Genuchten (1980). Soil water potential is weighted by the relative share of the
+!!                  of theroots in each layer.
+!!                  (2) Calculate pressure difference between leaves and soil (Whitehead 1998)
+!!                  (3) Calculate root (Weatherly 1998), sapwood (Magnani et al. 2000, Tyree et al. 1994,
+!!                  Sperry et al. 1998) and leave resistances (Sitch et al. 2003.
+!!                  (4) Calculate the supply of water for transpiration by the leaves using Darcy's law (Whitehead 1998)
+!! 
+!! RECENT CHANGE(S): None 
+!! 
+!! REFERENCE(S) : None
+!!   
+!! SVN     :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_sechiba/sechiba.f90 $ 
+!! $Date: 2013-05-06 14:14:36 +0200 (Mon, 06 May 2013) $
+!! $Revision: 1295 $
+!! \n
+!_ ================================================================================================================================
+ 
+MODULE sechiba_hydrol_arch
+ 
+  USE ioipsl
+  
+  ! modules used :
+  USE ioipsl   
+  USE xios_orchidee
+  USE ioipsl_para 
+  USE constantes
+  USE constantes_soil
+  USE pft_parameters
+ ! USE function_library, ONLY: wood_to_height_eff, biomass_to_lai, biomass_to_coupled_lai, stem_volume_f
+  USE function_library ! load all for now
+  USE qsat_moisture
+
+  IMPLICIT NONE
+
+  ! Private and public routines
+
+  PRIVATE
+  PUBLIC hydrol_arch, jdiffuco_trans_co2
+
+
+  LOGICAL, SAVE                              :: l_first_sechiba = .TRUE.      !! Flag controlling the intialisation (true/false)
+!$OMP THREADPRIVATE(l_first_sechiba)
+
+  INTEGER(i_std)                             :: jst          ! tzj
+
+  LOGICAL, SAVE                              :: l_first_inih = .TRUE.      !! Flag controlling the intialisation of hydrolarch  (true/false)
+!$OMP THREADPRIVATE(l_first_inih)
+
+  LOGICAL, SAVE                              :: rsoilroot = .TRUE.         !! tzjh Flag to activate/deactivate dynamic roots scheme (true/false) 
+!$OMP THREADPRIVATE(rsoilroot)
+  LOGICAL, SAVE                               :: ok_joetzjer_hydro=.TRUE. 
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: hydrol_arch
+!!
+!>\BRIEF        Calculate the amount of water that is available for the leaves for transpiration,
+!               accounting for effects of hydraulic architecture following (Hickler et al. 2006)    
+!!
+!!\n DESCRIPTION : (1) Calculate soil water potential from soil water content as calculated in hydrol.f90 
+!!   according to van Genuchten (1980). Soil water potential is weighted by the relative share of the
+!!   roots in each layer.
+!!   (2) Calculate pressure difference between leaves and soil (Whitehead 1998)
+!!   (3) Calculate root (Weatherly 1998), sapwood (Magnani et al. 2000, Tyree et al. 1994, Sperry et al. 1998)
+!!   and leave resistances (Sitch et al. 2003).
+!!   (4) Calculate the supply of water for transpiration by the leaves using Darcy's law (Whitehead 1998)
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): :: transpir_supply   
+!!
+!! REFERENCE(S)	: +++COMPLETE+++
+!!                Hickler et al. 2006
+!!                van Genuchten (1980)
+!!                Whitehead 1998
+!!                Weatherly 1998
+!!                Magnani et al. 2000
+!!                Tyree et al. 1994
+!!                Sperry et al. 1998
+!!                Sitch et al. 2003
+!!
+!! FLOWCHART    : 
+!!
+!! tzj modif
+!! -   correction du calcul de R_sap following Magnani et al. 2000
+!! -   ecriture des variables phi_soil et phi_soilroot dans les outputs de sechiba
+!! -   implementation de rsoilroot avec flag (idem dans hydrol.f90)
+!! -   new hydraulic architecture is implemented but NOT activate (commented for now)
+!_ ================================================================================================================================
+! tzj add arguments, tzjhrestart ldrestart
+  SUBROUTINE hydrol_arch (kjpindex,rest_id, ldrestart_read, ldrestart_write, circ_class_biomass, circ_class_n, temp_sol_new, &
+       temp_air, swc, transpir_supply, dtradia, njsc, biomass, ind, soiltile, &
+       vir_transpir_supply, veget, kjit, indexveg, hist_id, indexlayer,qsurf, pb, vl, vx, vr, &
+       psi_leaf, psi_stem, psi_root,swdown, ksave,stem_plc,transpir_tot,VPD_tzj,gsh,tzj_supply) 
+
+
+    !! 0. Variable declaration
+
+    !! 0.1 Input variables
+    INTEGER(i_std),INTENT (in)                               :: rest_id
+    INTEGER(i_std), INTENT(in)                      :: kjit                !! tzj : Time step number (unitless)
+    INTEGER(i_std), INTENT(in)                      :: kjpindex            !! Domain size - terrestrial pixels only (unitless)
+    INTEGER(i_std),DIMENSION(kjpindex*nvm), INTENT(in)   :: indexveg       !! tzj : Indeces of the points on the 3D map
+    INTEGER(i_std),INTENT(in)                       :: hist_id             !! tzj : Access to history file(unitless)
+    INTEGER(i_std),DIMENSION (kjpindex*nslm), INTENT (in):: indexlayer     !! tzj : Indeces of the points on the 3D map for soil layers
+    CHARACTER(LEN=80) , SAVE                        :: var_name            !! tzj : To store variables names for I/O
+
+!tzjhrestart
+   LOGICAL, INTENT(in)                              :: ldrestart_read   !!  Logical for _restart_ file to read
+   LOGICAL, INTENT(in)                              :: ldrestart_write  !! Logical for _restart_ file to write
+
+    REAL(r_std), INTENT (in)                        :: dtradia             !! Time step (s) 
+    INTEGER(i_std), DIMENSION(:), INTENT (in)       :: njsc                !! Index of the dominant soil textural class 
+                                                                           !! in the grid cell used for hydrology 
+                                                                           !! (1-nscm, unitless)
+    REAL(r_std),DIMENSION (:), INTENT (in)          :: temp_sol_new        !! New ground temperature (K)
+    REAL(r_std),DIMENSION (:), INTENT (in)          :: temp_air            !! Air temperature (K)   
+    REAL(r_std),DIMENSION (:,:), INTENT (in)        :: ind                 !! Number of individuals at the stand level
+                                                                           !! @tex $(m^{-2})$ @endtex
+    REAL(r_std),DIMENSION (:,:), INTENT (in)        :: soiltile            !! Fraction of each soiltile (-)
+    REAL(r_std),DIMENSION (:,:,:), INTENT (in)      :: swc                 !! Volumetric soil water content
+    REAL(r_std),DIMENSION (:,:,:), INTENT (in)      :: ksave               !! Hydraulic conductivity mm/d (copy from hydrol.f90)
+    REAL(r_std),DIMENSION (:,:,:), INTENT (in)      :: circ_class_n        !! number of trees within a circumference class (tree m-2)
+    REAL(r_std), DIMENSION(:,:,:,:,:),  INTENT(in)  :: circ_class_biomass  !! Biomass components of the model tree  
+                                                                           !! within a circumference class
+                                                                           !! class @tex $(g C ind^{-1})$ @endtex  
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(in)     :: biomass             !! PFT total biomass 
+                                                                           !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std),DIMENSION (:,:), INTENT (in)        :: veget               !! Fraction of the vegetation that covers the soil
+                                                                           !! also project canopy cover - calculated by Pgap
+    REAL(r_std),DIMENSION (:), INTENT (in)          :: pb             !! tzjh Lowest level pressure (hPa)
+    REAL(r_std),DIMENSION (:), INTENT (in)          :: swdown         !! tzjh short wave down
+    REAL(r_std),DIMENSION (:), INTENT (in)          :: qsurf          !! tzjh  Near surface specific humidity !! @tex ($kg kg^{-1}$) @endtex 
+  
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(:,:), INTENT (out)       :: transpir_supply     !! Supply of water for transpiration 
+                                                                           !! @tex $(mm dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(out)        :: vir_transpir_supply !! Supply of water for transpiration 
+                                                                           !! @tex $(mm dt^{-1})$ @endtex
+
+    !! 0.3 Modified variables
+
+   REAL(r_std), DIMENSION(:,:,:),INTENT(inout)      :: vx     !! Vegetation height per circ_class_biomass (m)
+   REAL(r_std), DIMENSION(:,:,:),INTENT(inout)      :: vr     !! Vegetation height per circ_class_biomass (m)
+   REAL(r_std), DIMENSION(:,:,:),INTENT(inout)      :: vl     !! Vegetation height per circ_class_biomass (m)
+ 
+   REAL(r_std), DIMENSION(:,:,:),INTENT(inout)      :: psi_leaf     !! Vegetation height per circ_class_biomass (m)
+   REAL(r_std), DIMENSION(:,:,:),INTENT(inout)      :: psi_stem     !! Vegetation height per circ_class_biomass (m)
+   REAL(r_std), DIMENSION(:,:,:),INTENT(inout)      :: psi_root     !! Vegetation height per circ_class_biomass (m)
+
+ 
+   !! 0.4 Local variables
+
+   INTEGER(i_std)                                  :: ipts,ivm,icirc      !! indices
+   INTEGER(i_std)                                  :: ibdl,istm           !! indices
+   INTEGER(i_std)                                  :: tmp_ncirc           !! indices
+   
+    
+    REAL(r_std)                                     :: R_root              !! Hydraulic resistance of the roots
+    REAL(r_std)                                     :: R_leaf              !! Hydraulic resistance of the leaves
+    REAL(r_std)                                     :: R_sap               !! Hydraulic resistance of sapwood 
+    REAL(r_std)                                     :: R_shoot             !! Hydraulic resistance of shoot corrected for temperature
+    REAL(r_std), DIMENSION(ncirc)                   :: height              !! Vegetation height per circ_class_biomass (m)
+    REAL(r_std), DIMENSION(kjpindex,nbdl,nstm)      :: phi_soil            !! Soil water potential per soil layer per soiltile higher 
+                                                                           !! than -5 MPa (threshold for hygroscopic water) (MPa)
+  
+    REAL(r_std), DIMENSION(kjpindex,nbdl,nstm)      :: e_frac            !! fraction of water transpired by layers no units
+    REAL(r_std), DIMENSION(kjpindex,nbdl,nstm)      :: e_max             !! maximum amoount of available water for transpiration per layer mmol m2 s-1 
+
+    REAL(r_std), DIMENSION(kjpindex,nbdl,nstm)      :: res_soil          !! Soil water resistance per layers
+    REAL(r_std), DIMENSION(kjpindex,nbdl,nstm)      :: ksaveUNIT         !! Hydraulic conductivity (from hydrol.90)
+
+    REAL(r_std), DIMENSION(nbdl)                   :: lr     !! root length per unit of soil volume
+    REAL(r_std), DIMENSION(nbdl)                   :: rs     !! mean distance between roots (m) 
+
+    REAL(r_std), DIMENSION(ncirc)                   :: circ_class_transpir_supply     !! @tex $(m^{3}s^{-1}tree^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                   :: vir_circ_class_transpir_supply !! @tex $(m^{3}s^{-1}tree^{-1})$ @endtex
+    REAL(r_std)                                     :: delta_P             !! Pressure difference between leaves and soil
+    REAL(r_std)                                     :: vir_delta_P         !! Virtual pressure difference between leaves and soil
+
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)    :: z_soil             !! Soil levels (m) - dimension nbdl+1
+    !$OMP THREADPRIVATE(z_soil)
+
+    INTEGER(i_std)                                  :: ier                 !! Error handling
+    REAL(r_std), DIMENSION(nvm)                     :: k_sap_cav           !! sapwood conductivity decreased by cavitation
+    REAL(r_std), DIMENSION(nbdl,nvm)                :: root_dens           !! root density per layer
+    REAL(r_std), DIMENSION(nvm)                     :: rpc                 !! scaling factor for integral
+    REAL(r_std),DIMENSION(kjpindex,nbdl,nstm)       :: phi_soiltile        !! soil water potentential per soil layer per soil tile 
+    REAL(r_std),DIMENSION (kjpindex,nbdl,nstm)      :: swc_adj             !! Volumetric soil water content, adjusted when it is lower 
+                                                                           !! than or equal to the residual soil water content
+    REAL(r_std),DIMENSION(kjpindex,nvm)             :: phi_soilroot        !! Sum of soil water potential in each soil layer weighted 
+                                                                           !! by the share of the roots in each layer (MPa)
+    REAL(r_std),DIMENSION(kjpindex,nvm)             :: vir_phi_soilroot    !! Virtual transpir supply to be used in land cover change
+                                                                           !! Sum of soil water potential in each soil layer weighted 
+   ! Compute VPD 
+   REAL(r_std), DIMENSION(kjpindex)      :: VPD                            !! Vapor Pressure Deficit (kPa)
+   REAL(r_std), DIMENSION(kjpindex)      :: light                          !! 
+   REAL(r_std), DIMENSION(kjpindex)      :: qsatt                          !! surface saturated humidity at 2m (??)
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc) :: phi_soilroot_circ
+!!!
+!-----------------------------------------------------------------------------------------------------------
+!-----------------------------------------------------------------------------------------------------------
+!!! declaration for the new hydraulic architecture scheme - code commented for now
+   ! Hydraulic potentials of each organ (Mpa)
+   REAL(r_std), DIMENSION(ncirc)      :: new_psi_leaf     !!    
+   REAL(r_std), DIMENSION(ncirc)      :: new_psi_stem     !!
+   REAL(r_std), DIMENSION(ncirc)      :: new_psi_root     !! 
+
+   REAL(r_std), DIMENSION(:,:,:),INTENT(inout)                   :: gsh   !!
+   REAL(r_std), DIMENSION(:,:,:),INTENT(inout)                  :: tzj_supply
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc)                   :: Et    !!
+
+   !Hydraulic conductivities (mmol m-2 s-1 MPa-1)
+   REAL(r_std), DIMENSION(ncirc)      :: kleaf     !! 
+   REAL(r_std), DIMENSION(ncirc)      :: kstem     !!
+   REAL(r_std), DIMENSION(ncirc)      :: kroot     !!
+   REAL(r_std), DIMENSION(ncirc)      :: ktrunk    !!
+   REAL(r_std), DIMENSION(ncirc)      :: kupper    !!
+   
+ 
+   ! Water storage
+   REAL(r_std), DIMENSION(ncirc)     :: vdot_leaf     !! 
+   REAL(r_std), DIMENSION(ncirc)     :: vdot_xylem    !! 
+   REAL(r_std), DIMENSION(ncirc)     :: vdot_root     !! 
+
+   REAL(r_std), DIMENSION(ncirc)                   :: vxmax              !! 
+   REAL(r_std), DIMENSION(ncirc)                   :: vrmax              !!
+   REAL(r_std), DIMENSION(ncirc)                   :: vmax_l             !!
+
+   REAL(r_std), DIMENSION(ncirc)                   :: new_vl             !!
+   REAL(r_std), DIMENSION(ncirc)                   :: new_vx             !!
+   REAL(r_std), DIMENSION(ncirc)                   :: new_vr             !!
+
+
+!! Rate of changes from soil and storage : to simplify  
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc) :: vdot_storage_leaf
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc) :: vdot_hydr_leaf
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc) :: vdot_hydr_stem
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc) :: vdot_storage_stem
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc) :: vdot_storage_root
+
+   ! for output vertical water flow
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc) :: vdot_hydr_leaf_vert
+
+   !
+
+! Environmental variables
+
+   REAL(r_std), DIMENSION(nvm)                   :: psi_soil    !! hydrolic protential of the soil (use for hydrol-arch)
+   REAL :: limit                                                !! optimization
+   REAL :: diff                                                 !! optimization
+   REAL :: timestep                                             !! link to ORCHIDEE now set a 1800
+   REAL*8 ::  mm                                                !! need a double precision (sinon loop dans le vide) 
+   REAL :: atm  
+
+! Structural variables
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc)     :: stem_volume                      !! sapwood conductivity decreased by cavitation
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc)     :: root_volume                      !! sapwood conductivity decreased by cavitation
+   REAL(r_std), DIMENSION(ncirc)     :: dbh                !! Vegetation height per circ_class_biomass (m)
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc)     :: canopy_leaf_area   !! Vegetation height per circ_class_biomass (m)
+   REAL(r_std), DIMENSION(ncirc)     :: grav_potential     !! Vegetation height per circ_class_biomass (m)
+  
+   REAL(r_std), DIMENSION(ncirc)     :: transpir_class    !! Vegetation height per circ_class_biomass (m)
+   REAL(r_std)                       :: tmp    !! useful
+
+   REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(out)       :: transpir_tot    !! Vegetation height per circ_class_biomass (m)
+   REAL(r_std), DIMENSION(kjpindex),INTENT(out)          :: VPD_tzj   
+
+   REAL(r_std), DIMENSION(ncirc)                   :: tmp2    !! Vegetation height per circ_class_biomass (m)
+!  
+   REAL ::  klight            ! light curve parameter
+   REAL, PARAMETER ::  zero =0.0             ! maximum vapor pressure deficit, kPa
+   REAL ::  rr             ! maximum vapor pressure deficit, kPa
+   REAL ::  srl             ! maximum vapor pressure deficit, kPa
+
+   REAL(r_std), DIMENSION(:,:,:), INTENT (inout)                :: stem_plc    !! Vegetation height per circ_class_biomass (m)
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc)                   :: optileaf    !! Vegetation height per circ_class_biomass (m)
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc)                   :: optistem    !! Vegetation height per circ_class_biomass (m)
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc)                   :: optiroot    !! Vegetation height per circ_class_biomass (m)
+
+   
+
+
+   INTEGER :: M,N,INFO
+   REAL(r_std) :: FNORM
+   REAL(r_std) :: ENORM !,DPMPAR
+   REAL(r_std),ALLOCATABLE,DIMENSION(:) :: X,FVEC,PARS
+   REAL(r_std)    :: inew_psi_leaf, inew_psi_stem,inew_psi_root, &
+                     ikmax_leaf, iP50_leaf, ia_leaf, ikstem, &
+                     icl, ipsi_leaf, ipsi_stem, igrav_potential, &
+                     igsh, iVPD, icanopy_leaf_area, &
+                     ikmax_stem, iP50_stem, ia_stem, &
+                     ikroot, icxyl, istem_volume, &
+                     ikmax_root, iP50_root, ia_root, &
+                     icr, ipsi_root, iroot_volume, ivl, &
+                     iEt, ikupper, ivdot_storage_leaf, ivdot_hydr_leaf, &
+                     iktrunk, ivdot_storage_stem, ivdot_hydr_stem, &
+                     inew_kroot, ivdot_storage_root, ivdot_hydr_root,&
+                     ipsi_soil, &
+                     inew_kstem
+         LOGICAL, ALLOCATABLE, SAVE                 :: iniok(:,:,:)     !!Vegetation
+!  height per circ_class_biomass (m)
+!        IF (.NOT. ALLOCATED(iniok)) ALLOCATE(iniok(kjpindex,nvm,ncirc))
+!-----------------------------------------------------------------------------------------------------------
+!-----------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=10)                                      :: part_str 
+  REAL(r_std), DIMENSION(kjpindex,nvm)                   :: biomass_root    !! Roots biomass
+
+  ! Values per soil type
+  REAL(r_std)    :: tnvan                !! Van Genuchten coeficients n (unitless) ! 1/n=1-m
+  REAL(r_std)   :: tavan                !! Van Genuchten coeficients a
+  REAL(r_std)   :: tmcr                 !! Residual volumetric water content
+  REAL(r_std)   :: tmcs                 !! Saturated volumetric water content
+  REAL(r_std)   :: tks                 !! Saturated volumetric water content
+
+!  ! one dimension array allocated, computed, saved and got in hydrol module
+  ! Values per soil type
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: nvan                !! Van Genuchten coeficients n (unitless) ! RK:
+!$OMP THREADPRIVATE(nvan)                                                 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: avan                !! Van Genuchten coeficients a!@tex!$(mm^{-1})$!@endtex
+!$OMP THREADPRIVATE(avan)                                                
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: mcr                 !! Residual volumetric water content !! !@tex !$(m^{3} !m^{-3})$!@endtex
+!$OMP THREADPRIVATE(mcr)                                                 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: mcs                 !!Saturated volumetric water content !@tex !$(m^{3} !m^{-3})$!@endtex
+!$OMP THREADPRIVATE(mcs)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: ks !!Saturated volumetric water content
+!$OMP THREADPRIVATE(ks)
+  REAL(r_std)  :: which_layers
+  IF (.NOT. ALLOCATED(iniok)) ALLOCATE(iniok(kjpindex,nvm,ncirc))
+
+   IF (.NOT. ALLOCATED(z_soil)) THEN  
+       ALLOCATE(z_soil(nbdl+1), stat=ier)
+       IF ( ier /= 0 ) CALL ipslerr_p(3,'sechibaHA','Pb in allocate of z_soil','','')
+       z_soil(1)= 0.
+       z_soil(2:nbdl+1) = diaglev(1:nbdl)
+   ENDIF
+!_ =================================================================================================================================
+
+        !write(numout,*) "phi_soilroot is initialized"
+
+        phi_soilroot=zero    
+        stem_plc = zero
+        optileaf = zero
+        optistem = zero
+        optiroot = zero
+        e_frac = zero
+        e_max=zero
+        phi_soilroot_circ=zero
+    ! Set Transpir_supply to a value that is definitely larger than transpir
+    ! that way the plant will not experience water stress in the first 
+    ! day of the simulation when there Transpir_supply is calculated before 
+    ! there is any biomass available. Biomass is prescribed in 
+    ! stomate_prescribe.f90 
+    ! We need this line, if only for PFT type 1, which otherwise will
+    ! not be initialized.
+    transpir_supply(:,:) = val_exp
+    phi_soiltile(:,:,:) = -un
+    ! tzj initialize transpir_to tzj initialize transpir_tot  (hydraulic
+    ! architecture)
+    transpir_tot(:,:)=-un
+    VPD_tzj(:)=-un
+    !gsh(:,:)=zero
+
+    !! 1. Calculate plant soil water potential 
+    !! First get the soil properties 
+
+    ! Soil water potential for each soiltile in each layer from 
+    ! soil water content according to Van Genuchten (1980)
+
+    IF (.NOT. ALLOCATED(nvan)) ALLOCATE (nvan(nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_arch','Problem in allocate of variable nvan','','')
+
+    IF (.NOT. ALLOCATED(avan)) ALLOCATE (avan(nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_arch','Problem in allocate of variable avan','','')
+
+    IF (.NOT. ALLOCATED(mcr)) ALLOCATE (mcr(nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_arch','Problem in allocate of variable mcr','','')
+
+    IF (.NOT. ALLOCATED(mcs)) ALLOCATE (mcs(nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_arch','Problem in allocate of variable mcs','','')
+
+    IF (.NOT. ALLOCATED(ks)) ALLOCATE (ks(nscm),stat=ier)
+    IF (ier /= 0) CALL ipslerr_p(3,'hydrol_arch','Problem in allocate of variable mcs','','')
+!    DO ipts = 1,kjpindex
+
+    SELECTCASE (nscm)
+    CASE (3)
+  nvan(:) = nvan_fao(:)
+  avan(:) = avan_fao(:)
+  mcr(:) = mcr_fao(:)
+  mcs(:) = mcs_fao(:)
+    CASE (12)
+  nvan(:) = nvan_usda(:)
+  avan(:) = avan_usda(:)
+  mcr(:) = mcr_usda(:)
+  mcs(:) = mcs_usda(:)
+    CASE DEFAULT
+       !WRITE (numout,*) 'Unsupported soil type classification. Choose betweenzobler and usda according to the map'
+       CALL ipslerr_p(3,'hydrol_init','Unsupported soil type classification. ',&
+            'Choose between zobler and usda according to the map','')
+    ENDSELECT
+
+! Read in the run.def the parameters values defined by the user
+! NO CHECK on the values (as it is done in hydrol.f90)
+
+ !Config Key   = CWRR_N_VANGENUCHTEN
+    !Config Desc  = Van genuchten coefficient n
+    !Config If    = HYDROL_CWRR
+    !Config Def   = 1.89, 1.56, 1.31
+    !Config Help  = This parameter will be constant over the entire 
+    !Config         simulated domain, thus independent from soil
+    !Config         texture.   
+    !Config Units = [-]
+    CALL getin_p("CWRR_N_VANGENUCHTEN",nvan)
+
+    !Config Key   = CWRR_A_VANGENUCHTEN
+    !Config Desc  = Van genuchten coefficient a
+    !Config If    = HYDROL_CWRR
+    !Config Def   = 0.0075, 0.0036, 0.0019
+    !Config Help  = This parameter will be constant over the entire 
+    !Config         simulated domain, thus independent from soil
+    !Config         texture.   
+    !Config Units = [1/mm]  
+    CALL getin_p("CWRR_A_VANGENUCHTEN",avan)
+
+   !Config Key   = VWC_RESIDUAL
+    !Config Desc  = Residual soil water content
+    !Config If    = HYDROL_CWRR
+    !Config Def   = 0.065, 0.078, 0.095
+    !Config Help  = This parameter will be constant over the entire 
+    !Config         simulated domain, thus independent from soil
+    !Config         texture.   
+    !Config Units = [m3/m3]  
+    CALL getin_p("VWC_RESIDUAL",mcr)
+
+   !Config Key   = VWC_SAT
+    !Config Desc  = Saturated soil water content
+    !Config If    = HYDROL_CWRR
+    !Config Def   = 0.41, 0.43, 0.41
+    !Config Help  = This parameter will be constant over the entire 
+    !Config         simulated domain, thus independent from soil
+    !Config         texture.   
+    !Config Units = [m3/m3]  
+    CALL getin_p("VWC_SAT",mcs)
+
+   !Config Key   = RSOILROOT
+    CALL getin_p('rsoilroot',rsoilroot)  !
+!WRITE(*,*) "test flagtzj hydrolARC", rsoilroot
+    CALL getin_p('ok_joetzjer_hydro',ok_joetzjer_hydro)
+    CALL getin_p('VPD_k1',vpd_k1)
+    CALL getin_p('VPD_b1',vpd_b1)
+    !write(*,*) 'VPD_k1',vpd_k1
+    !write(*,*) 'VPD_b1',vpd_b1 
+
+     CALL qsatcalc (kjpindex, temp_air, pb, qsatt)
+     VPD(:) = ( qsatt(:)*pb(:) / (Tetens_1+qsatt(:)*Tetens_2 ) ) &
+          - ( qsurf(:) * pb(:) / (Tetens_1+qsurf(:)* Tetens_2) )
+     ! VPD is needed in kPa
+     ! We limit the impact of VPD in the range of [0:6] kPa
+     ! This seems to be the typical range of values
+     ! that the vapor pressure difference can take, although
+     ! there is a paper by Mott and Parkhurst, Plant, Cell & Environment,
+     ! Vol. 14, pp. 509--519 (1991) which gives a value of 15 kPa.
+     VPD(:) = MAX(zero,MIN(VPD(:)/10.,6.))
+    ! VPD(:) = VPD(:)*1.038+0.132
+    ! VPD(:) = VPD(:)*1.038291 + 0.1315685
+
+     VPD(:) = VPD(:)*vpd_k1+vpd_b1
+N=1
+M=27
+ALLOCATE(X(N))
+ALLOCATE(FVEC(N))
+ALLOCATE(PARS(M))
+
+IF (ok_joetzjer_hydro) THEN
+IF (ldrestart_read) THEN
+            psi_stem(:,:,:) = val_exp
+            DO icirc = 1,ncirc
+               !write(numout,*) 'fail psi_stem',icirc
+               !write(*,*) 'fail in psi stem', icirc
+               WRITE(part_str,'(I2)') icirc
+               IF ( icirc < 10 ) part_str(1:1) = '0'
+               var_name = 'psi_stem_'//part_str(1:LEN_TRIM(part_str))
+               CALL restget_p (rest_id, var_name, nbp_glo,nvm,1,kjit,.TRUE.,psi_stem(:,:,icirc), "gather", nbp_glo, index_g)
+            ENDDO
+
+            psi_leaf(:,:,:) = val_exp
+            DO icirc = 1,ncirc
+               WRITE(part_str,'(I2)') icirc
+               IF ( icirc < 10 ) part_str(1:1) = '0'
+              var_name = 'psi_leaf_'//part_str(1:LEN_TRIM(part_str))
+               CALL restget_p (rest_id, var_name,nbp_glo,nvm,1,kjit,.TRUE.,psi_leaf(:,:,icirc), "gather", nbp_glo, index_g)
+            ENDDO
+
+           psi_root(:,:,:) = val_exp
+            DO icirc = 1,ncirc
+               WRITE(part_str,'(I2)') icirc
+               IF ( icirc < 10 ) part_str(1:1) = '0'
+               var_name = 'psi_root_'//part_str(1:LEN_TRIM(part_str))
+               CALL restget_p (rest_id, var_name,nbp_glo,nvm,1,kjit,.TRUE.,psi_root(:,:,icirc), "gather", nbp_glo, index_g)
+            ENDDO
+   ENDIF
+ENDIF
+
+DO ipts = 1,kjpindex  ! loop on land points 
+
+   tmcr=mcr(njsc(ipts))
+   tmcs=mcs(njsc(ipts))
+   tnvan=nvan(njsc(ipts))
+   tavan=avan(njsc(ipts))
+
+   WRITE(*,*) "tmcr", tmcr
+!----------------------------------------------------------------------------------
+! tzjh : compute light and VPD (for hydraulic architecture)
+ !CALL qsatcalc (kjpindex, temp_air, pb, qsatt)
+ !    VPD(:) = ( qsatt(:)*pb(:) / (Tetens_1+qsatt(:)*Tetens_2 ) ) &
+ !         - ( qsurf(:) * pb(:) / (Tetens_1+qsurf(:)* Tetens_2) )
+     ! VPD is needed in kPa
+     ! We limit the impact of VPD in the range of [0:6] kPa
+     ! This seems to be the typical range of values
+     ! that the vapor pressure difference can take, although
+     ! there is a paper by Mott and Parkhurst, Plant, Cell & Environment,
+     ! Vol. 14, pp. 509--519 (1991) which gives a value of 15 kPa.
+ !    VPD(:) = MAX(zero,MIN(VPD(:)/10.,6.))
+    ! VPD(:) = VPD(:)*1.038+0.132
+    ! VPD(:) = VPD(:)*1.038291 + 0.1315685
+    
+  !   VPD(:) = VPD(:)*vpd_k1+vpd_b1
+     light(ipts) = swdown(ipts) * 2.3
+!----------------------------------------------------------------------------------
+
+      !---TEMP---
+       IF (ld_hydrolarch) THEN
+          !WRITE(numout,*) 'soil texture',njsc
+          !WRITE(numout,*) 'swc', swc(ipts,:,:)  
+          !WRITE(numout,*)'soiltile',soiltile(ipts,:)
+       ENDIF
+       !----------
+
+       !! 2.1 Calculate soil water potential
+       !  Swc calculated in hydrol.f90 cannot be lower than or equal 
+       !  to the residual soil water content for each soiltile.
+       DO ibdl = 1, nbdl
+
+          DO istm = 1,nstm
+             ! tmcr is mcr(njsc(ipts)) - this can be simplified 
+             IF (swc(ipts,ibdl,istm) .LE. tmcr)  THEN
+
+                    IF (istm .EQ. 2) THEN
+                                  WRITE(*,*) "LOWER than tmcr", ibdl, istm
+                                  WRITE(*,*) "SWC", swc(ipts,ibdl,istm)
+                    ENDIF
+
+
+     !+++CHECK+++
+                !Explain why you do this
+                swc_adj(ipts,ibdl,istm) = tmcr  + .00001
+!               swc_adj(ipts,ibdl,istm) = mcr_usda(nstm) + .00001
+                !+++++++++++
+             ELSE
+                swc_adj(ipts,ibdl,istm) = swc(ipts,ibdl,istm)
+             IF (l_first_sechiba) THEN
+                   swc_adj(ipts,ibdl,istm) = min_sechiba
+             ENDIF
+
+             ENDIF
+
+           ENDDO !ENDDO loop istm soil type
+
+
+          !! 2. Initialize variables on first call
+          ! Soil water potential for each soiltile in each layer from 
+          ! soil water content according to Van Genuchten (1980). Convert 
+          ! unit avan from mm-1 to m-1. Convert units soil matric potential
+          ! from m to MPa by multiplying with cte_grav and rho_h2o. 
+          ! Soiltile = fraction of each soil column 
+          ! (three soil columns=bare soil, tree, grass)
+             DO istm = 1,nstm
+               IF (swc(ipts,ibdl,istm) .GE. tmcs) THEN
+               !WRITE(*,*) "sup a field capacity"
+               ENDIF
+
+               IF (swc_adj(ipts,ibdl,istm) .GT. min_stomate .AND. &
+                  (swc_adj(ipts,ibdl,istm) - tmcr) .GT. min_stomate) THEN
+
+                phi_soiltile(ipts,ibdl,istm) = &
+                     - ( cte_grav * rho_h2o * kilo_to_unit * & 
+                     ( 1/(tavan*kilo_to_unit) ) * &
+                     ( ( (swc_adj(ipts,ibdl,istm) - tmcr ) / &
+                     ( tmcs - tmcr ) ) ** &
+                     ( -1 / (1-1/tnvan) ) - 1) ** &
+                     (1/tnvan ) ) / mega_to_unit
+                              IF (istm .EQ. 2) THEN
+                                  WRITE(*,*) "soil water content (adjusted)", swc_adj(ipts,ibdl,istm),ibdl
+                                 ! WRITE(*,*) "phi", phi_soiltile(ipts,ibdl,istm),ibdl
+                              ENDIF
+! ( -1 / (1-1/tnvan) ) - 1) ** & original
+!  ( -(1+(1/tnvan)) ) - 1) ** &
+
+                ELSE
+
+                phi_soiltile(ipts,ibdl,istm) = zero
+WRITE(*,*) "no compute phi_soiltile", ibdl, istm
+                ENDIF
+                ENDDO !soil type 
+
+          ! Threshold for soil water potential: it cannot be lower than the 
+          ! soil water potential for hygroscopic water (= -5 MPa, Larcher 2001)
+          phi_soil(ipts,ibdl,:) = MAX(phi_soiltile(ipts,ibdl,:),pres_soil_potential_min)
+          ! Calculate soil water potential per layer by multiplying with 
+          ! the fraction of each soiltile
+!!$       phi_soil(ipts,ibdl) = SUM(soiltile(ipts,:) * phi_soiltile(ipts,ibdl,:))
+         ENDDO ! loop on soil layers
+
+       ! following initialisation of swc
+       l_first_sechiba = .FALSE.
+
+       !---TEMP---
+       IF (ld_hydrolarch) THEN
+          !WRITE(numout,*) 'phi_soiltile', phi_soiltile(ipts,:,:)
+          !WRITE(numout,*) 'phi_soil', phi_soil
+       ENDIF
+       !----------
+
+       !! 3. Calculate plant resistance
+
+       !! 3.1 Calculate root profile 
+       !  Weighting soil water potential with root profile
+
+
+       ! Scaling factor for integration
+       rpc(:) = un / ( un - EXP( -z_soil(nbdl) / humcste(:) ) )
+
+!WRITE(*,*) "SECH_HYDROL zsoil", z_soil(nbdl) 
+!WRITE(*,*) "SECH_HYDROL hum", humcste
+!WRITE(*,*) "SECH_HYDROL rpc", rpc
+
+       ! Calculate root density per layer per pft
+       !+++CHECK+++
+       ! what is the root density for layer one ?
+       DO ibdl = 1, nbdl ! Loop over # soil layers
+          root_dens(ibdl,:) = rpc(:) * &
+               ( EXP( -z_soil(ibdl)/humcste(:)) - &
+               EXP( -z_soil(ibdl+1)/humcste(:)) )
+          !write(*,*) 'root_density ',ibdl,' ',root_dens(ibdl,2)
+       ENDDO ! Loop over # soil layers
+       !++++++++++
+
+       !! 3.2 Calculate plant resistance to water transport 
+       !  Calculate plant resistance to water transport according to following
+       !  the principle of an electric circuit. The code is largely based on
+       !  Hickler et al. 2006
+       DO ivm = 2,nvm ! loop on pft 
+
+          !! 3.2.1 Calculate PFT-specific characteristics
+          IF (is_tree(ivm)) THEN
+
+             ! Calculate for each circumference classes
+             tmp_ncirc = ncirc
+
+             ! Calculate the effective height (m) from biomass. The effective
+             ! value is used here because the water needs to be transported
+             ! through both the belowground and aboveground biomass. Using the 
+             ! height (thus not the effective height) would only account for the 
+             ! height due to the aboveground biomass.
+             height(:) = wood_to_height_eff(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)
+             dbh(:)=wood_to_dia(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm) !tzjh
+             ! Calculate soil water potential weighted for root density
+             ! Note that the second soiltile in swc is for trees.
+             !+++CHECK+++
+             ! This implementation relies on two strong assumptions. First,
+             ! roots are assumed to follow a rigid distribution irrespective 
+             ! of how the water is distributed in the soil. So even if on 
+             ! average lots of water is available in deeper layer, the modeled 
+             ! plants will grow most roots in the top layers. Second it is 
+             ! assumed that the root_potential is identical to the soil_potential
+             ! With these assumptions it was found to be impossible to grow
+             ! oak, beech and birch even in central Europe because those species
+             ! experienced too much water stress. To overcome this problem
+             ! a tuning factor has been introduced. In the future this tuning factor
+             ! should be removed by a morec mechanistic model for root-soil
+             ! interface.
+             !+++++ TEMP ++++++
+
+! If rsoilroot is activated AND PFT2 
+
+               IF ((rsoilroot) .AND. (ivm .EQ. 2)) THEN
+               !WRITE(*,*) "rsoilroot ON"
+               ! THIS CONCERN only ISTM (soiltype=2)  
+               !Define some parameters (hard coded for now, only for PFT2) 
+                rr=0.29E-3 !rr fine root radius (m) ; in Bonan et al., 2014 GMD rr â 0.29
+                srl=10 ! (m/g specific roots lenght value from Metcalfe et al., 2008)
+
+                  DO ibdl = 1, nbdl ! loop over soil layers 
+                  !consider a constant biomass to compute lr
+                  lr(ibdl)=root_dens(ibdl,ivm)*2*60* srl !  
+           !lr(ibdl)=root_dens(ibdl,ivm)*2*biomass(ipts,ivm,iroot,icarbon)* srl !  
+           !rs(ibdl)=(1/(3.14*lr(ibdl)*z_soil(ibdl+1)))**(1/2)
+           !rs(ibdl)=(1/(3.14*lr(ibdl)*dlh(ibdl)))**(1/2)
+                  rs(ibdl)=(1/(3.14*lr(ibdl)))**(1/2)
+
+                  ! k save is in mm per day we need in in m/s , mpa *g)
+                  ! -3 is the psiRootmin (Bonan et al., 2014) 
+                  ! mm/d to m/s
+                  ksaveUNIT(ipts,ibdl,2)=ksave(ipts,ibdl,2)*1000/(60*60*24)
+                  !res_soil(:,ibdl,2)=(LOG(rs(ibdl)/rr))/(dlh(ibdl)*2*3.14*lr(ibdl)*(ksaveUNIT(ipts,ibdl,2)/(9.8*18E-5*1E-3)))
+                  res_soil(ipts,ibdl,2)=(LOG(rs(ibdl)/rr))/(dlh(ibdl)*2*3.14*lr(ibdl)*(ksaveUNIT(ipts,ibdl,2)/(9.8*18E-5*1E-3)))
+                  e_max(ipts,ibdl,2)= (phi_soil(ipts,ibdl,2)-psi_soil_min)/res_soil(ipts,ibdl,2)
+
+                         IF (e_max(ipts,ibdl,2) .LT. min_sechiba)  e_max(ipts,ibdl,2) = 0
+                  END DO  ! loop on soil layers
+
+                  ! tmp=SUM(e_max(ipts,:,2))  ! comment this line now April 19
+                  ! 22:45 2020 
+                  DO icirc=1,ncirc
+                     IF (icirc .LT. 10) THEN
+                         which_layers=icirc
+                     ELSE
+                         which_layers=10
+                     ENDIF
+                     tmp=SUM(e_max(ipts,1:which_layers,2)) 
+                     e_frac=zero
+                     phi_soilroot = zero
+                     IF (tmp .GT. min_sechiba) THEN          
+                         DO ibdl = 1, which_layers
+                            e_frac(ipts,ibdl,2)=e_max(ipts,ibdl,2)/SUM(e_max(ipts,1:which_layers,2))
+                     
+                         ENDDO
+                    !write(*,*) 'e_frac',e_frac(ipts,ibdl,2), 'e_max',e_max(ipts,ibdl,2), 'sum_e_max', SUM(e_max(ipts,:,2))
+                    !write(numout,*) "sechibahydrol1::", phi_soil(ipts,:,2), e_frac(ipts,:,2) 
+                     phi_soilroot(ipts,ivm) = SUM( phi_soil(ipts,1:which_layers,2)*e_frac(ipts,1:which_layers,2))
+                     ELSE
+                          phi_soilroot(ipts,2)=psi_soil_min    !-3 before
+                     END IF
+                    ! DO ibdl=1, nbdl
+                    !    write(*,*) 'e_frac',e_frac(ipts,ibdl,2),'e_max',e_max(ipts,ibdl,2), 'sum_e_max', SUM(e_max(ipts,:,2))
+                    ! ENDDO
+                    phi_soilroot_circ(ipts,ivm,icirc)=phi_soilroot(ipts,ivm)      
+                ENDDO
+         
+             ELSE ! no rsoil and pft2 
+                    !write(numout,*) "sechibahydrol2::", root_dens(:,ivm), phi_soil(ipts,:,2)
+                  phi_soilroot(ipts,ivm) = SUM(root_dens(:,ivm) * phi_soil(ipts,:,2)) + &
+                  phi_soil_tune(ivm)
+                  DO icirc=1,ncirc
+                        phi_soilroot_circ(ipts,ivm,icirc)=phi_soilroot(ipts,ivm)
+                  ENDDO
+               ENDIF !rsoilroot and pft2
+
+
+          ELSE ! no trees condition
+             ! There are no circumference classes for grasses
+             ! and crops. Biomasses are stored in first circumference
+             ! class
+             tmp_ncirc = 1
+
+             ! Calculate height (m) from biomass
+             height(1) = circ_class_biomass(ipts,ivm,1,ileaf,icarbon) * &
+                  sla(ivm) * lai_to_height(ivm)
+
+             ! Calculate soil water potential weighted for root density. Note 
+             ! that the third soiltile in swc is for grasses and crops.
+             !write(numout,*) "sechibahydrol3::", root_dens(:,ivm), phi_soil(ipts,:,3),  phi_soil_tune(ivm)
+             phi_soilroot(ipts,ivm) = SUM(root_dens(:,ivm) * phi_soil(ipts,:,3)) + &
+                  phi_soil_tune(ivm)
+             !+++++++++++ 
+
+          ENDIF ! tree or no tree condition
+
+          !! 3.2.2 Calculate general characteristics
+          !  Calculate soil water potential weighted for root density
+          !  Note that the second soiltile in swc is for trees. Calculate
+          !  for both the relevant soil water column i.e. tall vegetation
+          !  and a vertual soil water colum i.e. bare soil. The latter is
+          !  needed in land cover change because we may establish vegetation
+          !  on PFT1 and then need to know the water stress the plants will
+          !  experience on this new soil column.
+          !+++CHECK+++
+          !  should this be sum of soil water potential or the average? The
+          !  virtual_phi_soilroot may need to be revised once the water 
+          !  columns are getting merged in LCC. There are no plants so we 
+          !  should not account for the assumptions and thus not implement the
+          !  tuning factor. 
+          vir_phi_soilroot(ipts,ivm) = SUM(root_dens(:,ivm) * phi_soil(ipts,:,1))
+          !+++++++++++
+
+          !---TEMP---
+          IF (ld_hydrolarch .AND. ivm .EQ. test_pft) THEN 
+             !WRITE(numout,*) 'circ_class_biomass in hydrolic architecture,icirc', &
+             !     circ_class_biomass(1,test_pft,:,:,icarbon)
+            ! WRITE(numout,*) 'vegetation height, pft', height(:), ivm
+             !WRITE(numout,*) 'z_soil',z_soil(1:nbdl+1)
+             !WRITE(numout,*) 'rpc', ivm, rpc(ivm)
+!!$             WRITE(numout,*) 'phi_soilrootlayer',root_dens*phi_soil
+             !WRITE(numout,*) 'phi_soilroot', phi_soilroot(:,test_pft)
+            ! WRITE(numout,*) 'vir_phi_soilroot', vir_phi_soilroot(:,test_pft)
+          ENDIF
+          !----------
+
+          !! 3.2.3 Calculate plant resistences
+          IF ( biomass(ipts,ivm,ileaf,icarbon) .GT. min_sechiba .AND. &
+               biomass(ipts,ivm,iroot,icarbon) .GT. min_sechiba ) THEN
+             
+             DO icirc = 1,tmp_ncirc
+
+                ! This ensures that the loop goes over all circ_classes for trees and only
+                ! the first circ_class for grasses and crops
+                IF (circ_class_biomass(ipts,ivm,icirc,ileaf,icarbon) .GT. min_sechiba .AND. &
+                     circ_class_biomass(ipts,ivm,icirc,iroot,icarbon) .GT. min_sechiba ) THEN 
+
+                   !! 3.2.3.1 Root resistance
+                   !  Root resistance is in the first order related to root mass 
+                   !  and expression was proposed by Weatherly, 1982). Convert
+                   !  units of circ_class_biomss i.e. gC/ind to kg/ind
+                   R_root = un / (k_root(ivm) * 2 * &
+                        circ_class_biomass(ipts,ivm,icirc,iroot,icarbon) &
+                        / kilo_to_unit)
+
+                   !! 3.2.3.2 Sapwood resistance
+                   !  Calculate k_sap_cav as a function of water stress following 
+                   !  Tyree et al. (1994) and Sperry et al. (1998)
+                   IF (is_tree(ivm)) THEN
+
+                      IF( (phi_soilroot(ipts,ivm) == zero) .AND. (phi_50(ivm) .LE. zero) )THEN
+
+                         ! This seems to cause a strange numerical issue, even though we should
+                         ! just be taking the exponential of zero (i.e., one).  
+                         k_sap_cav(ivm) = k_sap(ivm)
+
+                      ELSE
+                         !++++ TEMP +++++
+                         IF((phi_soilroot(ipts,ivm)/phi_50(ivm)) .LT. zero)THEN
+                            !++++++ CHECK +++++++++
+                            ! If this is true, we generally try to take this ratio to
+                            ! an odd power, which results in an imaginary number.  So
+                            ! we use this simple solution for the moment.
+                         !   WRITE(numout,*) 'phi_soilroot', phi_soilroot(ipts,ivm)
+                         !   WRITE(numout,*) 'ipts', ipts
+                         !   WRITE(numout,*) 'ivm', ivm
+                         !   CALL ipslerr_p (3,'sechiba_hydrol_arch', &
+                         !        'this quantity should never be negative', &
+                         !        'See the output file for more details.','')
+                            ! A temporary fix.  We cannot have the stop statement anymore,
+                            ! since capping phi_soilroot at 0.0 above results in many PFTs
+                            ! dying.  This needs to be addressed.
+                            k_sap_cav(ivm) = k_sap(ivm)
+                         ELSE
+                            k_sap_cav(ivm) = k_sap(ivm) * &
+                                 EXP(-((phi_soilroot(ipts,ivm)/phi_50(ivm)) ** &
+                                 c_cavitation(ivm)))
+                         ENDIF
+
+                      ENDIF
+
+                      ! If k_sap_cav is too low, we can get a divide by zero
+                      ! error in the next couple lines.  So this is a protection
+                      ! against that.
+                      IF(k_sap_cav(ivm) .LE. min_sechiba)THEN
+
+                         k_sap_cav(ivm) = min_sechiba
+
+                      ENDIF
+
+                      !  Following the expression by Magnani et al 2000, sapwood resistance
+                      !  is given as a function of sapwood area. Convert Sapwood mass to 
+                      !  sapwood area
+                      !  tzj :  correction bug in R_sap 
+                     ! R_sap = height(icirc) / (k_sap_cav(ivm) * &
+                     !      (( circ_class_biomass(ipts,ivm,icirc,isapabove,icarbon) + &
+                     !      circ_class_biomass(ipts,ivm,icirc,isapbelow,icarbon)) / & 
+                     !      (tree_ff(ivm)*pipe_density(ivm) / height(icirc))) )
+                       R_sap = (height(icirc)**2* tree_ff(ivm)*pipe_density(ivm)) / (k_sap_cav(ivm) *&
+                        (circ_class_biomass(ipts,ivm,icirc,isapabove,icarbon) + &
+                        circ_class_biomass(ipts,ivm,icirc,isapbelow,icarbon)))
+
+                   ELSE
+
+                      !+++CHECK+++
+                      ! We have about the same leaf and root restistances and masses
+                      ! as for tress but lack a resistance in the sapwood. This is resulting
+                      ! in a huge supply because we lack part of the resistance. This was 
+                      ! the motivation to create an R_sap for grasses and roots. This equation 
+                      ! is made up and should be carefully checked against physiological
+                      ! studies for grasses and crops on the issue.
+!!$                         R_sap = zero
+                      ! R_sap = height(icirc) / (k_sap(ivm) * &
+                      !     (circ_class_biomass(ipts,ivm,icirc,isapabove,icarbon) / & 
+                      !     (pipe_density(ivm) / height(icirc))) )
+                      ! tzj idem R_sap
+                      R_sap = (height(icirc)**2 * pipe_density(ivm)) / (k_sap(ivm) *  &
+                      circ_class_biomass(ipts,ivm,icirc,isapabove,icarbon))
+
+
+                      !+++++++++++
+
+                   ENDIF
+
+                   !! 3.2.3.3 Leaf resistance
+                   !  Leaf resistance related to foliar projective area (Hickler 2006) or 
+                   !  LAI (more consistent with pipe model)? fpc instead of lai because 
+                   !  it is assumed that only sunlit leaves contribute to transpiration
+                   !  Initialy fpc = 1-e**(-0.5*LAI) but it was replaxced by veget which
+                   !  in itseld is calculated in Pgap and thus accounts for LAI and canopy
+                   !  structure. This was still inconsistent with the calculation of the
+                   ! atmospheric demand for transpiration, to improve consistency the coupled
+                   ! lai was used as was done in the energy budget calculations.
+                   ! R_leaf = 1/(k_leaf * fpc)
+!!$                   R_leaf = un / (k_leaf(ivm) * &
+!!$                        (un - EXP(-0.5 * circ_class_biomass(ipts,ivm,icirc,ileaf,icarbon) * &
+!!$                        sla(ivm))))
+                   R_leaf = un / (k_leaf(ivm) * &
+                        biomass_to_coupled_lai(circ_class_biomass(ipts,ivm,icirc,ileaf,icarbon), &
+                        veget(ipts,ivm),ivm))
+
+                   !! 3.2.3.4 Temperature dependance of resistance
+                   !  Decrease root resistance with soil temperature as a result of 
+                   !  changes in water viscosity (Cochard et al 2000)
+                   !  Decrease shoot resistance with air temperature (Cochard et al. 2000)
+                   R_root = R_root / (a_viscosity(1) + a_viscosity(2) * &
+                        (temp_sol_new(ipts) - zeroCelsius))               
+                   R_shoot = (R_leaf + R_sap) / (a_viscosity(1) + a_viscosity(2) * &
+                        (temp_air(ipts) - zeroCelsius))
+
+                   !! 3.2.3.5 Calculate pressure difference between leaves and soil 
+                   !  Defined by Whitehead 1998. Convert units to MPa.
+                   !+++CHECK+++
+                   ! If height is kept as a variable the delta_P gets out of bounds
+                   ! this seems to be one of the places where the static approach
+                   ! by Hickler fails. Could this be overcome by Sperry et al?
+                   ! As a quick fix we limit the height. This might have been acceptable
+                   ! if we would not have had to limit it at only 8m!
+!!$                   IF (height(icirc) .GT. 8.) height(icirc) = 8.
+                   delta_P = phi_leaf(ivm) - phi_soilroot(ipts,ivm) + &
+                        (height(icirc)*cte_grav*rho_h2o) / kilo_to_unit
+                   vir_delta_P = phi_leaf(ivm) - vir_phi_soilroot(ipts,ivm) + &
+                        (height(icirc)*cte_grav*rho_h2o) / kilo_to_unit
+                   !++++++++++
+
+                   !! 3.2.3.6 Calculate water supply for transpiration in m/s
+                   ! Using Dracy's law (Slatyer 1967, Whitehead 1998)
+                   circ_class_transpir_supply(icirc) = (-delta_P) / (R_root + R_shoot)
+                   vir_circ_class_transpir_supply(icirc) = (-vir_delta_P) / (R_root + R_shoot)
+
+                ELSE  
+                      
+                   !set transpir_supply to zero if there is no leaf or root biomass in the circ_class 
+                   circ_class_transpir_supply(icirc) = zero
+                   vir_circ_class_transpir_supply(icirc) = zero
+
+             ENDIF
+
+             !---TEMP--- 
+             IF (ld_hydrolarch .AND. ivm .EQ. test_pft) THEN
+                !WRITE(numout,*) 'root_dens', root_dens(:,test_pft)
+                !WRITE(numout,*) 'k_sap_cavitation, biomass(iroot)', k_sap_cav(ivm), &
+                !     2 * circ_class_biomass(ipts,ivm,icirc,iroot,icarbon) / 1000.
+                !WRITE(numout,*) 'sapwood area, ', ( circ_class_biomass(ipts,ivm,icirc,isapabove,icarbon) + &
+                     !circ_class_biomass(ipts,ivm,icirc,isapbelow,icarbon)) / (tree_ff(ivm) * pipe_density(ivm)) / &
+                     !height(icirc)
+                !WRITE(numout,*) 'fpc, ',(1-EXP(-0.5*circ_class_biomass(ipts,ivm,icirc,ileaf,icarbon)*sla(ivm)))
+                !WRITE(numout,*) 'R_root, R_sap, R_leaf', R_root, R_sap, R_leaf
+                !WRITE(numout,*) 'R_shoot', R_shoot 
+                !WRITE(numout,*) 'delta_P', delta_P
+             ENDIF
+             !----------
+
+          ENDDO ! ncirc
+
+
+          !+++CHECK+++
+          ! Just to be sure that we are not double counting for grasses and crops
+          IF (is_tree(ivm)) THEN
+             ! transpir_supply per PFT (sum of diameter classes) per timestep
+             transpir_supply(ipts,ivm) = &
+                  (SUM(circ_class_transpir_supply(:) * circ_class_n(ipts,ivm,:))) * &
+                  dtradia * kilo_to_unit
+             vir_transpir_supply(ipts,ivm) = &
+                  (SUM(vir_circ_class_transpir_supply(:) * circ_class_n(ipts,ivm,:))) * &
+                  dtradia * kilo_to_unit
+          ELSE
+             transpir_supply(ipts,ivm) = &
+                  (circ_class_transpir_supply(1) * circ_class_n(ipts,ivm,1)) * &
+                  dtradia * kilo_to_unit
+             vir_transpir_supply(ipts,ivm) = &
+                  (vir_circ_class_transpir_supply(1) * circ_class_n(ipts,ivm,1)) * &
+                  dtradia * kilo_to_unit
+          ENDIF
+          !+++++++++++
+
+          ! Set transpir_supply to zero when negative.
+          ! (When phisoilroot becomes very low, delta_P becomes positive and transpir_supply negative)
+          IF (transpir_supply(ipts,ivm) .LT. zero) then
+             IF(ld_warn)THEN
+                !WRITE(numout,*) 'transpir_supply before set to zero when negative', transpir_supply(ipts,ivm), ivm
+                !WRITE(numout,*) 'ipts, ivm:', ipts,ivm
+                !WRITE(numout,*) 'transpir_supply: ', transpir_supply(ipts,ivm)
+                !WRITE(numout,*) 'phisoilroot: ', phi_soilroot(ipts,ivm)
+             ENDIF
+             transpir_supply(ipts,ivm) = MAX(transpir_supply(ipts,ivm), zero)
+             vir_transpir_supply(ipts,ivm) = MAX(vir_transpir_supply(ipts,ivm), zero)
+          ELSE
+             !do nothing
+          ENDIF   
+
+          ! transpir_supply is in m/s. Convert to mm/dt
+          ! transpir_supply(ipts,ivm) = transpir_supply(ipts,ivm) * dtradia * 1000
+!!$             WRITE(numout,*) 'transpir_supply', transpir_supply
+
+          !---TEMP--- 
+          IF (ld_hydrolarch .AND. ivm .EQ. test_pft .AND. ipts == test_grid) THEN
+             WRITE(numout,*) 'transpir_supply, PFT, ', transpir_supply(ipts,test_pft), ivm
+             WRITE(numout,*) 'vir_transpir_supply, PFT, ', vir_transpir_supply(ipts,test_pft), ivm
+          ENDIF
+          !----------
+
+          ! Calculate daily water stress for use in stomate
+!!$             IF (transpir_supply .LE. transpir) THEN
+!!$                hydrol_stress(ipts,ivm) = transpir_supply(ipts,ivm)/transpir(ipts,ivm)
+!!$             ELSE IF (transpir_supply .GT. transpir) THEN
+!!$                hydrol_stress(ipts,ivm) = 1.
+!!$             ENDIF
+
+          ! Hydraulic architecure is not defined i.e. no biomass
+       ELSE
+
+          transpir_supply(ipts,ivm) = zero
+          phi_soilroot(ipts,ivm) = zero
+
+       ENDIF ! biomass leaves and roots.gt.zero
+          
+
+    ENDDO ! nvm
+
+!ENDDO ! DO ipts = 1,kjpindex
+!-----------------------------------------------------------------------------------------------------------------
+! tzjh hydraulic architecture
+!-----------------------------------------------------------------------------------------------------------------
+!control%ok_joetzjer_hydro=control_in%ok_joetzjer_hydro
+IF (ok_joetzjer_hydro) THEN
+!   IF (ldrestart_read) THEN
+!            psi_stem(:,:,:) = val_exp
+!            DO icirc = 1,ncirc
+!               !write(numout,*) 'fail psi_stem',icirc
+!               !write(*,*) 'fail in psi stem', icirc
+!               WRITE(part_str,'(I2)') icirc
+!               IF ( icirc < 10 ) part_str(1:1) = '0'
+!               var_name = 'psi_stem_'//part_str(1:LEN_TRIM(part_str))
+!               CALL restget_p (rest_id, var_name, nbp_glo,nvm,1,kjit,.TRUE.,psi_stem(:,:,icirc), "gather", nbp_glo, index_g)
+!            ENDDO
+
+ !           psi_leaf(:,:,:) = val_exp
+ !           DO icirc = 1,ncirc
+ !              WRITE(part_str,'(I2)') icirc
+ !              IF ( icirc < 10 ) part_str(1:1) = '0'
+ !             var_name = 'psi_leaf_'//part_str(1:LEN_TRIM(part_str))
+ !              CALL restget_p (rest_id, var_name, nbp_glo,nvm,1,kjit,.TRUE.,psi_leaf(:,:,icirc), "gather", nbp_glo, index_g)
+ !           ENDDO
+
+ !          psi_root(:,:,:) = val_exp
+ !           DO icirc = 1,ncirc
+ !              WRITE(part_str,'(I2)') icirc
+ !              IF ( icirc < 10 ) part_str(1:1) = '0'
+ !              var_name = 'psi_root_'//part_str(1:LEN_TRIM(part_str))
+ !              CALL restget_p (rest_id, var_name, nbp_glo,nvm,1,kjit,.TRUE.,psi_root(:,:,icirc), "gather", nbp_glo, index_g)
+  !          ENDDO
+  ! ENDIF
+  
+
+!DO ipts = 1,kjpindex
+
+!N=1
+!M=27
+!ALLOCATE(X(N))
+!ALLOCATE(FVEC(N))
+!ALLOCATE(PARS(M))
+
+
+DO ivm = 2,nvm ! loop over pft - put a flag after to be able to choose the hydraulic architecture
+
+! set general variables values  
+limit = 0.00001
+
+!-----------------------------------------------------------------
+! variable en dur but to change
+timestep = 1800
+klight = 100           ! light curve parameter
+atm = 101.3            ! atmospheric pressure, kPa
+!----------------------------------------------------------------
+
+! Need to know when it's the first time to initialize (maybe there is a simpler
+! way to do, at least this work) - make sure it works when several pft. 
+
+   IF (l_first_inih .EQ. .TRUE.) THEN  ! flag1 for initialization = TRUE when
+                                              ! ready for initialization
+   iniok(ipts,ivm,:) = .TRUE. ! flag2 for initialization (per circ)
+          WRITE(*,*) 'tzjh iniok', iniok(ipts,ivm,:)
+   ENDIF
+   l_first_inih= .FALSE.
+          
+       DO icirc = 1,tmp_ncirc ! loop over tree classes 
+!!!!!!!       DO icirc = 1,1 ! loop over tree classes 
+
+            IF (iniok(ipts,ivm,icirc) .EQ. .TRUE.) THEN     !initialization per class
+            WRITE(*,*) 'tzjh inialize',icirc
+
+                
+
+!!! Define the initial conditions           
+                stem_volume(ipts,ivm,icirc)=stem_volume_f(height(icirc),dbh(icirc))
+                root_volume(ipts,ivm,icirc)=root_volume_f(stem_volume(ipts,ivm,icirc), wood_density(ivm),root_shoot_ratio(ivm),root_density(ivm)) ! the volume of the root system
+
+                canopy_leaf_area(ipts,ivm,icirc) = canopy_leaf_area_f(dbh(icirc), sla_hydro(ivm))
+                grav_potential = grav_potential_f(height(icirc))
+                !write(*,*) 'flag_flow 1'
+!!! Calculate the size of the stored water reserves
+                vxmax(icirc) = vxmax_f(stem_volume(ipts,ivm,icirc), w_density_stem(ivm))
+                vrmax(icirc) = vrmax_f(stem_volume(ipts,ivm,icirc), wood_density(ivm), root_shoot_ratio(ivm), rwc_root(ivm))
+                vmax_l(icirc) = vmax_l_f(dbh(icirc), LDMC(ivm))* cut_limit
+!!!!WRITE(*,*)"vrmax ", vrmax(icirc),vmax_l(icirc),vxmax(icirc)
+                !write(*,*) 'flag_flow 2'
+!!!! start off by assuming the tree equilibrated with the soil 
+!!!!!!!!!!!!!!!!psi_soil(ivm)=phi_soilroot(ipts,ivm)
+
+                   IF (ALL(psi_stem(:,:,icirc) == val_exp) .AND. ALL(psi_leaf(:,:,icirc) == val_exp)) THEN
+
+                         psi_root(ipts,ivm,icirc)=phi_soilroot_circ(ipts,ivm,icirc)
+                         psi_stem(ipts,ivm,icirc)=phi_soilroot_circ(ipts,ivm,icirc)
+                         psi_leaf(ipts,ivm,icirc)=phi_soilroot_circ(ipts,ivm,icirc)
+                   ENDIF
+!!Determine the water storage volume consistent with this initial water potential
+                   vx(ipts,ivm,icirc) = vxmax(icirc) + cxyl(ivm)*psi_stem(ipts,ivm,icirc)*stem_volume(ipts,ivm,icirc)*1000.*1000./18.
+                   vr(ipts,ivm,icirc) = vrmax(icirc) + cr(ivm)*psi_root(ipts,ivm,icirc)*root_volume(ipts,ivm,icirc)*1000.*1000./18.
+                   vl(ipts,ivm,icirc) = vmax_l(icirc) + cl(ivm)*psi_leaf(ipts,ivm,icirc)*canopy_leaf_area(ipts,ivm,icirc)
+!
+                 !  write(*,*) 'flag_flow 3'
+!! and the conductances 
+                   kstem(icirc) = kstem_f(kmax_stem(ivm), P50_stem(ivm), a_stem(ivm), psi_stem(ipts,ivm,icirc))
+                   kleaf(icirc) = kleaf_f(kmax_leaf(ivm), P50_leaf(ivm), a_leaf(ivm), psi_leaf(ipts,ivm,icirc))
+                   kroot(icirc) = kroot_f(kmax_root(ivm), P50_root(ivm), a_root(ivm), psi_root(ipts,ivm,icirc))
+                
+!!
+                 iniok(ipts,ivm,icirc)= .FALSE.
+!!
+!!WRITE(*,*)"stem_volume ", icirc,  stem_volume(icirc)
+!!WRITE(*,*)"root_volume ", icirc,  root_volume(icirc)
+!!WRITE(*,*)" CAN_LA ", canopy_leaf_area(icirc)
+!!WRITE(*,*)" gravpot ", grav_potential(icirc)
+!!WRITE(*,*)"psi_root ", psi_root(ipts,ivm,icirc)
+!!WRITE(*,*)"psi_stem ", psi_stem(ipts,ivm,icirc)
+!!WRITE(*,*)"psi_leaf ", psi_leaf(ipts,ivm,icirc)
+!!WRITE(*,*)"psi_soil ", psi_soil(ivm)
+!!WRITE(*,*)"kroot ", kroot(icirc)
+!!WRITE(*,*)"kstem ", kstem(icirc)
+!!WRITE(*,*)"kleaf ", kleaf(icirc)
+!!WRITE(*,*)"vx ", vx(ipts,ivm,icirc)
+!!WRITE(*,*)"vr ", vr(ipts,ivm,icirc)
+!!WRITE(*,*)"vl ", vl(ipts,ivm,icirc)
+!
+!
+           ELSEIF (iniok(ipts,ivm,icirc) .EQ. .FALSE.) THEN ! run 
+!!write(*,*) 'tzjh runok',iniok(ipts,ivm,icirc)
+!!
+!!! compute needed local variable (otherwise need to set them as in/out)
+                stem_volume(ipts,ivm,icirc)=stem_volume_f(height(icirc),dbh(icirc))
+                root_volume(ipts,ivm,icirc)=root_volume_f(stem_volume(ipts,ivm,icirc), wood_density(ivm),root_shoot_ratio(ivm),root_density(ivm)) ! the volume of the root system
+                canopy_leaf_area(ipts,ivm,icirc) = canopy_leaf_area_f(dbh(icirc), sla_hydro(ivm))
+                grav_potential = grav_potential_f(height(icirc))
+
+                vxmax(icirc) = vxmax_f(stem_volume(ipts,ivm,icirc), w_density_stem(ivm))
+                vrmax(icirc) = vrmax_f(stem_volume(ipts,ivm,icirc), wood_density(ivm), root_shoot_ratio(ivm), rwc_root(ivm))
+                vmax_l(icirc) = vmax_l_f(dbh(icirc), LDMC(ivm)) * cut_limit
+!!WRITE(*,*)"vmax_l ", icirc,  vmax_l(icirc)
+!!WRITE(*,*)"vrmax ", vrmax(icirc)
+!!RITE(*,*)"LMDC ", icirc,  vmax_l(icirc)
+                !write(*,*) 'flag_flow 4'
+!
+                vx(ipts,ivm,icirc) = vxmax(icirc) + cxyl(ivm)*psi_stem(ipts,ivm,icirc)*stem_volume(ipts,ivm,icirc)*1000.*1000./18.
+                vr(ipts,ivm,icirc) = vrmax(icirc) + cr(ivm)*psi_root(ipts,ivm,icirc)*root_volume(ipts,ivm,icirc)*1000.*1000./18.
+                vl(ipts,ivm,icirc) = vmax_l(icirc) + cl(ivm)*psi_leaf(ipts,ivm,icirc)*canopy_leaf_area(ipts,ivm,icirc)
+!
+                !write(*,*) 'flag_flow 5'
+                kstem(icirc) = kstem_f(kmax_stem(ivm), P50_stem(ivm), a_stem(ivm), psi_stem(ipts,ivm,icirc))
+                kleaf(icirc) = kleaf_f(kmax_leaf(ivm), P50_leaf(ivm), a_leaf(ivm), psi_leaf(ipts,ivm,icirc))
+                kroot(icirc) = kroot_f(kmax_root(ivm), P50_root(ivm), a_root(ivm), psi_root(ipts,ivm,icirc))
+!
+!!WRITE(*,*)"stem_volume 2 ", icirc,  stem_volume(icirc)
+!!WRITE(*,*)"root_volume ", icirc,  root_volume(icirc)
+!!WRITE(*,*)" CAN_LA ", canopy_leaf_area(icirc)
+!!WRITE(*,*)" gravpot ", grav_potential(icirc)
+!!WRITE(*,*)"psi_root ", psi_root(ipts,ivm,icirc)
+!!WRITE(*,*)"psi_stem ", psi_stem(ipts,ivm,icirc)
+!!WRITE(*,*)"psi_leaf ", psi_leaf(ipts,ivm,icirc)
+!!WRITE(*,*)"kroot ", kroot(icirc)
+!!WRITE(*,*)"kstem ", kstem(icirc)
+!!WRITE(*,*)"kleaf ", kleaf(icirc)
+!!WRITE(*,*)"vx ", vx(ipts,ivm,icirc)
+!!WRITE(*,*)"vr ", vr(ipts,ivm,icirc)
+!!WRITE(*,*)"vl ", vl(ipts,ivm,icirc)
+!               ! added by yitong yao to solve the problem of jump in psi in the
+!               1st day of the year 
+                !DO m=1,ncirc
+                !       WRITE(part_str,'(I2)') m
+                !        IF (m < 10) part_str(1:1) = '0'
+                !        var_name = 'circ_class_n_'//part_str(1:LEN_TRIM(part_str))
+                !        CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            !&            circ_class_n(:,:,m), 'scatter', nbp_glo, index_g)
+             !   ENDDO
+
+
+                ! added by yitong yao Jan 30 18:00 
+!! 
+                gsh(ipts,ivm,icirc) = stomatal_conductance_hydro_f(gmax(ivm), light(ipts), klight, gpsi(ivm),psi_leaf(ipts,ivm,icirc),gpsi_50(ivm), gmin(ivm))
+!!!WRITE(*,*)"gsh ", icirc,  gsh(icirc)
+!
+                !write(*,*) 'flag_flow 6'
+                X(1)=psi_stem(ipts,ivm,icirc)
+!! parameters for leaf
+                PARS(1)=kmax_leaf(ivm);PARS(2)=P50_leaf(ivm);PARS(3)=a_leaf(ivm)
+                PARS(4)=kstem(icirc);PARS(5)=cl(ivm);PARS(6)=psi_leaf(ipts,ivm,icirc)
+                PARS(7)=psi_stem(ipts,ivm,icirc);PARS(8)=grav_potential(icirc);PARS(9)=gsh(ipts,ivm,icirc)
+                PARS(10)=VPD(ipts);PARS(11)=timestep;PARS(12)=canopy_leaf_area(ipts,ivm,icirc)
+!! parameters for stem
+                PARS(13)=kmax_stem(ivm);PARS(14)=P50_stem(ivm);PARS(15)=a_stem(ivm)
+                PARS(16)=kroot(icirc);PARS(17)=cxyl(ivm);PARS(18)=stem_volume(ipts,ivm,icirc)
+!! parameters for root
+                PARS(19)=kmax_root(ivm);PARS(20)=P50_root(ivm);PARS(21)=a_root(ivm)
+                PARS(22)=cr(ivm);PARS(23)=psi_root(ipts,ivm,icirc);PARS(24)=root_volume(ipts,ivm,icirc)
+                PARS(25)=phi_soilroot_circ(ipts,ivm,icirc);PARS(26)=vl(ipts,ivm,icirc)
+                PARS(27)=0
+!!!!!!!!!!!!!!print*,'IIIIIIIIII',PARS
+                CALL HYBRD1(FCN1,N,X,M,PARS,FVEC,limit,INFO)
+                  new_psi_leaf(icirc)=X(1)
+                   IF (new_psi_leaf(icirc) .LT. minpsi) THEN 
+                         new_psi_leaf(icirc)=minpsi
+                   ENDIF
+                  vdot_storage_leaf(ipts,ivm,icirc) = (cl(ivm)*(new_psi_leaf(icirc)-psi_leaf(ipts,ivm,icirc)))*canopy_leaf_area(ipts,ivm,icirc)
+                ! write(*,*) 'flag_flow 7'
+                 !write(*,*) 'vdot_storage_leaf_hybrd1',icirc,vdot_storage_leaf(ipts,ivm,icirc)
+                 !write(*,*) 'psi_leaf_hybrd1',icirc,psi_leaf(ipts,ivm,icirc)
+                 !write(*,*) 'new_psi_leaf_hybrd1',icirc,new_psi_leaf(icirc)
+                 IF ((vdot_storage_leaf(ipts,ivm,icirc) .LE. 0)  .AND. (vdot_storage_leaf(ipts,ivm,icirc) .LE. -1*vl(ipts,ivm,icirc) )) THEN
+!    print*,'FCN1_VL!!!!!!!!!!!!!!!!!!!!'
+                    CALL HYBRD1(FCN1_VL,N,X,M,PARS,FVEC,limit,INFO)
+                    new_psi_leaf(icirc)=X(1)
+                    IF (new_psi_leaf(icirc) .LT. minpsi) THEN 
+                        new_psi_leaf(icirc)=minpsi
+                    ENDIF
+                    vdot_storage_leaf(ipts,ivm,icirc) = (cl(ivm)*(new_psi_leaf(icirc)-psi_leaf(ipts,ivm,icirc)))*canopy_leaf_area(ipts,ivm,icirc)
+                   ! write(*,*) 'new_psi_leaf_if_hybrd1',icirc,new_psi_leaf(icirc)
+                   ! write(*,*) 'vdot_storage_leaf_if_hybrd1',icirc,vdot_storage_leaf(ipts,ivm,icirc)
+                ENDIF
+                ! added by yitong yao limit psi_leaf to -2.5 MPa here
+                !IF (new_psi_leaf(icirc) .LT. (-1*2.5)) THEN
+                !    new_psi_leaf(icirc) = -2.5
+                   ! vdot_storage_leaf(ipts,ivm,icirc)=0
+
+                !ENDIF
+                ! added by yitong yao above lines 2020 April 19 20:05
+
+                kupper(icirc) = kupper_f(kmax_leaf(ivm), P50_leaf(ivm), a_leaf(ivm),new_psi_leaf(icirc), kstem(icirc))
+                Et(ipts,ivm,icirc)=gsh(ipts,ivm,icirc)*(VPD(ipts)/atm)*canopy_leaf_area(ipts,ivm,icirc)*timestep
+                vdot_hydr_leaf(ipts,ivm,icirc) = (psi_stem(ipts,ivm,icirc) - new_psi_leaf(icirc) - grav_potential(icirc)/2)*kupper(icirc) *canopy_leaf_area(ipts,ivm,icirc)*timestep
+!  write(*,*) "diff leaf", icirc,FVEC,INFO,X,vdot_storage_leaf(icirc),-1*vl(ipts,ivm,icirc)
+!!!!!  write(*,*) "diff leaf", FVEC(:), FVEC(1:)
+                optileaf(ipts,ivm,icirc)=INFO
+                !write(*,*) 'flag_flow 8'
+                X(1)=psi_root(ipts,ivm,icirc)
+                PARS(27)=vdot_hydr_leaf(ipts,ivm,icirc)
+                CALL HYBRD1(FCN2,N,X,M,PARS,FVEC,limit,INFO)
+                new_psi_stem(icirc)=X(1)
+                IF (vertical_limit .EQ. 1) THEN 
+                 IF (new_psi_stem(icirc) .LT. new_psi_leaf(icirc)) THEN 
+                            new_psi_stem(icirc) = new_psi_leaf(icirc)
+                 ENDIF
+                ENDIF
+                vdot_storage_stem(ipts,ivm,icirc) = (cxyl(ivm)*(new_psi_stem(icirc) - psi_stem(ipts,ivm,icirc)))*stem_volume(ipts,ivm,icirc)*1000*1000/18
+                !write(*,*) 'vdot_storage_stem_hybrd1',icirc,vdot_storage_stem(icirc)
+                ! write(*,*) 'psi_stem_hybrd1',icirc,psi_stem(ipts,ivm,icirc)
+                ! write(*,*) 'new_psi_stem_hybrd1',icirc,new_psi_stem(icirc)
+                IF ((vdot_storage_stem(ipts,ivm,icirc) .LE. 0)  .AND. (vdot_storage_stem(ipts,ivm,icirc) .LE. -1*vl(ipts,ivm,icirc) )) THEN
+!    print*,'FCN2_VL!!!!!!!!!!!!!!!!!!!!'
+                    CALL HYBRD1(FCN2_VL,N,X,M,PARS,FVEC,limit,INFO)
+                    new_psi_stem(icirc)=X(1)
+                    IF (vertical_limit .EQ. 1) THEN 
+                         IF (new_psi_stem(icirc) .LT. new_psi_leaf(icirc)) THEN
+                         new_psi_stem(icirc)=new_psi_leaf(icirc) 
+                         ENDIF
+                    ENDIF
+                    vdot_storage_stem(ipts,ivm,icirc) = (cxyl(ivm)*(new_psi_stem(icirc) - psi_stem(ipts,ivm,icirc)))*stem_volume(ipts,ivm,icirc)*1000*1000/18    
+                   ! write(*,*) 'new_psi_stem_if_hybrd1',icirc,new_psi_stem(icirc)
+                   ! write(*,*) 'vdot_storage_stem_if_hybrd1',icirc,vdot_storage_stem(icirc) 
+                 ENDIF
+                ! above added 
+!!!!!!!!!!  !ktrunk(icirc)=1/((1/(2*kroot(icirc))) + (1/(2*kstem_f(kmax_stem(ivm), P50_stem(ivm), a_stem(ivm),new_psi_stem(icirc)))))
+!!!!!!!!!!  !vdot_hydr_stem(icirc) = (psi_root(ipts,ivm,icirc) - new_psi_stem(icirc) - grav_potential(icirc)/2)*ktrunk(icirc)*canopy_leaf_area(icirc)*timestep
+!  write(*,*) "diff stem", icirc,FVEC,INFO,X,vdot_storage_stem(icirc),-1*vl(ipts,ivm,icirc)
+!!!!!!!!!!!optistem(ipts,ivm,icirc)=INFO
+!
+                vdot_hydr_leaf_vert(ipts,ivm,icirc) = (new_psi_stem(icirc) - new_psi_leaf(icirc) - grav_potential(icirc)/2)*kupper(icirc)* canopy_leaf_area(ipts,ivm,icirc)*timestep
+
+                optistem(ipts,ivm,icirc)=INFO
+                ! added by yitong yao 2020 April 19 21:00
+                !IF (new_psi_stem(icirc) .LT. new_psi_leaf(icirc)) THEN 
+                !   new_psi_stem(icirc) = new_psi_leaf(icirc)
+                !   vdot_storage_stem(ipts,ivm,icirc) = (cxyl(ivm)*(new_psi_stem(icirc) - psi_stem(ipts,ivm,icirc)))*stem_volume(ipts,ivm,icirc)*1000*1000/18
+                !ENDIF 
+                ! above lines added by yitong yao 2020 April 19 20:59
+                kstem(icirc)=kstem_f(kmax_stem(ivm), P50_stem(ivm), a_stem(ivm), new_psi_stem(icirc)) 
+                ktrunk(icirc)=1/((1/(2*kroot(icirc))) + (1/(2*kstem(icirc))))
+                vdot_hydr_stem(ipts,ivm,icirc) = (psi_root(ipts,ivm,icirc) - new_psi_stem(icirc) - grav_potential(icirc)/2)*ktrunk(icirc)&
+            *canopy_leaf_area(ipts,ivm,icirc)*timestep
+!
+                X(1)=phi_soilroot_circ(ipts,ivm,icirc)
+                PARS(27)=vdot_hydr_stem(ipts,ivm,icirc)
+                CALL HYBRD1(FCN3,N,X,M,PARS,FVEC,limit,INFO)
+                new_psi_root(icirc)=X(1) 
+
+                IF (vertical_limit .EQ. 1) THEN 
+                ! added by yitong yao 2020 April 19 21:07 
+                 IF (new_psi_root(icirc) .LT. new_psi_stem(icirc))  THEN 
+                     new_psi_root(icirc) = new_psi_stem(icirc)
+                 ENDIF
+                ENDIF
+                ! added by yitong yao above lines 
+
+!  write(*,*) "diff root", icirc, FVEC,INFO,X
+!!!! Update water volume 
+!!!!!!!!!!!!!!!!!!!!!!!vdot_storage_leaf(icirc) = (cl(ivm)*(new_psi_leaf(icirc) - psi_leaf(ipts,ivm,icirc)))*canopy_leaf_area(icirc)
+                optiroot(ipts,ivm,icirc)=INFO
+                !write(*,*) 'flag_flow 10'
+                new_vl(icirc)=MAX(vl(ipts,ivm,icirc)+vdot_storage_leaf(ipts,ivm,icirc),zero)
+!!!!!!!!!!!!!!!WRITE(*,*) 'vl ', vl(ipts,ivm,icirc), new_vl(icirc), vdot_storage_leaf(icirc)
+!!!!!!!!!!!!!!!WRITE(*,*), 'vdot_storage_leaf test', cl(ivm),new_psi_leaf(icirc),psi_leaf(ipts,ivm,icirc),canopy_leaf_area(icirc)
+!!!!!!!!!!!!!!!!vdot_storage_stem(icirc) = (cxyl(ivm)*(new_psi_stem(icirc) - psi_stem(ipts,ivm,icirc)))*stem_volume(icirc)*1000*1000/18
+                new_vx(icirc)=MAX(vx(ipts,ivm,icirc)+vdot_storage_stem(ipts,ivm,icirc),zero)
+!!!!!!!!!!!!!!WRITE(*,*) 'vx ', vx(ipts,ivm,icirc), new_vx(icirc), vdot_storage_stem(icirc)
+!
+                kroot(icirc)=kroot_f(kmax_root(ivm), P50_root(ivm), a_root(ivm),new_psi_root(icirc))
+!!!!!!!!!!!!!!vdot_storage_root(icirc)=(phi_soilroot(ipts,ivm)-new_psi_root(icirc))*2*kroot(icirc)*canopy_leaf_area(icirc)*timestep
+                vdot_storage_root(ipts,ivm,icirc)=(cr(ivm)*root_volume(ipts,ivm,icirc)*1000*1000/18)*(new_psi_root(icirc)-psi_root(ipts,ivm,icirc))
+                !write(*,*) 'vdot_storage_root_hybrd1',icirc,vdot_storage_root(icirc)
+                ! write(*,*) 'psi_root_hybrd1',icirc,psi_root(ipts,ivm,icirc)
+                ! write(*,*) 'new_psi_root_hybrd1',icirc,new_psi_root(icirc)
+                !write(*,*) 'flag_flow 11'
+                new_vr(icirc)=MAX(vr(ipts,ivm,icirc)+vdot_storage_root(ipts,ivm,icirc),zero)
+!!!!!!!!!WRITE(*,*) 'vr ', vr(ipts,ivm,icirc), new_vr(icirc), vdot_storage_root(icirc)
+!!!WRITE(*,*), 'vdot_storage_root test',kroot(icirc), psi_soil(ivm), new_psi_root(icirc) 
+!
+!!! Set variable names for the next timestep
+                psi_leaf(ipts,ivm,icirc)=new_psi_leaf(icirc)
+                psi_stem(ipts,ivm,icirc)=new_psi_stem(icirc)
+                psi_root(ipts,ivm,icirc)=new_psi_root(icirc)
+!
+!
+!
+                vl(ipts,ivm,icirc)=new_vl(icirc)
+                vx(ipts,ivm,icirc)=new_vx(icirc)
+                vr(ipts,ivm,icirc)=new_vr(icirc)
+!
+                stem_plc(ipts,ivm,icirc)=100 - 100*kstem(icirc)/kmax_stem(ivm)
+                !write(*,*) 'stem_plc_hydrol',stem_plc(ipts,ivm,icirc)
+!!
+!!WRITE(*,*) 'test2 ', X(1)
+!!WRITE(*,*) 'testoutput', PARS(30)
+!!WRITE(*,*) 'stem_plc', kstem(icirc),stem_plc(ipts,ivm,icirc)
+!!WRITE(*,*)"psi_root end tstep ", psi_root(ipts,ivm,icirc)
+!!!WRITE(*,*)"psi_stem ", psi_stem(ipts,ivm,icirc)
+!!WRITE(*,*)"psi_leaf ", psi_leaf(ipts,ivm,icirc)
+!W!RITE(*,*)"kroot ", kroot(icirc)
+!!WRITE(*,*)"kstem ", kstem(icirc)
+!!WRITE(*,*)"kleaf ", kleaf(icirc)
+!
+                transpir_class(icirc)=gsh(ipts,ivm,icirc)*VPD(ipts)/atm*canopy_leaf_area(ipts,ivm,icirc)
+                tzj_supply(ipts,ivm,icirc)=transpir_class(icirc)*circ_class_n(ipts,ivm,icirc)*dtradia*1.8E-5
+               ! WRITE(*,*) "tzjRR circum ", icirc, " transpiration", transpir_class(icirc)
+       
+            ENDIF
+           ! write(numout,*) 'gsh mmol/m^2/s^-1', gsh(ipts,ivm,icirc)
+        ENDDO ! icirc ini
+
+
+!        write(*,*) 'gsh mmol/m^2/s^-1', gsh(ipts,icirc)
+!write(*,*) 'etzj mmol/s^-1', transpir_class(:)
+!write(*,*) 'hickler ', circ_class_transpir_supply(:)
+
+!!!!!!!!!!!!!transpir_tot =  SUM(transpir_class(:)* circ_class_n(ipts,ivm,:))*dtradia * 1.8E-5 
+        transpir_tot(ipts,ivm) =  SUM(transpir_class(:)* circ_class_n(ipts,ivm,:))*dtradia*1.8E-5 
+        !write(*,*) 'etzj3tot mm (kg/m^2 per dt-1)', transpir_tot(:,ivm)
+        !write(*,*) 'dtradia yyt', dtradia
+        !write(*,*) 'VPDyyt',VPD(ipts)
+          IF (supply_flag .EQ. 1) THEN
+             transpir_supply(ipts,ivm)=transpir_tot(ipts,ivm)
+          ENDIF
+!write(*,*) 'etzj3 mm (kg/m^2 per dt-1)', transpir_tot(:,ivm) 
+!write(*,*) 'etzj2', tmp
+!write(*,*) 'etzj3 mmol', transpir_tot
+!write(*,*) 'etzj3 mmol/m^2 de sol', transpir_tot
+!write(*,*) 'etzj3 mm (kg/m^2 per dt-1)', transpir_tot *1.8e-5
+
+!write(*,*) 'hickler2 ', transpir_supply(:,:)
+
+        ENDDO ! ivm for new hydraulic architecture
+ 
+       !write(*,*) 'etzj3tot mm (kg/m^2 per dt-1)', transpir_tot(:,ivm)
+     !ENDDO ! kjpindex
+
+  !   IF (ldrestart_write) THEN
+  !         DO icirc = 1,ncirc
+  !            !write(numout,*) 'fail put  psi_stem',icirc
+  !            !write(*,*) 'fail in put psi stem', icirc
+  !            WRITE(part_str,'(I2)') icirc
+  !            IF ( icirc < 10 ) part_str(1:1) = '0'
+  !            var_name = 'psi_stem_'//part_str(1:LEN_TRIM(part_str))
+  !            CALL restput_p(rest_id, var_name, nbp_glo,   nvm,1,kjit,psi_stem(:,:,icirc),'scatter',  nbp_glo, index_g)
+   !        ENDDO
+
+    !       DO icirc = 1,ncirc
+    !          WRITE(part_str,'(I2)') icirc
+    !          IF ( icirc < 10 ) part_str(1:1) = '0'
+    !          var_name = 'psi_leaf_'//part_str(1:LEN_TRIM(part_str))
+    !          CALL restput_p(rest_id, var_name, nbp_glo,   nvm,1,kjit,psi_leaf(:,:,icirc), 'scatter',  nbp_glo, index_g)
+     !      ENDDO
+
+      !     DO icirc = 1,ncirc
+      !        WRITE(part_str,'(I2)') icirc
+      !        IF ( icirc < 10 ) part_str(1:1) = '0'
+      !        var_name = 'psi_root_'//part_str(1:LEN_TRIM(part_str))
+      !        CALL restput_p(rest_id, var_name, nbp_glo,   nvm,1,kjit,psi_root(:,:,icirc),'scatter',  nbp_glo, index_g)
+      !     ENDDO
+     !ENDIF
+
+ ENDIF !flag ok_joetzjer_hydro 
+
+
+ENDDO ! kjpindexipts
+IF (ok_joetzjer_hydro) THEN
+IF (ldrestart_write) THEN
+           DO icirc = 1,ncirc
+              !write(numout,*) 'fail put  psi_stem',icirc
+              !write(*,*) 'fail in put psi stem', icirc
+              WRITE(part_str,'(I2)') icirc
+              IF ( icirc < 10 ) part_str(1:1) = '0'
+              var_name = 'psi_stem_'//part_str(1:LEN_TRIM(part_str))
+              CALL restput_p(rest_id, var_name, nbp_glo, nvm,1,kjit,psi_stem(:,:,icirc),'scatter',  nbp_glo, index_g)
+           ENDDO
+
+           DO icirc = 1,ncirc
+              WRITE(part_str,'(I2)') icirc
+              IF ( icirc < 10 ) part_str(1:1) = '0'
+              var_name = 'psi_leaf_'//part_str(1:LEN_TRIM(part_str))
+              CALL restput_p(rest_id, var_name, nbp_glo,nvm,1,kjit,psi_leaf(:,:,icirc), 'scatter',  nbp_glo, index_g)
+           ENDDO
+
+           DO icirc = 1,ncirc
+              WRITE(part_str,'(I2)') icirc
+              IF ( icirc < 10 ) part_str(1:1) = '0'
+              var_name = 'psi_root_'//part_str(1:LEN_TRIM(part_str))
+              CALL restput_p(rest_id, var_name, nbp_glo,nvm,1,kjit,psi_root(:,:,icirc),'scatter',  nbp_glo, index_g)
+           ENDDO
+     ENDIF
+ENDIF
+
+ !---TEMP---
+ IF (ld_hydrolarch) THEN
+    !WRITE(numout,*) 'transpir_supply, ', transpir_supply(:,:)
+    !WRITE(numout,*) 'vir_transpir_supply, ', vir_transpir_supply(:,:)
+ ENDIF
+ !----------
+
+
+IF ( ALLOCATED (nvan)) DEALLOCATE (nvan)
+IF ( ALLOCATED (avan)) DEALLOCATE (avan)
+IF ( ALLOCATED (mcr)) DEALLOCATE (mcr)
+IF ( ALLOCATED (mcs)) DEALLOCATE (mcs)
+
+!! ############################################################################
+!! Writing variables in Sechiba Outputs tzj
+     !write(numout,*) 'sechibahydrol::gsh=', gsh(1,2)
+     !write(numout,*) 'sechibahydrol::phi-soilroot=', phi_soilroot
+     CALL histwrite_p(hist_id, 'phi_soilroot', kjit, phi_soilroot, kjpindex*nvm, indexveg)
+     CALL histwrite_p(hist_id, 'transpir_tot_tzj', kjit, transpir_tot, kjpindex*nvm, indexveg)
+     !CALL histwrite_p(hist_id, 'gsh', kjit, gsh, kjpindex*nvm, indexveg)
+     
+     VPD_tzj=VPD
+     CALL histwrite_p(hist_id, 'VPD_tzj', kjit, VPD_tzj, kjpindex, indexveg)
+     !write(numout,*) 'vpd_right'
+  DO jst=1,nstm
+        !  var_name= phi_soil_1" ... "phi_soil_3"
+     WRITE (var_name,"('phi_soil_',i1)") jst
+     CALL histwrite_p(hist_id, trim(var_name), kjit,phi_soil(:,:,jst),kjpindex*nslm, indexlayer)
+  ENDDO
+     !write(numout,*) 'right 2'
+ IF (rsoilroot) THEN
+
+!DO jst=1,nstm
+        ! var_name= phi_soil_1" ... "phi_soil_3"
+     jst=2
+     WRITE (var_name,"('res_soil_',i1)") jst
+     CALL histwrite_p(hist_id, trim(var_name), kjit,res_soil(:,:,jst),kjpindex*nslm, indexlayer)
+
+ !    WRITE (var_name,"('ksave_',i1)") jst
+ !    CALL histwrite_p(hist_id, trim(var_name), kjit, ksave(:,:,jst),kjpindex*nslm, indexlayer)
+!
+     jst=2
+     WRITE (var_name,"('e_max_',i1)") jst
+     CALL histwrite_p(hist_id, trim(var_name), kjit, e_max(:,:,jst),kjpindex*nslm, indexlayer)
+!
+     CALL histwrite_p(hist_id, 'e_frac_2', kjit, e_frac(:,:,2),kjpindex*nslm, indexlayer)
+ END IF 
+
+IF (ok_joetzjer_hydro) THEN 
+  DO icirc = 1,tmp_ncirc
+
+    WRITE (var_name,"('PHI_soilroot_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, phi_soilroot_circ(:,:,icirc),kjpindex*nvm,indexveg)
+    
+    WRITE (var_name,"('PSLeaf_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, psi_leaf(:,:,icirc),kjpindex*nvm,indexveg)
+!
+    WRITE (var_name,"('tzj_gsh_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, gsh(:,:,icirc),kjpindex*nvm,indexveg)
+        
+    WRITE (var_name,"('tzj_supply_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, tzj_supply(:,:,icirc),kjpindex*nvm,indexveg)
+
+    WRITE (var_name,"('PSStem_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, psi_stem(:,:,icirc),kjpindex*nvm,indexveg)
+!
+    WRITE (var_name,"('PSRoot_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, psi_root(:,:,icirc),kjpindex*nvm,indexveg)
+!
+    WRITE (var_name,"('stemPLC_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, stem_plc(:,:,icirc),kjpindex*nvm,indexveg)
+!
+    WRITE (var_name,"('vl_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, vl(:,:,icirc),kjpindex*nvm,indexveg)
+!
+    WRITE (var_name,"('vx_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, vx(:,:,icirc),kjpindex*nvm,indexveg)
+!
+    WRITE (var_name,"('vr_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, vr(:,:,icirc),kjpindex*nvm,indexveg)
+!
+    WRITE (var_name,"('optileaf_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, optileaf(:,:,icirc),kjpindex*nvm,indexveg)
+! 
+    WRITE (var_name,"('v_storage_leaf_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, vdot_storage_leaf(:,:,icirc),kjpindex*nvm,indexveg)
+    
+    WRITE (var_name,"('v_hydr_leaf_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, vdot_hydr_leaf(:,:,icirc),kjpindex*nvm,indexveg)
+   
+    WRITE (var_name,"('v_hydr_leaf_vert_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, vdot_hydr_leaf_vert(:,:,icirc),kjpindex*nvm,indexveg)
+
+ 
+    WRITE (var_name,"('v_storage_stem_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, vdot_storage_stem(:,:,icirc),kjpindex*nvm,indexveg)
+
+    WRITE (var_name,"('v_hydr_stem_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit,vdot_hydr_stem(:,:,icirc),kjpindex*nvm,indexveg)
+    
+    WRITE (var_name,"('v_storage_root_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, vdot_storage_root(:,:,icirc),kjpindex*nvm,indexveg)
+
+
+    WRITE (var_name,"('tzj_Et_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, Et(:,:,icirc),kjpindex*nvm,indexveg)
+
+    WRITE (var_name,"('tzj_stem_volume_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, stem_volume(:,:,icirc),kjpindex*nvm,indexveg)
+
+    WRITE (var_name,"('tzj_root_volume_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, root_volume(:,:,icirc),kjpindex*nvm,indexveg)
+
+    WRITE (var_name,"('tzj_canopy_LAI_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, canopy_leaf_area(:,:,icirc),kjpindex*nvm,indexveg)
+
+
+    WRITE (var_name,"('optistem_',i3.3)") icirc
+    CALL histwrite_p(hist_id, var_name, kjit, optistem(:,:,icirc),kjpindex*nvm,indexveg)
+!
+    !WRITE (var_name,"('optiroot_',i3.3)") icirc
+    !CALL histwrite_p(hist_id, var_name, kjit, optiroot(:,:,icirc),kjpindex*nvm,indexveg)
+        !write(numout,*) 'write right in loop'
+    ENDDO
+ENDIF
+    !write(numout,*) 'write right'
+
+
+!! ############################################################################
+
+
+END SUBROUTINE hydrol_arch
+
+SUBROUTINE FCN1(N,X,M,PARS,FVEC,INFO)
+  USE pft_parameters
+  IMPLICIT NONE
+  INTEGER(i_std) :: N,M,INFO
+  REAL(r_std)    :: X(N), FVEC(N), PARS(M)
+  REAL(r_std)    :: inew_psi_leaf, &
+                    ikmax_leaf, iP50_leaf, ia_leaf, ikstem, &
+                    icl, ipsi_leaf, ipsi_stem, igrav_potential, &
+                    igsh, iVPD, timestep, icanopy_leaf_area, &
+                    ivl, &
+                    Et, ikupper, vdot_storage_leaf, vdot_hydr_leaf                  
+                      
+  REAL(r_std)    :: atm = 101.3            ! atmospheric pressure, kPa  
+  inew_psi_leaf=X(1)
+  ! parameters for leaf
+  ikmax_leaf=PARS(1);iP50_leaf=PARS(2);ia_leaf=PARS(3)
+  ikstem=PARS(4);icl=PARS(5);ipsi_leaf=PARS(6)
+  ipsi_stem=PARS(7);igrav_potential=PARS(8);igsh=PARS(9)
+  iVPD=PARS(10);timestep=PARS(11);icanopy_leaf_area=PARS(12)
+  ! parameters for stem
+ ! ikmax_stem=PARS(13); iP50_stem=PARS(14);  ia_stem=PARS(15)
+ ! ikroot=PARS(16);  icxyl=PARS(17);  istem_volume=PARS(18)
+  ! parameters for root
+ ! ikmax_root=PARS(19); iP50_root=PARS(20);  ia_root=PARS(21)
+ ! icr=PARS(22);  ipsi_root=PARS(23);  iroot_volume=PARS(24)
+ ! ipsi_soil=PARS(25)
+ ! ivl=PARS(26)
+  ! parameters optimized before this loop
+  ! none here, but some for stem and root
+
+
+  ! leaf 
+  ikupper = kupper_f(ikmax_leaf, iP50_leaf, ia_leaf, inew_psi_leaf, ikstem)
+  Et=igsh*(iVPD/atm)*icanopy_leaf_area*timestep
+  vdot_storage_leaf = (icl*(inew_psi_leaf - ipsi_leaf))*icanopy_leaf_area
+  vdot_hydr_leaf = (ipsi_stem - inew_psi_leaf - igrav_potential/2)*ikupper&
+                      *icanopy_leaf_area*timestep
+!  print*, 'wyl check1.0~~~~~~~~~~',ikmax_leaf,iP50_leaf,ia_leaf,ikstem
+!  print*, 'wyl check1.1~~~~~~~~~~',ikupper,Et,vdot_storage_leaf,vdot_hydr_leaf
+!  print*, 'wyl check1.2~~~~~~~~~~',ivl,icl,inew_psi_leaf,ipsi_leaf
+!  print*, 'wyl check1.3~~~~~~~~~~',ipsi_stem,igrav_potential,icanopy_leaf_area,timestep
+!  IF ((vdot_storage_leaf .LT. 0)  .AND. (vdot_storage_leaf .LT. -1*ivl )) THEN
+!    vdot_storage_leaf = -1*ivl
+!  ENDIF
+  FVEC(1) = Et-(vdot_hydr_leaf-vdot_storage_leaf)
+!  print*, 'wyl check1.4~~~~~~~~~~',FVEC(1)
+END SUBROUTINE FCN1
+
+SUBROUTINE FCN1_VL(N,X,M,PARS,FVEC,INFO)
+  USE pft_parameters
+  IMPLICIT NONE
+  INTEGER(i_std) :: N,M,INFO
+  REAL(r_std)    :: X(N), FVEC(N), PARS(M)
+  REAL(r_std)    :: inew_psi_leaf, &
+                    ikmax_leaf, iP50_leaf, ia_leaf, ikstem, &
+                    icl, ipsi_leaf, ipsi_stem, igrav_potential, &
+                    igsh, iVPD, timestep, icanopy_leaf_area, &
+                    ivl, &
+                    Et, ikupper, vdot_storage_leaf, vdot_hydr_leaf
+                      
+  REAL(r_std)    :: atm = 101.3            ! atmospheric pressure, kPa  
+  inew_psi_leaf=X(1)
+  ! parameters for leaf
+  ikmax_leaf=PARS(1);iP50_leaf=PARS(2);ia_leaf=PARS(3)
+  ikstem=PARS(4);icl=PARS(5);ipsi_leaf=PARS(6)
+  ipsi_stem=PARS(7);igrav_potential=PARS(8);igsh=PARS(9)
+  iVPD=PARS(10);timestep=PARS(11);icanopy_leaf_area=PARS(12)
+  ! parameters for stem
+ ! ikmax_stem=PARS(13);iP50_stem=PARS(14);ia_stem=PARS(15)
+ ! ikroot=PARS(16);icxyl=PARS(17);istem_volume=PARS(18)
+  ! parameters for root
+ ! ikmax_root=PARS(19);iP50_root=PARS(20);ia_root=PARS(21)
+ ! icr=PARS(22);ipsi_root=PARS(23);iroot_volume=PARS(24)
+ ! ipsi_soil=PARS(25)
+  ivl=PARS(26)
+  ! parameters optimized before this loop
+  ! none here, but some for stem and root
+
+  ! leaf 
+  ikupper = kupper_f(ikmax_leaf, iP50_leaf, ia_leaf, inew_psi_leaf, ikstem)
+  Et=igsh*(iVPD/atm)*icanopy_leaf_area*timestep
+  vdot_storage_leaf = -1*ivl
+  vdot_hydr_leaf = (ipsi_stem - inew_psi_leaf - igrav_potential/2)*ikupper&
+                      *icanopy_leaf_area*timestep
+  FVEC(1) = Et-(vdot_hydr_leaf-vdot_storage_leaf)
+END SUBROUTINE FCN1_VL
+
+
+
+SUBROUTINE FCN1_VL0(N,X,M,PARS,FVEC,INFO)
+  USE pft_parameters
+  IMPLICIT NONE
+  INTEGER(i_std) :: N,M,INFO
+  REAL(r_std)    :: X(N), FVEC(N), PARS(M)
+  REAL(r_std)    :: inew_psi_leaf, &
+                    ikmax_leaf, iP50_leaf, ia_leaf, ikstem, &
+                    icl, ipsi_leaf, ipsi_stem, igrav_potential, &
+                    igsh, iVPD, timestep, icanopy_leaf_area, &
+                    ivl, &
+                    Et, ikupper, vdot_storage_leaf, vdot_hydr_leaf
+                      
+  REAL(r_std)    :: atm = 101.3            ! atmospheric pressure, kPa  
+  inew_psi_leaf=X(1)
+  ! parameters for leaf
+  ikmax_leaf=PARS(1);iP50_leaf=PARS(2);ia_leaf=PARS(3)
+  ikstem=PARS(4);icl=PARS(5);ipsi_leaf=PARS(6)
+  ipsi_stem=PARS(7);igrav_potential=PARS(8);igsh=PARS(9)
+  iVPD=PARS(10);timestep=PARS(11);icanopy_leaf_area=PARS(12)
+  ! parameters for stem
+ ! ikmax_stem=PARS(13);iP50_stem=PARS(14);ia_stem=PARS(15)
+ ! ikroot=PARS(16);icxyl=PARS(17);istem_volume=PARS(18)
+  ! parameters for root
+ ! ikmax_root=PARS(19);iP50_root=PARS(20);ia_root=PARS(21)
+ ! icr=PARS(22);ipsi_root=PARS(23);iroot_volume=PARS(24)
+ ! ipsi_soil=PARS(25)
+  ivl=PARS(26)
+  ! parameters optimized before this loop
+  ! none here, but some for stem and root
+
+  ! leaf 
+  ikupper = kupper_f(ikmax_leaf, iP50_leaf, ia_leaf, inew_psi_leaf, ikstem)
+  Et=igsh*(iVPD/atm)*icanopy_leaf_area*timestep
+  !vdot_storage_leaf = -1*ivl
+  vdot_storage_leaf = 0
+  vdot_hydr_leaf = (ipsi_stem - inew_psi_leaf - igrav_potential/2)*ikupper&
+                      *icanopy_leaf_area*timestep
+  FVEC(1) = Et-(vdot_hydr_leaf-vdot_storage_leaf)
+END SUBROUTINE FCN1_VL0
+
+SUBROUTINE FCN2(N,X,M,PARS,FVEC,INFO)
+  USE pft_parameters
+  IMPLICIT NONE
+  INTEGER(i_std) :: N,M,INFO
+  REAL(r_std)    :: X(N), FVEC(N), PARS(M)
+  REAL(r_std)    :: inew_psi_stem, &
+                    ipsi_stem, igrav_potential, &
+                    timestep, icanopy_leaf_area, &
+                    ikmax_stem, iP50_stem, ia_stem, &
+                    ikroot, icxyl, istem_volume, &
+                    ipsi_root, ivl, &
+                    iktrunk, vdot_storage_stem, vdot_hydr_stem, &
+                    inew_kstem,ivdot_hydr_up
+                      
+  REAL(r_std)    :: atm = 101.3            ! atmospheric pressure, kPa  
+  inew_psi_stem=X(1)
+  ! parameters for leaf
+!  ikmax_leaf=PARS(1);iP50_leaf=PARS(2);ia_leaf=PARS(3)
+!  ikstem=PARS(4);icl=PARS(5);ipsi_leaf=PARS(6)
+  ipsi_stem=PARS(7);igrav_potential=PARS(8)
+!  igsh=PARS(9)
+!  iVPD=PARS(10)
+  timestep=PARS(11);icanopy_leaf_area=PARS(12)
+  ! parameters for stem
+  ikmax_stem=PARS(13);iP50_stem=PARS(14);ia_stem=PARS(15)
+  ikroot=PARS(16);icxyl=PARS(17);istem_volume=PARS(18)
+  ! parameters for root
+!  ikmax_root=PARS(19);iP50_root=PARS(20);ia_root=PARS(21)
+!  icr=PARS(22);
+  ipsi_root=PARS(23)
+!  iroot_volume=PARS(24)
+!  ipsi_soil=PARS(25)
+  ivl=PARS(26)
+  ! parameters optimized before this loop
+  ivdot_hydr_up=PARS(27)
+
+  ! stem
+  inew_kstem=kstem_f(ikmax_stem, iP50_stem, ia_stem, inew_psi_stem) 
+  iktrunk=1/((1/(2*ikroot)) + (1/(2*inew_kstem)))
+
+  vdot_storage_stem = (icxyl*(inew_psi_stem - ipsi_stem))*istem_volume*1000*1000/18
+  vdot_hydr_stem = (ipsi_root - inew_psi_stem - igrav_potential/2)*iktrunk&
+                      *icanopy_leaf_area*timestep
+!  print*,'wyl check1.0',ikmax_stem,iP50_stem,ia_stem,inew_psi_stem
+!  print*,'wyl check1.1',inew_kstem,ikroot,iktrunk
+!  print*,'wyl check1.2',icxyl,ipsi_stem,istem_volume
+!  print*,'wyl check1.3',ipsi_root,igrav_potential,icanopy_leaf_area
+!  print*,'wyl check1.4',vdot_storage_stem,vdot_hydr_stem,ivl,ivdot_hydr_up
+!  IF ((vdot_storage_stem .LT. 0)  .AND. (vdot_storage_stem .LT. -1*ivl)) THEN
+!    vdot_storage_stem = -1*ivl
+!  ENDIF
+  FVEC(1) = ivdot_hydr_up-(vdot_hydr_stem-vdot_storage_stem)
+!  print*,'wyl check1.5',FVEC
+END SUBROUTINE FCN2
+
+SUBROUTINE FCN2_VL(N,X,M,PARS,FVEC,INFO)
+  USE pft_parameters
+  IMPLICIT NONE
+  INTEGER(i_std) :: N,M,INFO
+  REAL(r_std)    :: X(N), FVEC(N), PARS(M)
+  REAL(r_std)    :: inew_psi_stem, &
+                    ipsi_stem, igrav_potential, &
+                    timestep, icanopy_leaf_area, &
+                    ikmax_stem, iP50_stem, ia_stem, &
+                    ikroot, icxyl, istem_volume, &
+                    ipsi_root, ivl, &
+                    iktrunk, vdot_storage_stem, vdot_hydr_stem, &
+                    inew_kstem,ivdot_hydr_up
+                      
+  REAL(r_std)    :: atm = 101.3            ! atmospheric pressure, kPa  
+  inew_psi_stem=X(1)
+  ! parameters for leaf
+!  ikmax_leaf=PARS(1);iP50_leaf=PARS(2);ia_leaf=PARS(3)
+!  ikstem=PARS(4);icl=PARS(5);ipsi_leaf=PARS(6)
+  ipsi_stem=PARS(7);igrav_potential=PARS(8)
+!  igsh=PARS(9)
+!  iVPD=PARS(10)
+  timestep=PARS(11);icanopy_leaf_area=PARS(12)
+  ! parameters for stem
+  ikmax_stem=PARS(13);iP50_stem=PARS(14);ia_stem=PARS(15)
+  ikroot=PARS(16);icxyl=PARS(17);istem_volume=PARS(18)
+  ! parameters for root
+!  ikmax_root=PARS(19);iP50_root=PARS(20);ia_root=PARS(21)
+!  icr=PARS(22);
+  ipsi_root=PARS(23)
+!  iroot_volume=PARS(24)
+!  ipsi_soil=PARS(25)
+  ivl=PARS(26)
+  ! parameters optimized before this loop
+  ivdot_hydr_up=PARS(27)
+
+  ! stem
+  inew_kstem=kstem_f(ikmax_stem, iP50_stem, ia_stem, inew_psi_stem) 
+  iktrunk=1/((1/(2*ikroot)) + (1/(2*inew_kstem)))
+
+  vdot_storage_stem = -1*ivl
+  vdot_hydr_stem = (ipsi_root - inew_psi_stem - igrav_potential/2)*iktrunk&
+                      *icanopy_leaf_area*timestep
+  FVEC(1) = ivdot_hydr_up-(vdot_hydr_stem-vdot_storage_stem)
+END SUBROUTINE FCN2_VL
+
+SUBROUTINE FCN3(N,X,M,PARS,FVEC,INFO)
+  USE pft_parameters
+  IMPLICIT NONE
+  INTEGER(i_std) :: N,M,INFO
+  REAL(r_std)    :: X(N), FVEC(N), PARS(M)
+  REAL(r_std)    :: inew_psi_root, &
+                    timestep, icanopy_leaf_area,&
+                    ikmax_root, iP50_root, ia_root, &
+                    icr, ipsi_root, iroot_volume, &
+                    inew_kroot, vdot_storage_root, &
+                    vdot_hydr_root, ipsi_soil, ivdot_hydr_up
+                      
+  REAL(r_std)    :: atm = 101.3            ! atmospheric pressure, kPa  
+  inew_psi_root=X(1)
+  ! parameters for leaf
+!  ikmax_leaf=PARS(1);iP50_leaf=PARS(2);ia_leaf=PARS(3)
+!  ikstem=PARS(4);icl=PARS(5);ipsi_leaf=PARS(6)
+!  ipsi_stem=PARS(7);igrav_potential=PARS(8);igsh=PARS(9)
+!  iVPD=PARS(10)
+  timestep=PARS(11);icanopy_leaf_area=PARS(12)
+!  ! parameters for stem
+!  ikmax_stem=PARS(13);iP50_stem=PARS(14);ia_stem=PARS(15)
+!  ikroot=PARS(16);icxyl=PARS(17);istem_volume=PARS(18)
+  ! parameters for root
+  ikmax_root=PARS(19);iP50_root=PARS(20);ia_root=PARS(21)
+  icr=PARS(22);ipsi_root=PARS(23);iroot_volume=PARS(24)
+  ipsi_soil=PARS(25)
+!  ivl=PARS(26)
+  ! parameters optimized before this loop
+  ivdot_hydr_up=PARS(27)
+
+ ! root
+  inew_kroot= kroot_f(ikmax_root, iP50_root, ia_root, inew_psi_root)
+  vdot_hydr_root=(ipsi_soil-inew_psi_root)*2*inew_kroot&
+                      *icanopy_leaf_area*timestep
+  vdot_storage_root=(icr*iroot_volume*1000*1000/18)*(inew_psi_root-ipsi_root)
+!  print*,'wyl check1.0',ikmax_root,iP50_root,ia_root,inew_psi_root
+!  print*,'wyl check1.1',inew_kroot,ipsi_soil,icanopy_leaf_area
+!  print*,'wyl check1.2',icr,iroot_volume
+!  print*,'wyl check1.3',ivdot_hydr_up,vdot_storage_root,vdot_hydr_root
+  FVEC(1) = ivdot_hydr_up-(vdot_hydr_root-vdot_storage_root)
+!  print*,'wyl check1.4',FVEC
+END SUBROUTINE FCN3
+  
+
+!! ==============================================================================================================================
+!! SUBROUTINE   : jdiffuco_trans_co2
+!!
+!>\BRIEF        This subroutine computes carbon assimilation and stomatal 
+!! conductance, following respectively Farqhuar et al. (1980) and Ball et al. (1987).
+!!
+!! DESCRIPTION  :\n
+!! *** General:\n 
+!! The equations are different depending on the photosynthesis mode (C3 versus C4).\n 
+!! Assimilation and conductance are computed over 20 levels of LAI and then 
+!! integrated at the canopy level.\n 
+!! This routine also computes partial beta coefficient: transpiration for each 
+!! type of vegetation.\n
+!! There is a main loop on the PFTs, then inner loops on the points where 
+!! assimilation has to be calculated.\n
+!! This subroutine is called by diffuco_main only if photosynthesis is activated
+!! for sechiba (flag STOMATE_OK_CO2=TRUE), otherwise diffuco_trans is called.\n
+!! This subroutine is called at each sechiba time step by sechiba_main.\n
+!! *** Details:
+!! - Integration at the canopy level\n
+!! \latexonly
+!! \input{diffuco_trans_co2_1.1.tex}
+!! \endlatexonly
+!! - Light''s extinction \n
+!! The available light follows a simple Beer extinction law. 
+!! The extinction coefficients (ext_coef) are PFT-dependant constants and are defined in constant_co2.f90.\n
+!! \latexonly
+!! \input{diffuco_trans_co2_1.2.tex}
+!! \endlatexonly
+!! - Estimation of relative humidity of air (for calculation of the stomatal conductance)\n
+!! \latexonly
+!! \input{diffuco_trans_co2_1.3.tex}
+!! \endlatexonly
+!! - Calculation of the water limitation factor\n
+!! \latexonly
+!! \input{diffuco_trans_co2_2.1.tex}
+!! \endlatexonly
+!! - Calculation of temperature dependent parameters for C4 plants\n
+!! \latexonly
+!! \input{diffuco_trans_co2_2.2.tex}
+!! \endlatexonly
+!! - Calculation of temperature dependent parameters for C3 plants\n
+!! \latexonly
+!! \input{diffuco_trans_co2_2.3.tex}
+!! \endlatexonly
+!! - Vmax scaling\n 
+!! Vmax is scaled into the canopy due to reduction of nitrogen 
+!! (Johnson and Thornley,1984).\n
+!! \latexonly
+!! \input{diffuco_trans_co2_2.4.1.tex}
+!! \endlatexonly
+!! - Assimilation for C4 plants (Collatz et al., 1992)\n
+!! \latexonly
+!! \input{diffuco_trans_co2_2.4.2.tex}
+!! \endlatexonly         
+!! - Assimilation for C3 plants (Farqhuar et al., 1980)\n
+!! \latexonly
+!! \input{diffuco_trans_co2_2.4.3.tex}
+!! \endlatexonly
+!! - Estimation of the stomatal conductance (Ball et al., 1987)\n
+!! \latexonly
+!! \input{diffuco_trans_co2_2.4.4.tex}
+!! \endlatexonly
+!!
+!! RECENT CHANGE(S): N. de Noblet          2006/06
+!!                - addition of q2m and t2m as input parameters for the 
+!!                calculation of Rveget
+!!                - introduction of vbeta23
+!!
+!! MAIN OUTPUT VARIABLE(S): beta coefficients, resistances, CO2 intercellular 
+!! concentration
+!!
+!! REFERENCE(S) :
+!! - Ball, J., T. Woodrow, and J. Berry (1987), A model predicting stomatal 
+!! conductance and its contribution to the control of photosynthesis under 
+!! different environmental conditions, Prog. Photosynthesis, 4, 221â 224.
+!! - Collatz, G., M. Ribas-Carbo, and J. Berry (1992), Coupled photosynthesis 
+!! stomatal conductance model for leaves of C4 plants, Aust. J. Plant Physiol.,
+!! 19, 519â538.
+!! - Farquhar, G., S. von Caemmener, and J. Berry (1980), A biochemical model of 
+!! photosynthesis CO2 fixation in leaves of C3 species, Planta, 149, 78â90.
+!! - Johnson, I. R., and J. Thornley (1984), A model of instantaneous and daily
+!! canopy photosynthesis, J Theor. Biol., 107, 531 545
+!! - McMurtrie, R.E., Rook, D.A. and Kelliher, F.M., 1990. Modelling the yield of Pinus radiata on a
+!! site limited by water and nitrogen. For. Ecol. Manage., 30: 381-413
+!! - Yin, X. and Struik, P. C., 2009. C3 and C4 photosynthesis models: An overview from the perspective
+!!   of crop modelling, NJAS - Wageningen Journal of Life Sciences, 57, 27--38.
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE jdiffuco_trans_co2 (kjpindex, dtradia, swdown, temp_sol, pb, qsurf, q2m, t2m, &
+                                temp_growth, rau, u, v, q_cdrag, vegstress, &
+                                assim_param, Ca, &
+                                veget_max, lai, qsintveg, qsintmax, vbeta3, vbeta3pot, rveget, rstruct, &
+                                cimean, gsmean, gpp, vbeta23, Isotrop_Abs_Tot_p,&
+                                Isotrop_Tran_Tot_p, lai_per_level, new_leaf_ci, &
+                                hydrol_flag2, hydrol_flag3, gs_distribution, &
+                                gs_diffuco_output, james_netcdf_flag, gstot_component, gstot_frac, warnings, veget, biomass)
+
+    !
+    !! 0. Variable and parameter declaration
+    !
+
+    !
+    !! 0.1 Input variables
+    !
+    INTEGER(i_std), INTENT(in)                               :: kjpindex         !! Domain size (unitless)
+    REAL(r_std), INTENT (in)                                 :: dtradia          !! Time step (s)
+    REAL(r_std),DIMENSION (:), INTENT (in)                   :: swdown           !! Downwelling short wave flux 
+                                                                                 !! @tex ($W m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION (:), INTENT (in)                   :: temp_sol         !! Skin temperature (K)
+    REAL(r_std),DIMENSION (:), INTENT (in)                   :: pb               !! Lowest level pressure (hPa)
+    REAL(r_std),DIMENSION (:), INTENT (in)                   :: qsurf            !! Near surface specific humidity 
+                                                                                 !! @tex ($kg kg^{-1}$) @endtex
+! N. de Noblet - 2006/06 - addition of q2m and t2m
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q2m              !! 2m specific humidity 
+                                                                                 !! @tex ($kg kg^{-1}$) @endtex
+! In off-line mode q2m and qair are the same.
+! In off-line mode t2m and temp_air are the same.
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: t2m              !! 2m air temperature (K)
+! N. de Noblet - 2006/06 - addition of q2m and t2m
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_growth      !! Growth temperature (Â°C) - Is equal to t2m_month
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: rau              !! air density @tex ($kg m^{-3}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u                !! Lowest level wind speed 
+                                                                                 !! @tex ($m s^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: v                !! Lowest level wind speed 
+                                                                                 !! @tex ($m s^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q_cdrag          !! Surface drag 
+                                                                                 !! @tex ($m s^{-1}$) @endtex
+    REAL(r_std),DIMENSION (:,:,:), INTENT (in)               :: assim_param      !! min+max+opt temps (K), vcmax, vjmax for 
+                                                                                 !! photosynthesis 
+                                                                                 !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: Ca               !! CO2 concentration inside the canopy
+                                                                                 !! @tex ($\mu mol mol^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: vegstress        !! Soil moisture stress (0-1,unitless) 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: veget_max        !! Maximum vegetation fraction of each PFT inside 
+                                                                                 !! the grid box (0-1, unitless) 
+    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 @tex ($m^2 m^{-2}$) @endtex
+                                                                                 !! @tex ($m s^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: qsintveg         !! Water on vegetation due to interception 
+                                                                                 !! @tex ($kg m^{-2}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: qsintmax         !! Maximum water on vegetation
+                                                                                 !! @tex ($kg m^{-2}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: vbeta23          !! Beta for fraction of wetted foliage that will 
+                                                                                 !! transpire (unitless) 
+    REAL(r_std),DIMENSION (:,:,:), INTENT (in)               :: Isotrop_Abs_Tot_p !! Absorbed radiation per level for photosynthesis
+    REAL(r_std),DIMENSION (:,:,:), INTENT (in)               :: Isotrop_Tran_Tot_p !! Absorbed radiation per level for photosynthesis
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)                :: lai_per_level    !! This is the LAI per vertical level
+                                                                                 !! @tex $(m^{2} m^{-2})$
+                                                                                     
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(in)              :: biomass          !! Stand level biomass @tex $(gC m^{-2})$ @endtex
+
+    LOGICAL, DIMENSION (kjpindex), INTENT (in)               :: hydrol_flag2     !! flag that 'trips' the alternative energy budget for each grid square
+    LOGICAL, DIMENSION (kjpindex, nvm), INTENT (in)          :: hydrol_flag3     !! flag that 'trips' the alternative energy budget for each grid square
+    REAL(r_Std),DIMENSION (kjpindex,nvm,nlevels_tot), INTENT (in)        :: gs_distribution
+    REAL(r_std),DIMENSION (kjpindex,nvm,nlevels_tot), INTENT (in)        :: gs_diffuco_output
+    REAL(r_Std),DIMENSION (kjpindex,nvm,nlevels_tot), INTENT (in)        :: gstot_component
+    REAL(r_Std),DIMENSION (kjpindex,nvm,nlevels_tot), INTENT (in)        :: gstot_frac    
+
+
+    LOGICAL, INTENT(in)                                     :: james_netcdf_flag !! Flag that controls the netCDF output routine
+
+
+    !
+    !! 0.2 Output variables
+    
+    !! 0.3 Modified variables
+    ! JR these are all defined as inout variables as we skip over PFTs and grid squares for which the hydrol stress constraint
+    !       does not apply. We can to use the values the values previously calculated (within diffuco) for these cases.
+    !
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)       :: vbeta3         !! Beta for Transpiration (unitless)
+
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)       :: vbeta3pot      !! Beta for Potential Transpiration
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)       :: rveget         !! stomatal resistance of vegetation 
+                                                                                 !! @tex ($s m^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)       :: rstruct        !! structural resistance @tex ($s m^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)       :: cimean         !! mean intercellular CO2 concentration 
+                                                                                 !! @tex ($\mu mol mol^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)       :: gsmean         !! mean stomatal conductance to CO2 (umol m-2 s-1)
+    REAL(r_Std),DIMENSION (kjpindex,nvm), INTENT (inout)       :: gpp            !! Assimilation ((gC m^{-2} s^{-1}), total area)
+    REAL(r_std),DIMENSION(kjpindex,nvm,nwarns), INTENT(inout)  :: warnings       !! A warning counter
+    !
+    !
+    REAL(r_std), DIMENSION (kjpindex,nvm,nlai)  :: new_leaf_ci                   !! intercellular CO2 concentration (ppm)
+    !
+    !! 0.4 Local variables
+    !
+    REAL(r_std), DIMENSION(kjpindex, nvm)                                :: coupled_lai
+    REAL(r_std), DIMENSION(kjpindex, nvm)                                :: total_lai
+      
+    REAL(r_Std),DIMENSION (kjpindex,nvm,nlevels_tot)                     :: gs_output
+    REAL(r_Std),DIMENSION (kjpindex,nvm,nlevels_tot)                     :: gstot_output
+    REAL(r_std),DIMENSION (kjpindex,nvm,nlevels_tot)                     :: assimi_store
+
+    REAL(r_std), DIMENSION (kjpindex)      :: jwind                              !! Wind module (m s^{-1})
+
+    REAL(r_std),DIMENSION (kjpindex,nvm)  :: sum_rveget_rstruct
+
+    REAL(r_std),DIMENSION (kjpindex,nvm)  :: vcmax                               !! maximum rate of carboxylation 
+                                                                                 !! @tex ($\mu mol CO2 m^{-2} s^{-1}$) @endtex
+    INTEGER(i_std)                        :: ji, jv, ilev, limit_photo            !! indices (unitless)
+    !REAL(r_std), DIMENSION(kjpindex)      :: leaf_ci_lowest                      !! intercellular CO2 concentration at the lowest 
+    !                                                                             !! LAI level
+    !                                                                             !! @tex ($\mu mol mol^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex)      :: zqsvegrap                           !! relative water quantity in the water 
+                                                                                 !! interception reservoir (0-1,unitless) 
+    REAL(r_std)                           :: speed                               !! wind speed @tex ($m s^{-1}$) @endtex
+    ! Assimilation
+    LOGICAL, DIMENSION(kjpindex)          :: assimilate                          !! where assimilation is to be calculated 
+                                                                                 !! (unitless) 
+    INTEGER(i_std)                        :: nia,inia,nina,inina,iainia          !! counter/indices (unitless)
+    INTEGER(i_std), DIMENSION(kjpindex)   :: index_assi,index_non_assi           !! indices (unitless)
+    REAL(r_std), DIMENSION(kjpindex)      :: vc2                                 !! rate of carboxylation (at a specific LAI level) 
+                                                                                 !! @tex ($\mu mol CO2 m^{-2} s^{-1}$) @endtex 
+    REAL(r_std), DIMENSION(kjpindex)      :: vj2                                 !! rate of Rubisco regeneration (at a specific LAI 
+                                                                                 !! level) @tex ($\mu mol e- m^{-2} s^{-1}$) @endtex 
+    REAL(r_std), DIMENSION(kjpindex)      :: assimi                              !! assimilation (at a specific LAI level) 
+                                                                                 !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+                                                                                 !! (temporary variables)
+    REAL(r_std), DIMENSION(kjpindex)      :: gstop                               !! stomatal conductance to H2O at topmost level 
+                                                                                 !! @tex ($m s^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex)      :: gs                                  !! stomatal conductance to CO2 
+                                                                                 !! @tex ($\mol m^{-2} s^{-1}$) @endtex
+
+
+    REAL(r_std), DIMENSION(kjpindex)      :: gamma_star                          !! CO2 compensation point (ppm)
+                                                                                 !! @tex ($\mu mol mol^{-1}$) @endtex
+
+    REAL(r_std), DIMENSION(kjpindex)      :: air_relhum                          !! air relative humidity at 2m 
+                                                                                 !! @tex ($kg kg^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex)      :: VPD                                 !! Vapor Pressure Deficit (kPa)
+    REAL(r_std), DIMENSION(kjpindex)      :: water_lim                           !! water limitation factor (0-1,unitless)
+
+    REAL(r_std), DIMENSION(kjpindex)      :: gstot                               !! total stomatal conductance to H2O
+                                                                                 !! Final unit is
+                                                                                 !! @tex ($m s^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex)      :: assimtot                            !! total assimilation 
+                                                                                 !! @tex ($\mu mol CO2 m^{-2} s^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex)      :: Rdtot                               !! Total Day respiration (respiratory CO2 release other than by photorespiration) (mumol CO2 mâ2 sâ1) 
+    REAL(r_std), DIMENSION(kjpindex)      :: gs_top                              !! leaf stomatal conductance to H2O across all top levels
+                                                                                 !! @tex ($\mol H2O m^{-2} s^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex)      :: qsatt                               !! surface saturated humidity at 2m (??) 
+                                                                                 !! @tex ($g g^{-1}$) @endtex
+    REAL(r_std), DIMENSION(kjpindex)      :: T_Vcmax                             !! Temperature dependance of Vcmax (unitless)
+    REAL(r_std), DIMENSION(kjpindex)      :: S_Vcmax_acclim_temp                 !! Entropy term for Vcmax 
+                                                                                 !! accounting for acclimation to temperature (J K-1 mol-1)
+    REAL(r_std), DIMENSION(kjpindex)      :: T_Jmax                              !! Temperature dependance of Jmax
+    REAL(r_std), DIMENSION(kjpindex)      :: S_Jmax_acclim_temp                  !! Entropy term for Jmax 
+                                                                                 !! accounting for acclimation to temperature (J K-1 mol-1)
+    REAL(r_std), DIMENSION(kjpindex)      :: T_Rd                                !! Temperature dependance of Rd (unitless)
+    REAL(r_std), DIMENSION(kjpindex)      :: T_Kmc                               !! Temperature dependance of KmC (unitless)
+    REAL(r_std), DIMENSION(kjpindex)      :: T_KmO                               !! Temperature dependance of KmO (unitless)
+    REAL(r_std), DIMENSION(kjpindex)      :: T_gamma_star                        !! Temperature dependance of gamma_star (unitless)    
+    REAL(r_std), DIMENSION(kjpindex)      :: vc                                  !! Maximum rate of Rubisco activity-limited carboxylation (mumol CO2 mâ2 sâ1)
+    REAL(r_std), DIMENSION(kjpindex)      :: vj                                  !! Maximum rate of e- transport under saturated light (mumol CO2 mâ2 sâ1)
+    REAL(r_std), DIMENSION(kjpindex)      :: Rd                                  !! Day respiration (respiratory CO2 release other than by photorespiration) (mumol CO2 mâ2 sâ1)
+    REAL(r_std), DIMENSION(kjpindex)      :: Kmc                                 !! MichaelisâMenten constant of Rubisco for CO2 (mubar)
+    REAL(r_std), DIMENSION(kjpindex)      :: KmO                                 !! MichaelisâMenten constant of Rubisco for O2 (mubar)
+    REAL(r_std), DIMENSION(kjpindex)      :: gb                                  !! Boundary-layer conductance (mol mâ2 sâ1 barâ1)
+    REAL(r_std), DIMENSION(kjpindex)      :: fvpd                                !! Factor for describing the effect of leaf-to-air vapour difference on gs (-)
+    REAL(r_std), DIMENSION(kjpindex)      :: low_gamma_star                      !! Half of the reciprocal of Sc/o (bar bar-1)
+    REAL(r_std)                           :: N_Vcmax                             !! Nitrogen level dependance of Vcmacx and Jmax 
+    REAL(r_std)                           :: fcyc                                !! Fraction of electrons at PSI that follow cyclic transport around PSI (-)
+    REAL(r_std)                           :: z                                   !! A lumped parameter (see Yin et al. 2009) ( mol mol-1)                          
+    REAL(r_std)                           :: Rm                                  !! Day respiration in the mesophyll (umol CO2 mâ2 sâ1)
+    REAL(r_std)                           :: Cs_star                             !! Cs -based CO2 compensation point in the absence of Rd (ubar)
+    REAL(r_std), DIMENSION(kjpindex)      :: Iabs                                !! Photon flux density absorbed by leaf photosynthetic pigments (umol photon mâ2 sâ1)
+    REAL(r_std), DIMENSION(kjpindex)      :: Jmax                                !! Maximum value of J under saturated light (umol eâ mâ2 sâ1)
+    REAL(r_std), DIMENSION(kjpindex)      :: JJ                                  !! Rate of eâ transport (umol eâ mâ2 sâ1)
+    REAL(r_std)                           :: J2                                  !! Rate of all eâ transport through PSII (umol eâ mâ2 sâ1)
+    REAL(r_std)                           :: VpJ2                                !! eâ transport-limited PEP carboxylation rate (umol CO2 mâ2 sâ1)
+    REAL(r_std)                           :: A_1, A_3                            !! Lowest First and third roots of the analytical solution for a general 
+                                                                                 !! cubic equation (see Appendix A of Yin et al. 2009) (umol CO2 mâ2 sâ1)
+    REAL(r_std)                           :: A_1_tmp, A_3_tmp                    !! Temporary First and third roots of the analytical solution for a general 
+                                                                                 !! cubic equation (see Appendix A of Yin et al. 2009) (umol CO2 mâ2 sâ1)
+    REAL(r_std)                           :: Obs                                 !! Bundle-sheath oxygen partial pressure (ubar)
+    REAL(r_std)                           :: Cc                                  !! Chloroplast CO2 partial pressure (ubar)
+    REAL(r_std)                           :: ci_star                             !! Ci -based CO2 compensation point in the absence of Rd (ubar)        
+    REAL(r_std)                           :: a,b,c,d,m,f,j,g,h,i,l,p,q,r         !! Variables used for solving the cubic equation (see Yin et al. (2009))
+    REAL(r_std)                           :: QQ,UU,PSI,x1,x2,x3                  !! Variables used for solving the cubic equation (see Yin et al. (2009))
+
+    REAL(r_std),DIMENSION (kjpindex,nvm)  :: lai_total                           !! total LAI for column in question
+                                        
+    REAL(r_std)                           :: cresist                             !! coefficient for resistances (??)
+    REAL(r_std)                           :: lai_min                             !! mininum lai to calculate photosynthesis       
+                                                                                 !! coefficient for resistances (??)
+
+    LOGICAL,DIMENSION(kjpindex,nlevels_tot)  :: top_level                        !! A flag to see if a given level is considered
+                                                                                 !! a "top" level or not.  Must be done this way
+                                                                                 !! because there could be several "top" levels.
+    REAL(r_std)                           :: totlai_top                          !! The sum of the LAI in all the levels that we
+                                                                                 !! declare as the "top".
+    INTEGER(i_std)                        :: lev_count                           !! How many levels we have already taken for
+                                                                                 !! the "top"
+    INTEGER                               :: jij
+
+! @defgroup Photosynthesis Photosynthesis
+! @{   
+    ! 1. Preliminary calculations\n
+    REAL(r_std),DIMENSION (kjpindex,nvm)  :: rveget_min                          !! Minimal Surface resistance of vegetation
+    REAL(r_std),DIMENSION (kjpindex,nvm,nlevels_tot)     &
+                                          :: light_tran_to_level                 !! Cumulative amount of light transmitted
+                                                                                 !! to a given level
+    LOGICAL,DIMENSION (kjpindex)          :: lskip                               !! A flag to indicate we've hit an unusual
+                                                                                 !! case were we may have numerical instability.
+    INTEGER :: ipts
+    LOGICAL :: llight
+    LOGICAL :: llai
+    INTEGER,SAVE :: istep=0
+!_ ================================================================================================================================
+
+
+    ! JR 211013 define wind speed (this is defined in full in the diffuco module, but not here, so need to replicate it)
+    jwind(:) = SQRT (u(:)*u(:) + v(:)*v(:))
+    gs_output = 0.0d0
+    gstot_output = 0.0d0
+    lai_total = 0.0d0
+    assimi = 0.0d0
+    assimi_store = zero
+    !
+    DO ji=1,kjpindex
+        DO jv = 1, nvm
+            DO ilev=1,nlevels_tot
+                lai_total(ji,jv) = lai_total(ji,jv) + lai_per_level(ji,jv,ilev)   !! total LAI for column in question
+            END DO ! ilev = 1, nlevels_tot
+            !IF (test_grid == 1 .AND. jv ==test_pft) THEN
+            !   WRITE(numout, '(A20, ES20.4)') 'GET limited Vbeta3:', vbeta3(ji, jv)
+            !ENDIF       
+        END DO ! jv = 1, nvm
+    END DO ! ji = 1, klpindex
+    !
+    ! 1. Photosynthesis parameters
+    !
+    vcmax(:,:) = assim_param(:,:,ivcmax)
+    !
+    ! @addtogroup Photosynthesis
+    ! @{   
+    !
+    ! 1.2 Estimate relative humidity of air (for calculation of the stomatal conductance).\n
+    !! \latexonly
+    !! \input{jdiffuco_trans_co2_1.3.tex}
+    !! \endlatexonly
+    ! @}
+    !
+    ! N. de Noblet - 2006/06 - We use q2m/t2m instead of qair.
+    !    CALL qsatcalc (kjpindex, temp_air, pb, qsatt)
+    !    air_relhum(:) = &
+    !      ( qair(:) * pb(:) / (0.622+qair(:)*0.378) ) / &
+    !      ( qsatt(:)*pb(:) / (0.622+qsatt(:)*0.378 ) )
+    ! @codeinc
+
+    ! WRITE(*,*) '181113a test, pre call to qsatcalc sechiba_hydrol_arch line 858; temp_sol is: ', temp_sol
+
+    CALL qsatcalc (kjpindex, temp_sol, pb, qsatt)
+    air_relhum(:) = &
+      ( qsurf(:) * pb(:) / (Tetens_1+qsurf(:)* Tetens_2) ) / &
+      ( qsatt(:)*pb(:) / (Tetens_1+qsatt(:)*Tetens_2 ) )
+
+
+    VPD(:) = ( qsatt(:)*pb(:) / (Tetens_1+qsatt(:)*Tetens_2 ) ) &
+         - ( qsurf(:) * pb(:) / (Tetens_1+qsurf(:)* Tetens_2) )
+    ! VPD is needed in kPa
+    ! We limit the impact of VPD in the range of [0:6] kPa
+    ! This seems to be the typical range of values
+    ! that the vapor pressure difference can take, although
+    ! there is a paper by Mott and Parkhurst, Plant, Cell & Environment,
+    ! Vol. 14, pp. 509--519 (1991) which gives a value of 15 kPa.
+    VPD(:) = MAX(zero,MIN(VPD(:)/10.,6.))
+   ! VPD(:) = VPD(:)*1.038+0.132
+   
+    ! VPD(:) = VPD(:)*1.038291 + 0.1315685
+    VPD(:) = VPD(:)*vpd_k1+vpd_b1
+    ! write(*,*) 'VPDyyt',VPD(:)
+    ! @endcodeinc
+    ! N. de Noblet - 2006/06 
+    !
+    !
+    ! 2. beta coefficient for vegetation transpiration
+    !
+    rstruct(:,1) = rstruct_const(1)
+    rveget(:,:) = undef_sechiba
+    rveget_min(:,:) = undef_sechiba
+    !
+ 
+    ! JR 051113 need to preserve the value of vbeta3 modified by supply term constraint
+    ! in addition other values of vbeta3 are passed back from the earlier call to this
+    ! routine in sechiba, so no need to initialise again. It is an (inout) variable in
+    ! this version of the routine.
+    ! vbeta3(:,:) = zero
+
+    vbeta3pot(:,:) = zero
+    gsmean(:,:) = zero
+    gpp(:,:) = zero
+    light_tran_to_level(:,:,:)=un
+    !
+    cimean(:,1) = Ca(:)
+    !
+    ! @addtogroup Photosynthesis
+    ! @{   
+    ! 2. Loop over vegetation types\n
+    ! @} 
+    !
+    DO jv = 2,nvm
+      !
+      ! @addtogroup Photosynthesis
+      ! @{   
+      !
+      ! 2.1 Initializations\n
+      !! \latexonly
+      !! \input{diffuco_trans_co2_2.1.tex}
+      !! \endlatexonly
+      ! @}      
+      !
+      ! beta coefficient for vegetation transpiration
+      !
+      rstruct(:,jv) = rstruct_const(jv)
+      cimean(:,jv) = Ca(:)
+      !
+      !! mask that contains points where there is photosynthesis
+      !! For the sake of vectorisation [DISPENSABLE], computations are done only for convenient points.
+      !! nia is the number of points where the assimilation is calculated and nina the number of points where photosynthesis is not
+      !! calculated (based on criteria on minimum or maximum values on LAI, vegetation fraction, shortwave incoming radiation, 
+      !! temperature and relative humidity).
+      !! For the points where assimilation is not calculated, variables are initialized to specific values. 
+      !! The assimilate(kjpindex) array contains the logical value (TRUE/FALSE) relative to this photosynthesis calculation.
+      !! The index_assi(kjpindex) array indexes the nia points with assimilation, whereas the index_no_assi(kjpindex) array indexes
+      !! the nina points with no assimilation.
+      !          
+      ! set minimum lai value to test if photosynthesis should be calculated
+      ! 0.0001 is abitrary
+      ! could be externalised 
+      lai_min = 0.0001
+      !
+      nia=0
+      nina=0
+      index_assi=0
+      index_non_assi=0
+      !
+      !      
+      DO ji=1,kjpindex
+         !
+         ! This is tricky.  We need a certain amount of LAI to have photosynthesis.
+         ! However, we divide our canopy up into certain levels, so even if we
+         ! have a total amount that is sufficient, there might not be enough
+         ! in any particular layer.  So we check each layer to see if there
+         ! is one that has enough to give a non-zero photosynthesis.  In
+         ! the worst-case scenario (small LAI in every other level), this becomes 
+         ! our top level for the gs calculation.  If gs_top_level is zero below,
+         ! we have a divide by zero issue.
+         llai=.FALSE.
+         DO ilev=1,nlevels_tot
+            IF(lai_per_level(ji,jv,ilev) .GT. lai_min) llai=.TRUE.
+         ENDDO
+
+         IF ( llai .AND. &
+              ( veget_max(ji,jv) .GT. min_sechiba ) ) THEN
+            
+            ! Here we need to do something different than in the previous model.
+            ! We explicitly need to check for absorbed light.  This occurs
+            ! because our albedo in the two stream model is a function
+            ! of the solar angle.  If the sun has set, we have no
+            ! light, and therefore we cannot have photosynthesis.
+            llight=.FALSE.
+            DO ilev=1,nlevels_tot
+               IF(Isotrop_Abs_Tot_p(ji,jv,ilev) .GT. min_sechiba) llight=.TRUE.
+            ENDDO
+            IF ( ( swdown(ji) .GT. min_sechiba )   .AND. &
+                 ( temp_growth(ji) .GT. tphoto_min(jv) ) .AND. &
+                 llight .AND. &
+                 ( temp_growth(ji) .LT. tphoto_max(jv) )) 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
+      !
+
+      IF(ld_photo .AND. jv == test_pft)THEN
+         !WRITE(numout,*) 'index_non_assi(:): ',index_non_assi(:)
+         !WRITE(numout,*) 'index_assi(:): ',index_assi(:)
+         !WRITE(numout,*) 'nia: ',nia
+      ENDIF
+
+
+      top_level(:,:)=.FALSE.
+      gstot(:) = zero
+      assimtot(:) = zero
+      Rdtot(:)=zero
+      gs_top(:) = zero
+      lskip(:)=.FALSE.
+      !
+      zqsvegrap(:) = zero
+      WHERE (qsintmax(:,jv) .GT. min_sechiba)
+         !! relative water quantity in the water interception reservoir
+         zqsvegrap(:) = MAX(zero, qsintveg(:,jv) / qsintmax(:,jv))
+      ENDWHERE
+      !
+      !! Calculates the water limitation factor.
+      !!Not used when hydrol_arch is used, can be deleted
+      WHERE ( assimilate(:) )
+         ! water_lim(:) = MAX( min_sechiba, MIN( vegstress(:,jv)/0.5, un ))
+         water_lim(:) = un
+      ELSEWHERE
+         water_lim(:) = zero
+      ENDWHERE
+
+      ! give a default value of ci for all pixel that do not assimilate
+      DO ilev=1,nlevels_tot
+         DO inina=1,nina
+            new_leaf_ci(index_non_assi(inina),jv,ilev) = Ca(index_non_assi(inina)) 
+         ENDDO
+      ENDDO
+      !
+      !
+      ! Here is the calculation of assimilation and stomatal conductance
+      ! based on the work of Farquahr, von Caemmerer and Berry (FvCB model) 
+      ! as described in Yin et al. 2009
+      ! Yin et al. developed a extended version of the FvCB model for C4 plants
+      ! and proposed an analytical solution for both photosynthesis pathways (C3 and C4)
+      ! Photosynthetic parameters used are those reported in Yin et al. 
+      ! Except For Vcmax25, relationships between Vcmax25 and Jmax25 for which we use 
+      ! Medlyn et al. (2002) and Kattge & Knorr (2007)
+      ! Because these 2 references do not consider mesophyll conductance, we neglect this term
+      ! in the formulations developed by Yin et al. 
+      ! Consequently, gm (the mesophyll conductance) tends to the infinite
+      ! This is of importance because as stated by Kattge & Knorr and Medlyn et al.,
+      ! values of Vcmax and Jmax derived with different model parametrizations are not 
+      ! directly comparable and the published values of Vcmax and Jmax had to be standardized
+      ! to one consistent formulation and parametrization
+
+      ! See eq. 6 of Yin et al. (2009)
+      ! Parametrization of Medlyn et al. (2002) - from Bernacchi et al. (2001)
+      T_KmC(:)        = Arrhenius(kjpindex,temp_sol,298.,E_KmC(jv))
+      T_KmO(:)        = Arrhenius(kjpindex,temp_sol,298.,E_KmO(jv))
+      T_gamma_star(:) = Arrhenius(kjpindex,temp_sol,298.,E_gamma_star(jv))
+
+
+      ! Parametrization of Yin et al. (2009) - from Bernacchi et al. (2001)
+      T_Rd(:)         = Arrhenius(kjpindex,temp_sol,298.,E_Rd(jv))
+
+
+      ! For C3 plants, we assume that the Entropy term for Vcmax and Jmax 
+      ! acclimates to temperature as shown by Kattge & Knorr (2007) - Eq. 9 and 10
+      ! and that Jmax and Vcmax respond to temperature following a modified Arrhenius function
+      ! (with a decrease of these parameters for high temperature) as in Medlyn et al. (2002) 
+      ! and Kattge & Knorr (2007).
+      ! In Yin et al. (2009), temperature dependance to Vcmax is based only on a Arrhenius function
+      ! Concerning this apparent unconsistency, have a look to the section 'Limitation of 
+      ! Photosynthesis by gm' of Bernacchi (2002) that may provide an explanation
+
+      ! Growth temperature tested by Kattge & Knorr range from 11 to 35Â°C
+      ! So, we limit the relationship between these lower and upper limits
+      S_Jmax_acclim_temp(:) = aSJ(jv) + bSJ(jv) * MAX(11., MIN(temp_growth(:),35.))      
+      T_Jmax(:)  = Arrhenius_modified(kjpindex,temp_sol,298.,E_Jmax(jv),D_Jmax(jv),S_Jmax_acclim_temp)
+
+      S_Vcmax_acclim_temp(:) = aSV(jv) + bSV(jv) * MAX(11., MIN(temp_growth(:),35.))   
+      T_Vcmax(:) = Arrhenius_modified(kjpindex,temp_sol,298.,E_Vcmax(jv),D_Vcmax(jv),S_Vcmax_acclim_temp)
+      !       
+      vc(:) = vcmax(:,jv) * T_Vcmax(:)
+      ! As shown by Kattge & Knorr (2007), we make use
+      ! of Jmax25/Vcmax25 ratio (rJV) that acclimates to temperature for C3 plants
+      ! rJV is written as a function of the growth temperature
+      ! rJV = arJV + brJV * T_month 
+      ! See eq. 10 of Kattge & Knorr (2007)
+      ! and Table 3 for Values of arJV anf brJV 
+      ! Growth temperature is monthly temperature (expressed in Â°C) - See first paragraph of
+      ! section Methods/Data of Kattge & Knorr
+      vj(:) = ( arJV(jv) + brJV(jv) *  MAX(11., MIN(temp_growth(:),35.)) ) * vcmax(:,jv) * T_Jmax(:)
+      !
+      ! @endcodeinc
+      !
+      KmC(:)=KmC25(jv)*T_KmC(:)
+      KmO(:)=KmO25(jv)*T_KmO(:)
+      gamma_star(:) = gamma_star25(jv)*T_gamma_star(:)
+      ! low_gamma_star is defined by Yin et al. (2009)
+      ! as the half of the reciprocal of Sco - See Table 2
+      ! We derive its value from Equation 7 of Yin et al. (2009)
+      ! assuming a constant O2 concentration (Oi)
+      low_gamma_star(:) = gamma_star(:)/Oi
+      ! VPD expressed in kPa
+     ! fvpd(:) = 1. / ( 1. / (a1(jv) - b1(jv) * VPD(:)) - 1. ) 
+      ! * water_lim(:)
+      !IF (VPD(:) .LT. 0.1) THEN
+      !   CALL getin_p('newA1',a1)
+      !   CALL getin_p('newB1',b1)
+      !   fvpd(:) = 1. / ( 1. / (a1(jv) - b1(jv) * VPD(:)) - 1. )
+      !ELSE
+      !   CALL getin_p('A1',a1)
+      !   CALL getin_p('B1',b1)
+      !   fvpd(:) = 1. / ( 1. / (a1(jv) - b1(jv) * VPD(:)) - 1. )
+     ! ENDIF
+! change a1 and b1 values according to vpd  yitong Yao
+      DO ji=1,kjpindex
+         IF (VPD(ji) .LT. 0.35) THEN
+                 CALL getin_p('newA1',a1)
+                 CALL getin_p('newB1',b1)
+                 fvpd(ji) = 1. / ( 1. / (a1(jv) - b1(jv) * VPD(ji)) - 1. )
+         ELSE
+                 CALL getin_p('A1',a1)
+                 CALL getin_p('B1',b1)
+                 fvpd(ji) = 1. / ( 1. / (a1(jv) - b1(jv) * VPD(ji)) - 1. )
+         ENDIF
+         !write(*,*) 'vpdvpd_yyt1',VPD(ji)
+         !write(*,*) 'fvpd_yyt1',fvpd(ji)
+      ENDDO
+
+      !write(*,*) 'vpdvpd',VPD(:)
+      !write(*,*) 'cons_a1',a1(jv)
+      !write(*,*) 'cons_b1',b1(jv)
+
+        !???
+      !leaf boundary layer conductance
+      gb(:) = (1.0_r_std /25.0_r_std)/(22.4_r_std *temp_sol(:)/273._r_std/1000._r_std) 
+      !???
+      !
+      ! @addtogroup Photosynthesis
+      ! @{   
+      !
+      ! 2.4 Loop over LAI levels to estimate assimilation and conductance\n
+      ! @}           
+      !
+
+
+
+
+      IF (nia .GT. 0) THEN
+         gridloop1: DO inia=1,nia
+            !
+            iainia=index_assi(inia)
+
+            ! JR we 'cycle' the LAI loop for those PFTs not subject to the hydrol stress for the grid square in question
+
+            IF (hydrol_flag3(iainia, jv)) THEN
+               !nothing              
+            ELSE
+               CYCLE gridloop1
+            END IF !(hydrol_flag3)
+
+
+            ! JR the first part of the routine is a copy of diffuco_trans_co2, so that we can 
+            ! calculate values for fvpd, assimtot, Rdtot, new_leaf_ci and ci_star
+            !
+            ! Find the top layer that still contains lai.  We have also
+            ! added a check in here to make sure this layer has absorbed
+            ! light.  If there is no absorbed light, we will not calculate
+            ! stomatal conductance for the top level, which means gstop
+            ! will be zero later and we'll crash when we divide by it.
+            ! Include a warning so we know how often this happens.
+            ! Include a warning so we know how often this happens.
+            ! The old system of chosing just one top level caused some bad results
+            ! in the transpir, evidently due to the calculation of vbeta3 being
+            ! too low due to too low of LAI in the top level.  Therefore, we are
+            ! now going to take several top levels in an effort to make sure
+            ! we have enough LAI.  We aim for an arbitrary amount of 0.1 or
+            ! the top three levels.  This has not been rigoursly tested, but it
+            ! is theoretically justified by the fact that if the LAI of the top
+            ! level is very low, other leaves will be getting a lot of sun and
+            ! well-exposed to the atmosphere, and therefore contribute equal
+            ! to the resistence of the vegetation.
+            totlai_top=zero
+            lev_count=0
+            !   
+            DO ilev=nlevels_tot, 1, -1
+               IF(lai_per_level(iainia,jv,ilev) .GT. lai_min)THEN
+                  IF(Isotrop_Abs_Tot_p(iainia,jv,ilev) .GT. min_sechiba)THEN
+                     IF(totlai_top .LT. lai_top(jv) .AND. lev_count .LT. nlev_top)THEN
+                        lev_count=lev_count+1
+                        top_level(iainia,ilev)=.TRUE.
+                        totlai_top=totlai_top+lai_per_level(iainia,jv,ilev)
+                     ELSE
+                        ! We have enough levels now.
+                        !WRITE(numout,*) 'Top levels ',totlai_top,lev_count
+                        EXIT
+                     ENDIF
+                  ELSE
+                     IF(ld_warn)THEN
+                        WRITE(numout,*) 'WARNING: Found a level with LAI, ' // &
+                             'but no absorbed light.'
+                        WRITE(numout,*) 'WARNING: iainia,jv,ilev, ',iainia,jv,ilev
+                        WRITE(numout,*) 'WARNING: Isotrop_Abs_Tot_p(iainia,jv,ilev),' //&
+                             'lai_per_level(iainia,jv,ilev), ',iainia,jv,ilev
+                     ENDIF
+                  ENDIF
+               ENDIF
+            ENDDO
+            IF(totlai_top .LT. min_sechiba)THEN
+               ! There seem to be some fringe cases where this happens, usually
+               ! at sunrise or sunset with low LAI levels.  Instead of stopping
+               ! here, I'm going to issue a warning.  If this case happens,
+               ! we produce no GPP, but we're not going to crash.  We need to
+               ! be careful in one of the loops below, since a stomatal 
+               ! conductance of zero will cause a crash.
+                IF(ld_warn)THEN
+                   WRITE(numout,*) 'WARNING: Did not find a level with LAI in diffuco!'
+                   WRITE(numout,*) 'WARNING: iainia,ivm: ',iainia,jv
+                ENDIF
+               assimtot(iainia) = zero
+               Rdtot(iainia) = zero
+               gstot(iainia) = zero
+               lskip(iainia)=.TRUE.
+               CYCLE gridloop1
+            ENDIF
+
+            ! We need to know how much is transmitted to this level
+            ! from the top of the canopy, since this aboslute number
+            ! is what is actually used in the photosyntheis.  Right now
+            ! Isotrop_Tran_Tot_p and Isotropic_Abs_Tot_p are the 
+            ! relative quantities transmitted through and absorbed
+            ! by the layer.
+            DO ilev = nlevels_tot-1,1,-1
+               light_tran_to_level(iainia,jv,ilev)=light_tran_to_level(iainia,jv,ilev+1)*Isotrop_Tran_Tot_p(iainia,jv,ilev+1)
+            ENDDO
+            IF(ld_photo .AND. jv == test_pft .AND. iainia == test_grid)THEN
+               WRITE(numout,*) 'Absolute transmitted light to each level',jv,iainia
+               DO ilev = nlevels_tot,1,-1
+                  WRITE(numout,*) ilev,light_tran_to_level(iainia,jv,ilev)
+               ENDDO
+            ENDIF
+
+            DO ilev = 1, nlevels_tot
+               
+               IF (Isotrop_Abs_Tot_p(iainia,jv,ilev) .GT. min_sechiba) THEN
+
+                  IF(lai_per_level(iainia,jv,ilev) .LE. min_sechiba)THEN
+                     ! This is not necessarily a problem.  LAI is updated in slowproc, while
+                     ! absorbed light is updated in condveg, which is called after diffuco.
+                     ! So we might be one timestep off.  It generally should be at night,
+                     ! though, so there is no absorbed light.  If this persists, that
+                     ! is a real problem.
+                     IF(ld_warn)THEN
+                        WRITE(numout,*) 'WARNING: We have absorbed light but no LAI ' // &
+                             'in this level. Skipping.'
+                        WRITE(numout,'(A,3I8)') 'WARNING: iainia,jv,ilev: ',iainia,jv,ilev
+                        WRITE(numout,'(A,2F20.10)') 'WARNING: Isotrop_Abs_Tot_p(iainia,jv,ilev), ' // &
+                             'lai_per_level(ji,jv,ilev): ',&
+                             Isotrop_Abs_Tot_p(iainia,jv,ilev), lai_per_level(iainia,jv,ilev)
+                     ENDIF
+                     CYCLE
+                  ENDIF
+                  !
+                  ! nitrogen is scaled according to the transmitted light
+                  ! before the caclulation was (1 - exp(lai)) we replaced
+                  ! it by the transmitted light calculated by the 2stream
+                  ! model, maybe ( un - Isotrop_Tran_Tot_p(iainia,jv,ilev) )
+                  ! could be replaced by the directly calculated absorbed
+                  ! light Isotrop_Abs_Tot_p(iainia,jv,ilev).
+                  ! Notice that light in the old code was the cumulative light transmitted to
+                  ! the layer, while Isotrop_Tran_Tot_p is the relative light transmitted
+                  ! through the layer.  Therefore, we use a different variable.
+                  !
+!                     N_Vcmax = ( un - .7_r_std * ( un - Isotrop_Tran_Tot_p(iainia,jv,ilev) ) )
+                  N_Vcmax = ( un - .7_r_std * ( un - light_tran_to_level(iainia,jv,ilev) ) )
+                  !
+                 ! IF (control%ok_hydrol_arch) THEN
+                 
+                  !*********CHECK: only photsynthesis when day***************
+                 ! WHERE (assimilate(:))
+                 !    vc2(iainia) = vc(iainia) * N_Vcmax
+                 !    vj2(iainia) = vj(iainia) * N_Vcmax 
+                     ! see Comment in legend of Fig. 6 of Yin et al. (2009)
+                     ! Rd25 is assumed to equal 0.01 Vcmax25 
+                  !   Rd(iainia) = vcmax(iainia,jv) * N_Vcmax * 0.01 * T_Rd(iainia)
+                  !ELSEWHERE
+                  !   vc2(iainia) = zero
+                  !   vj2(iainia) = zero
+                  !   Rd(iainia) = zero
+                  !ENDWHERE
+
+                 ! ELSE
+                     
+                     vc2(iainia) = vc(iainia) * N_Vcmax 
+                     vj2(iainia) = vj(iainia) * N_Vcmax 
+                     
+                     ! see Comment in legend of Fig. 6 of Yin et al. (2009)
+                     ! Rd25 is assumed to equal 0.01 Vcmax25 
+                     Rd(iainia) = vcmax(iainia,jv) * N_Vcmax * 0.01 * T_Rd(iainia)
+                 
+                  !ENDIF
+
+                  !+++++ CHECK +++++
+                  IF(jv == test_pft .AND. iainia == test_grid .AND. ld_photo)THEN
+                     WRITE(numout,*) 'Iabs1: ',iainia,jv,ilev
+                     WRITE(numout,'(A,10F20.10)') 'Iabs2: ',swdown(iainia),W_to_mmol,RG_to_PAR,&
+                          Isotrop_Abs_Tot_p(iainia,jv,ilev),light_tran_to_level(iainia,jv,ilev) &
+                          , lai_per_level(iainia,jv,ilev)
+                  ENDIF
+                  Iabs(iainia)=swdown(iainia)*W_to_mmol*RG_to_PAR*&
+                       Isotrop_Abs_Tot_p(iainia,jv,ilev)*light_tran_to_level(iainia,jv,ilev) &
+                       / lai_per_level(iainia,jv,ilev) ! need to convert to per m**2 of leaves to
+                  ! be consistent with the units we use for Jmax
+!                  WRITE(numout,*) 'Iabs ',jv,Iabs(iainia),lai_per_level(iainia,jv,ilev)
+!                  Iabs(iainia)=swdown(iainia)*W_to_mmol*RG_to_PAR*Isotrop_Abs_Tot_p(iainia,jv,ilev)
+                  !+++++++++++++++++
+                  ! If we have a very dense canopy, the lower levels might
+                  ! get almost no light.  If the light is close to zero, it
+                  ! causes a numerical problem below, as x1 will be zero.  Of
+                  ! course, if the absorbed light is really small photosynthesis will
+                  ! not happen, so we can just skip this level.  This number is 
+                  ! fairly arbitrary, but it should be as small as possible.
+                  IF(Iabs(iainia) .LT. 1e-12)CYCLE
+
+                  !
+                  !
+                  ! eq. 4 of Yin et al (2009)
+                  Jmax(iainia)=vj2(iainia)
+                  JJ(iainia) = ( alpha_LL(jv) * Iabs(iainia) + Jmax(iainia) - &
+                       sqrt((alpha_LL(jv) * Iabs(iainia) + Jmax(iainia) )**2. &
+                       - 4 * theta(jv) * Jmax(iainia) * alpha_LL(jv) * &
+                       Iabs(iainia)) ) &
+                       / ( 2 * theta(jv))
+
+                  !
+
+                  IF(ld_photo .AND. test_pft == jv)THEN
+                     WRITE(numout,*) '*************************'
+                     WRITE(numout,*) 'jv,ilev: ',jv,ilev
+                     WRITE(numout,*) 'JJ(iainia),Jmax(iainia),Iabs(iainia),Rd(iainia): ',&
+                          JJ(iainia),Jmax(iainia),Iabs(iainia),Rd(iainia)
+                     WRITE(numout,*) 'vj2(iainia),vc2(iainia),N_Vcmax:',&
+                          vj2(iainia),vc2(iainia),N_Vcmax
+                     WRITE(numout,*) 'Isotrop_Abs_Tot_p(iainia,jv,ilev),Isotrop_Tran_Tot_p(iainia,jv,ilev):',&
+                          Isotrop_Abs_Tot_p(iainia,jv,ilev),Isotrop_Tran_Tot_p(iainia,jv,ilev)
+                     
+                     WRITE(numout,*) 'water_lim(iainia),T_Rd(iainia):',water_lim(iainia),T_Rd(iainia)
+                     WRITE(numout,*) 'vc(iainia),vj(iainia), vcmax(iainia,jv):',&
+                          vc(iainia),vj(iainia),vcmax(iainia,jv)
+                     WRITE(numout,*) '*************************'
+                  ENDIF
+                  IF ( is_c4(jv) )  THEN
+                     !
+                     ! @addtogroup Photosynthesis
+                     ! @{   
+                     !
+                     ! 2.4.2 Assimilation for C4 plants (Collatz et al., 1992)\n
+                     !! \latexonly
+                     !! \input{jdiffuco_trans_co2_2.4.2.tex}
+                     !! \endlatexonly
+                     ! @}           
+                     !
+                     !
+                     !
+                     ! Analytical resolution of the Assimilation based Yin et al. (2009)
+                     ! Eq. 28 of Yin et al. (2009)
+                     fcyc= 1. - ( 4.*(1.-fpsir(jv))*(1.+fQ(jv)) + 3.*h_protons(jv)*fpseudo(jv) ) / &
+                          ( 3.*h_protons(jv) - 4.*(1.-fpsir(jv)))
+
+                     ! See paragraph after eq. (20b) of Yin et al.
+                     Rm=Rd(iainia)/2.
+
+                     ! We assume that cs_star equals ci_star (see Comment in legend of Fig. 6 of Yin et al. (2009)
+                     ! Equation 26 of Yin et al. (2009)
+                     Cs_star = (gbs(jv) * low_gamma_star(iainia) * Oi - ( 1. + &
+                          low_gamma_star(iainia) * alpha(jv) / 0.047) * Rd(iainia) + Rm ) &
+                          / ( gbs(jv) + kp(jv) ) 
+                     
+
+                     ! eq. 11 of Yin et al (2009)
+                     J2 = JJ(iainia) / ( 1. - fpseudo(jv) / ( 1. - fcyc ) )
+
+                     ! Equation right after eq. (20d) of Yin et al. (2009)
+                     z = ( 2. + fQ(jv) - fcyc ) / ( h_protons(jv) * (1. - fcyc ))
+
+                     VpJ2 = fpsir(jv) * J2 * z / 2.
+
+                     A_3=9999.
+
+                     ! See eq. right after eq. 18 of Yin et al. (2009)
+                     ! The loop over limit_photo calculates the assimultion
+                     ! rate of the Rubisco-limited CsO2 assimilation (Ac) and
+                     ! the rate of electron transport-limited CO2 assimultion
+                     ! (Aj).  The overall assimilation will be the slower
+                     ! of these two processes.
+                     DO limit_photo=1,2
+                        ! Is Vc limiting the Assimilation
+                        IF ( limit_photo .EQ. 1 ) THEN
+                           a = 1. + kp(jv) / gbs(jv)
+                           b = 0.
+                           x1 = Vc2(iainia)
+                           x2 = KmC(iainia)/KmO(iainia)
+                           x3 = KmC(iainia)
+                           ! Is J limiting the Assimilation
+                        ELSE
+                           a = 1.
+                           b = VpJ2
+                           x1 = (1.- fpsir(jv)) * J2 * z / 3.
+                           x2 = 7. * low_gamma_star(iainia) / 3.
+                           x3 = 0.
+                        ENDIF
+
+                        m=fvpd(iainia)-g0(jv)/gb(iainia)
+                        d=g0(jv)*(Ca(iainia)-Cs_star) + fvpd(iainia)*Rd(iainia)
+                        f=(b-Rm-low_gamma_star(iainia)*Oi*gbs(jv))*x1*d + a*gbs(jv)*x1*Ca(iainia)*d
+                        j=(b-Rm+gbs(jv)*x3 + x2*gbs(jv)*Oi)*m + (alpha(jv)*x2/0.047-1.)*d &
+                             + a*gbs(jv)*(Ca(iainia)*m - d/gb(iainia) - (Ca(iainia) - Cs_star ))
+
+                        g=(b-Rm-low_gamma_star(iainia)*Oi*gbs(jv))*x1*m - (alpha(jv)*low_gamma_star(iainia)/0.047+1.)*x1*d &
+                             + a*gbs(jv)*x1*(Ca(iainia)*m - d/gb(iainia) - (Ca(iainia)-Cs_star ))
+
+                        h=-((alpha(jv)*low_gamma_star(iainia)/0.047+1.)*x1*m + (a*gbs(jv)*x1*(m-1.))/gb(iainia) )
+                        i= ( b-Rm + gbs(jv)*x3 + x2*gbs(jv)*Oi )*d + a*gbs(jv)*Ca(iainia)*d
+                        l= ( alpha(jv)*x2/0.047 - 1.)*m - (a*gbs(jv)*(m-1.))/gb(iainia)
+
+                        p = (j-(h-l*Rd(iainia))) / l
+                        q = (i+j*Rd(iainia)-g) / l
+                        r = -(f-i*Rd(iainia)) / l 
+
+                        ! See Yin et al. (2009) and  Baldocchi (1994)
+                        QQ = ( (p**2._r_std) - 3._r_std * q) / 9._r_std
+                        UU = ( 2._r_std* (p**3._r_std) - 9._r_std *p*q + 27._r_std *r) /54._r_std
+
+                        IF (QQ .GE. 0._r_std) THEN
+                           IF (ABS(UU/(QQ**1.5_r_std) ) .LE. 1._r_std) THEN
+                              PSI = ACOS(UU/(QQ**1.5_r_std))
+                              A_3_tmp = -2._r_std * SQRT(QQ) * COS(( PSI + 4._r_std * PI)/3._r_std ) - p / 3._r_std
+                              IF (( A_3_tmp .LT. A_3 )) THEN
+                                 A_3 = A_3_tmp
+                              ELSE
+                                 ! In case, J is not limiting the assimilation
+                                 ! we have to re-initialise a, b, x1, x2 and x3 values
+                                 ! in agreement with a Vc-limited assimilation 
+                                 a = 1. + kp(jv) / gbs(jv)
+                                 b = 0.
+                                 x1 = Vc2(iainia)
+                                 x2 = KmC(iainia)/KmO(iainia)
+                                 x3 = KmC(iainia)
+                              ENDIF
+                           ENDIF
+                        ELSE
+                           WRITE(numout,*) 'WARNING: unexpected value for QQ (sechiba_hydrol_arch.f90)'
+                        ENDIF
+
+                        IF ( ( A_3 .EQ. 9999. ) .OR. ( A_3 .LT. (-Rd(iainia)) ) ) THEN
+                           WRITE(numout,*) 'We have a problem in jdiffuco_trans_co2'
+                           WRITE(numout,*) 'no real positive solution found for pft:',jv
+                           WRITE(numout,*) 'temp_sol:',temp_sol(iainia)
+                           WRITE(numout,*) 'vpd:',vpd(iainia)
+                           A_3 = -Rd(iainia)
+                        ENDIF
+                        assimi(iainia) = A_3
+
+                        !++++ TEMP +++++
+                        IF(( x1 - (assimi(iainia) + Rd(iainia) )) == zero)THEN
+                           
+                           ! This causes a problem, since we really should not
+                           ! be dividing by zero.  However, it seems to happen
+                           ! fairly rarely, so all we'll do is cycle to the
+                           ! next loop and keep track of this warning so we
+                           ! can look at it afterwards.
+                           warnings(iainia,jv,iwphoto)=warnings(iainia,jv,iwphoto)+un
+                           
+                           IF(ld_warn)THEN
+                              WRITE(numout,*) 'jdiffuco, Getting ready to divide by zero! C4'
+                              WRITE(numout,*) '( x1 - ( assimi(iainia) + Rd(iainia) ) ', &
+                                   ( x1 - (assimi(iainia) + Rd(iainia) ))
+                              WRITE(numout,*) 'x1,assimi(iainia),Rd(iainia): ', &
+                                   x1,assimi(iainia),Rd(iainia)
+                              WRITE(numout,*) 'jv,ilev,iainia: ', jv,ilev,iainia
+                           ENDIF
+                           
+                           CYCLE
+                           
+                        ENDIF
+
+                        ! Eq. 24 of Yin et al. (2009) 
+                        Obs = ( alpha(jv) * assimi(iainia) ) / ( 0.047 * gbs(jv) ) + Oi
+                        ! Eq. 23 of Yin et al. (2009)
+                        Cc = ( ( assimi(iainia) + Rd(iainia) ) * ( x2 * Obs + x3 ) + low_gamma_star(iainia) &
+                             * Obs * x1 ) &
+                             / ( x1 - ( assimi(iainia) + Rd(iainia) ))
+                        ! Eq. 22 of Yin et al. (2009)
+                        new_leaf_ci(iainia,jv,ilev) = ( Cc - ( b - assimi(iainia) - Rm ) / gbs(jv) ) / a
+
+
+
+                        ! JR %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+                        ! For the cases in which the supply term condition applies, we need
+                        ! to work backwards and calculate gs, and hence assimi for the grid
+                        ! square and PFT in question, from the value of vbeta3 derived in the
+                        ! enerbil code.
+
+                        ! This sequence is for the c4 vegetation types, and should be identical
+                        ! to the c3 loop below, except for the definition of assimi
+
+                        IF (hydrol_flag3(iainia, jv)) THEN
+
+                           !WRITE(numout,*) '231113 in c4 loop ilev is: ', ilev, 'PFT is: ', jv
+
+                           ! WRITE(numout,*) '151113 in jenerbil_trans_co2 hydrol_flag3 C4 plants'
+
+                            speed = MAX(min_wind, jwind(iainia))
+
+                            ! first case
+
+                            IF (zqsvegrap(iainia) .lt. 1.0d0) THEN
+                           
+                            !cresist = vbeta3(iainia, jv) / &
+                            !     &  ( veget_max(iainia, jv) * (1.0d0 - zqsvegrap(iainia)) + &
+                            !     &  veget_max(iainia, jv) * zqsvegrap(iainia) )
+                            
+                            cresist = vbeta3(iainia, jv) / &
+                                  & (veget_max(iainia, jv) * ( un - zqsvegrap(iainia)) + &
+                                  &  veget(iainia,jv) * zqsvegrap(iainia) )     
+                                 
+                            
+                            ! WRITE(numout,*) 'cresist condition a)'
+
+                            ELSE
+
+                            ! cresist = vbeta3(iainia, jv) / &
+                            !      &  ( veget_max(iainia, jv) * zqsvegrap(iainia) )
+
+                            cresist = 0.0d0
+
+                            ! WRITE(numout,*) 'cresist condition b)'
+
+                            END IF
+                           
+                            IF (vbeta23(iainia, jv) .le. &
+                            &  (veget(iainia, jv) * zqsvegrap(iainia) * cresist) ) THEN
+                               ! do nothing
+                            ELSE
+
+                               IF (zqsvegrap(iainia) .lt. 1.0d0) THEN
+                               !cresist = (vbeta3(iainia, jv) - vbeta23(iainia, jv)  )  / &
+                               !    & ( veget_max(iainia, jv) * (1.0d0 - zqsvegrap(iainia))  )
+                               
+                               cresist = vbeta3(iainia, jv) / &
+                                  & (veget_max(iainia, jv) * ( un - zqsvegrap(iainia)) + &
+                                  &  veget(iainia,jv) * zqsvegrap(iainia) )    
+
+                               
+                               ! WRITE(numout,*) 'cresist condition c)'
+                            
+                               ELSE
+
+                               ! cresist = vbeta3(iainia, jv) / &
+                               !      &  ( veget_max(iainia, jv) * zqsvegrap(iainia) )
+
+                               cresist = 0.0d0
+
+                               END IF
+
+                            END IF !
+
+                                   !     
+                            IF (cresist .ne. 0.0d0) THEN
+                                sum_rveget_rstruct(iainia,jv) = &
+                                     & (1.0d0/cresist - 1.0d0) * (1.0d0 / (speed * q_cdrag(iainia) * rveg_pft(jv)))
+                              ELSE
+                                ! sum_rveget_rstruct(iainia,jv) = &
+                                !      & (1.0d0 / (speed * q_cdrag(iainia) * rveg_pft(jv)))
+                                  
+                                sum_rveget_rstruct(iainia,jv) = 0.0d0
+
+                            END IF
+
+                            !WRITE(numout,*) '241113 sub_rveget_rstruct is: ', sum_rveget_rstruct(iainia,jv)
+
+                            vbeta3pot(iainia,jv) = MAX(zero, veget_max(iainia,jv) * cresist)
+
+
+                            ! calculate approximate gs, working backwards from vbeta3
+                            IF (sum_rveget_rstruct(iainia,jv) .ne. 0.0d0) THEN
+                                gstot(iainia) = 1.0d0 / sum_rveget_rstruct(iainia,jv)
+                            ELSE
+                               ! Need to convert the units of g0
+                               gstot(iainia) = g0(jv)*mmol_to_m_1 *(temp_sol(iainia)/tp_00)*&
+                                    (pb_std/pb(iainia))*ratio_H2O_to_CO2
+                            END IF
+
+                            !WRITE(numout,*) '241113 gstot is: ', gstot
+
+                            IF (gstot(iainia) .gt. 0.0d0) THEN
+                                ! nothing
+                            ELSE
+                                !WRITE(*,*) '121113 gstot .le. 0'
+                            ENDIF
+
+
+                            ! we now do a unit conversion, from m/s to mol/m^2/s, the reverse
+                            !   of the calculation of section 2.5, below
+
+                            gstot(iainia) =  gstot(iainia) / (mmol_to_m_1 *(temp_sol(iainia)/tp_00)* &
+                                       (pb_std/pb(iainia))*ratio_H2O_to_CO2)
+
+
+                            ! gs(iainia) = gstot(iainia) / lai(iainia, jv)
+                            ! gs(iainia) = gstot(iainia) * gs_distribution(iainia, jv, ilev) !/ lai_total(iainia,jv)
+
+!************************CHECK KIM: gs should not be lower than g0************************************
+                            
+
+                            gs(iainia) = gstot(iainia)*gstot_frac(iainia,jv,ilev) / lai_per_level(iainia,jv,ilev)
+
+                           ! IF (gs(iainia) .gt. gstot(iainia)) THEN
+                           !    gs(iainia) = gstot(iainia)
+                           ! END IF
+                            
+
+                            IF (gs(iainia) .GE. g0(jv)) THEN
+                               assimi(iainia) = (((gs(iainia) - g0(jv)) * (Ca(iainia) - Cs_star)) / fvpd(iainia)) &
+                                  & - Rd(iainia)
+                            ELSE
+                               assimi(iainia) = -Rd(iainia)
+                            ENDIF
+
+                            assimi_store(iainia, jv, ilev) = assimi(iainia)
+
+                            ! WRITE(numout,*) '281113 assimi is: ', assimi
+
+                             IF (assimi(iainia) .lt. min_sechiba) THEN
+                                 assimi(iainia) = 0.0d0
+                             !    WRITE(numout,*) 'assimi(iainia) is negative ***************************************'
+                             !    WRITE(numout,*) 'assimi(iainia) is: ', assimi(iainia)
+                             !    WRITE(numout,*) 'gs(iainia) is: ', gs(iainia)
+                             !    WRITE(numout,*) 'g0(jv) is: ', g0(jv)
+                             !    WRITE(numout,*) 'new_leaf_ci(iainia,jv,ilev) is: ', new_leaf_ci(iainia,jv,ilev)
+                             !    WRITE(numout,*) 'Ca(iainia) is: ', Ca(iainia)
+                             !    WRITE(numout,*) 'Cs_star is: ', Cs_star
+                             !    WRITE(numout,*) 'fvpd(iainia) is: ', fvpd(iainia)
+                             !    WRITE(numout,*) 'Rd(iainia) is: ', Rd(iainia)
+                             !    WRITE(numout,*) '*********************************************************'
+                              ELSE IF (assimi(iainia) .gt. 500.0d0) THEN
+                             !    WRITE(numout,*) 'assimi(iainia) is very large'
+                             !    WRITE(numout,*) 'assimi(iainia) is: ', assimi(iainia)
+                             !    WRITE(numout,*) 'temp_sol(iainia) is: ', temp_sol(iainia)
+                             !    WRITE(numout,*) 'vbeta3(iainia, jv) is: ', vbeta3(iainia, jv)
+                             !    WRITE(numout,*) 'gs(iainia) is: ', gs(iainia)
+                             !    WRITE(numout,*) 'g0(jv) is: ', g0(jv)
+                             !    WRITE(numout,*) 'new_leaf_ci(iainia,jv,ilev) is: ', new_leaf_ci(iainia,jv,ilev)
+                             !    WRITE(numout,*) 'Ca(iainia) is: ', Ca(iainia)
+                             !    WRITE(numout,*) 'Cs_star is: ', Cs_star
+                             !    WRITE(numout,*) 'fvpd(iainia) is: ', fvpd(iainia)
+                             !    WRITE(numout,*) 'Rd(iainia) is: ', Rd(iainia)
+                             !    WRITE(numout,*) 'gstot(iainia) is: ', gstot(iainia)
+                             !    WRITE(numout,*) 'sum_rveget_rstruct(iainia,jv) is: ', sum_rveget_rstruct(iainia,jv)
+                             !    WRITE(numout,*) 'speed is: ', speed
+                             !    WRITE(numout,*) 'q_cdrag(iainia) is: ',q_cdrag(iainia)
+                             !    WRITE(numout,*) 'rveg_pft(jv) is: ', rveg_pft(jv)
+                             !    WRITE(numout,*) 'gstot_frac(iainia,jv,ilev) is: ', gstot_frac(iainia,jv,ilev)
+                             !    WRITE(numout,*) 'lai_per_level(iainia,jv,ilev) is: ', lai_per_level(iainia,jv,ilev)
+                             !    WRITE(numout,*) '*********************************************************'                                
+                              END IF       
+                
+                        ENDIF  ! (hydrol_flag3(iainia, jv))
+
+                        ! with new assimilation rates for the grid squares and the PFTs for
+                        ! which the supply term restriction replies, we let the rest of the
+                        ! routine run its course from here, to calculate gs and gpp (vbeta3
+                        ! remains the same as that calculated within enerbil)
+
+                        ! JR %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+                        ! Eq. 25 of Yin et al. (2009)
+                        ! It should be Cs instead of Ca but it seems that 
+                        ! other equations in Appendix C make use of Ca
+                       ! IF ( ABS( assimi(iainia) + Rd(iainia) ) .LT. min_sechiba ) THEN
+
+!**************CHECK KIM: shouldn't this be done before the calculation of assimi? ***********************************
+                        IF ( gs(iainia) .LT. min_sechiba ) THEN
+                            gs(iainia) = g0(jv)
+                        ENDIF
+                        !      
+
+                     ENDDO
+                     !
+                  ELSE
+                     !
+                     ! @addtogroup Photosynthesis
+                     ! @{   
+                     !
+                     ! 2.4.3 Assimilation for C3 plants (Farqhuar et al., 1980)\n
+                     !! \latexonly
+                     !! \input{jdiffuco_trans_co2_2.4.3.tex}
+                     !! \endlatexonly
+                     ! @}           
+                     !
+                     !
+                     !
+                     A_1=9999.
+
+                     ! See eq. right after eq. 18 of Yin et al. (2009)
+                     DO limit_photo=1,2
+                        ! Is Vc limiting the Assimilation
+                        IF ( limit_photo .EQ. 1 ) THEN
+                           x1 = vc2(iainia)
+                           ! It should be O not Oi (comment from Vuichard)
+                           x2 = KmC(iainia) * ( 1. + Oi / KmO(iainia) )
+                           ! Is J limiting the Assimilation
+                        ELSE
+                           x1 = JJ(iainia)/4.
+                           x2 = 2. * gamma_star(iainia)
+                        ENDIF
+
+
+                        ! See Appendix B of Yin et al. (2009)
+                        a = g0(jv) * ( x2 + gamma_star(iainia) ) + ( fvpd(iainia) ) * ( x1 - Rd(iainia) )
+                        b = Ca(iainia) * ( x1 - Rd(iainia) ) - gamma_star(iainia) * x1 - Rd(iainia) * x2
+                        c = Ca(iainia) + x2 + ( 1./gb(iainia) ) * ( x1 - Rd(iainia) ) 
+                        d = x2 + gamma_star(iainia)
+                        m = fvpd(iainia) / gb(iainia)  
+
+                        p = - ( d + a / gb(iainia) + fvpd(iainia) * c ) / m
+
+                        q = ( d * ( x1 - Rd(iainia) ) + a*c + ( fvpd(iainia) ) * b ) / m
+                        r = - a * b / m
+
+                        ! See Yin et al. (2009) 
+                        QQ = ( (p**2._r_std) - 3._r_std * q) / 9._r_std
+                        UU = ( 2._r_std* (p**3._r_std) - 9._r_std *p*q + 27._r_std *r) /54._r_std
+
+                        IF ( (QQ .GE. 0._r_std) .AND. (ABS(UU/(QQ**1.5_r_std) ) .LE. 1._r_std) ) THEN
+                           PSI = ACOS(UU/(QQ**1.5_r_std))
+                           A_1_tmp = -2._r_std * SQRT(QQ) * COS( PSI / 3._r_std ) - p / 3._r_std
+                           IF (( A_1_tmp .LT. A_1 )) THEN
+                              A_1 = A_1_tmp
+                           ELSE
+                              ! In case, J is not limiting the assimilation
+                              ! we have to re-initialise x1 and x2 values
+                              ! in agreement with a Vc-limited assimilation 
+                              x1 = vc2(iainia)
+                              ! It should be O not Oi (comment from Vuichard)
+                              x2 = KmC(iainia) * ( 1. + Oi / KmO(iainia) )                           
+                           ENDIF
+                        ENDIF
+                     ENDDO
+
+                     IF ( (A_1 .EQ. 9999.) .OR. ( A_1 .LT. (-Rd(iainia)) ) ) THEN
+                        WRITE(numout,*) 'We have a problem in jdiffuco_trans_co2'
+                        WRITE(numout,*) 'no real positive solution found for pft:',jv
+                        WRITE(numout,*) 'temp_sol:',temp_sol(iainia)
+                        WRITE(numout,*) 'vpd:',vpd(iainia)
+                        WRITE(numout,*) 'Setting the solution to -Rd(iainia):',-Rd(iainia)
+                        A_1 = -Rd(iainia)
+                     ENDIF
+                     assimi(iainia) = A_1
+                     ! Eq. 18 of Yin et al. (2009)
+
+                     !++++++++ TEMP +++++++
+                     IF(( x1 - (assimi(iainia) + Rd(iainia) )) == zero)THEN
+                        ! This causes a problem, since we really should not
+                        ! be dividing by zero.  However, it seems to happen
+                        ! fairly rarely, so all we'll do is cycle to the
+                        ! next loop and keep track of this warning so we
+                        ! can look at it afterwards.
+                        warnings(iainia,jv,iwphoto)=warnings(iainia,jv,iwphoto)+un
+
+                        IF(ld_warn)THEN
+                           WRITE(numout,*) 'jdiffuco, Getting ready to divide by zero! C3'
+                           WRITE(numout,*) '( x1 - ( assimi(iainia) + Rd(iainia) ) ', &
+                                ( x1 - (assimi(iainia) + Rd(iainia) ))
+                           WRITE(numout,*) 'x1,assimi(iainia),Rd(iainia): ', &
+                                x1,assimi(iainia),Rd(iainia)
+                           WRITE(numout,*) 'jv,ilev,iainia: ', jv,ilev,iainia
+                        ENDIF
+                        
+                        CYCLE
+
+                     ENDIF
+                     !++++++++++++++++++++++++++++++
+ 
+                     Cc = ( gamma_star(iainia) * x1 + ( assimi(iainia) + Rd(iainia) ) * x2 )  &
+                          / ( x1 - ( assimi(iainia) + Rd(iainia) ) )
+                     ! Eq. 17 of Yin et al. (2009)
+                     ! new_leaf_ci(iainia,jv,ilev) = Cc
+                     new_leaf_ci(iainia,jv,ilev) = Cc  
+                     ! See eq. right after eq. 15 of Yin et al. (2009)
+                     ci_star = gamma_star(iainia) 
+                     ! 
+
+
+                        ! JR %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+                        ! For the cases in which the supply term condition applies, we need
+                        ! to work backwards and calculate gs, and hence assimi for the grid
+                        ! square and PFT in question, from the value of vbeta3 derived in the
+                        ! enerbil code.
+
+                        ! This sequence is for the c3 vegetation types, and should be identical
+                        ! to the c4 loop above, except for the definition of assimi
+
+                        IF (hydrol_flag3(iainia, jv)) THEN
+
+                            !WRITE(numout,*) 'in jdiffuco_trans_co2'
+                            !WRITE(numout,*) '231113 in c3 loop ilev is: ', ilev, 'PFT is: ', jv
+
+                            speed = MAX(min_wind, jwind(iainia))
+
+                            ! first case
+                            ! WRITE(numout,*) '151113 cresist before: ', cresist
+
+                            IF (zqsvegrap(iainia) .lt. 1.0d0) THEN
+                            !calculation of cresist may need to be check 
+                            ! Here may to to devided gradient of spacific
+                            ! humidity, at least which need to consist with the
+                            ! caculation in the diffuco_trans_co2.. 
+                            !cresist = vbeta3(iainia, jv) / &
+                            !     &  ( veget_max(iainia, jv) * (1.0d0 - zqsvegrap(iainia)) + &
+                            !     &  veget_max(iainia, jv) * zqsvegrap(iainia) )
+                             cresist = vbeta3(iainia, jv) / &
+                                  & (veget_max(iainia, jv) * ( un - zqsvegrap(iainia)) + &
+                                  &  veget(iainia,jv) * zqsvegrap(iainia) )        
+                                 
+
+                            ! WRITE(numout,*) 'cresist condition a)'
+                            
+                            ELSE
+
+                            ! cresist = vbeta3(iainia, jv) / &
+                            !      &  ( veget_max(iainia, jv) * zqsvegrap(iainia) )
+
+                            cresist = 0.0d0
+
+                            ! WRITE(numout,*) 'cresist condition b)'
+
+                            END IF
+
+
+                            IF (vbeta23(iainia, jv) .le. &
+                            &  (veget(iainia, jv) * zqsvegrap(iainia) * cresist) ) THEN
+
+                               ! do nothing
+ 
+                            ELSE
+
+                               IF (zqsvegrap(iainia) .lt. 1.0d0) THEN
+
+                               !cresist = (vbeta3(iainia, jv) - vbeta23(iainia, jv)  )  / &
+                               !    & ( veget_max(iainia, jv) * (1.0d0 - zqsvegrap(iainia))  )
+
+                               cresist = vbeta3(iainia, jv) / &
+                                  & (veget_max(iainia, jv) * ( un - zqsvegrap(iainia)) + &
+                                  &  veget(iainia,jv) * zqsvegrap(iainia) )     
+                               ! WRITE(numout,*) 'cresist condition c)'
+                            
+                               ELSE
+
+                               ! cresist = vbeta3(iainia, jv) / &
+                               !      &  ( veget_max(iainia, jv) * zqsvegrap(iainia) )
+
+                               cresist = 0.0d0
+
+                               ! WRITE(numout,*) 'cresist condition d)'
+
+                               END IF
+
+                            END IF !
+
+                            !WRITE(numout,*) '241113 cresist is: ', cresist
+
+                            !*****************************TEMP**************************
+                            !WRITE(*,*) '151113 cresist (jdiffuco_trans_co2) is: ', cresist
+                            !WRITE(*,*) '151113 speed: ', speed
+                            !WRITE(*,*) '151113 cresist (jdiffuco_trans_co2) is: ', q_cdrag(iainia)
+                            !WRITE(*,*) '151113 rveg_pft (jdiffuco_trans_co2) is: ', rveg_pft(jv)
+                            !*****************************TEMP****************************
+
+                            IF (cresist .ne. 0.0d0) THEN
+                                sum_rveget_rstruct(iainia,jv) = &
+                                     & (1.0d0/cresist - 1.0d0) * (1.0d0 / (speed * q_cdrag(iainia) * rveg_pft(jv)))
+                            ELSE
+                                sum_rveget_rstruct(iainia,jv) = &
+                                     & (1.0d0 / (speed * q_cdrag(iainia) * rveg_pft(jv)))
+                            END IF
+
+                            IF (cresist .ne. 0.0d0) THEN
+                                sum_rveget_rstruct(iainia,jv) = &
+                                     & (1.0d0/cresist - 1.0d0) * (1.0d0 / (speed * q_cdrag(iainia) * rveg_pft(jv)))
+                            ELSE
+                                ! sum_rveget_rstruct(iainia,jv) = &
+                                !      & (1.0d0 / (speed * q_cdrag(iainia) * rveg_pft(jv)))
+                                  
+                                sum_rveget_rstruct(iainia,jv) = 0.0d0
+
+                            END IF
+
+                            !WRITE(numout,*) '241113 sub_rveget_rstruct is: ', sum_rveget_rstruct(iainia,jv)
+
+                            vbeta3pot(iainia,jv) = MAX(zero, veget_max(iainia,jv) * cresist)
+
+                              
+                            ! calculate approximate gs, working backwards from vbeta3
+                            !
+                            IF (sum_rveget_rstruct(iainia,jv) .ne. 0.0d0) THEN
+                                gstot(iainia) = 1.0d0 / sum_rveget_rstruct(iainia,jv)
+                            ELSE
+                               ! Need to convert the units of g0
+                               gstot(iainia) = g0(jv)*mmol_to_m_1 *(temp_sol(iainia)/tp_00)*&
+                                    (pb_std/pb(iainia))*ratio_H2O_to_CO2
+                            END IF
+                            
+    
+              
+                            !******CHECK KIM: this what I had for a divide by zero bug fix, for now I keep what's in James update
+                            ! IF (cresist .NE. un .AND. speed .GT. min_sechiba .AND. &
+                            !      & q_cdrag(iainia) .GT. min_sechiba .AND. rveg_pft(jv) .GT. min_sechiba) THEN
+                            ! 
+                            ! sum_rveget_rstruct(iainia,jv) = &
+                            !       & (1.0d0/cresist - 1.0d0) * (1.0d0 / (speed * q_cdrag(iainia) * rveg_pft(jv)))
+                            !ENDIF
+
+                            !WRITE(numout,*) '241113 sub_rveget_rstruct is: ', sum_rveget_rstruct(iainia,jv)
+
+
+                            IF (cresist .lt. min_sechiba) THEN
+                                IF(ld_warn .OR. ld_wstress) THEN
+                                !       WRITE(numout,*) 'cresist is very small or negative   **********************'
+                                !       WRITE(numout,*) 'cresist is: ', cresist
+                                !       WRITE(numout,*) 'vbeta3(iainia, jv) is: ', vbeta3(iainia, jv)
+                                !       WRITE(numout,*) 'veget_max(iainia, jv) is: ', veget_max(iainia, jv)
+                                !       WRITE(numout,*) 'zqsvegrap(iainia) is: ', zqsvegrap(iainia)
+                                !       WRITE(numout,*) '*********************************************************'
+                                ENDIF
+                            ELSE IF (assimi(iainia) .gt. 100.0d0) THEN
+                                WRITE(numout,*) 'assimi(iainia) is very large'
+                            END IF
+
+
+                            IF (gstot(iainia) .gt. 0.0d0) THEN
+                                ! nothing
+                            ELSE
+                                !WRITE(*,*) '121113 gstot .le. 0'
+                            ENDIF
+
+                            ! we assume lai is the sum of lai_per_level over all of the levels
+
+                            ! we now do a unit conversion, from m/s to mol/m^2/s, the reverse
+                            !   of the calculation of section 2.5, below
+
+                            gstot(iainia) =  gstot(iainia) / (mmol_to_m_1 *(temp_sol(iainia)/tp_00)* &
+                                       (pb_std/pb(iainia))*ratio_H2O_to_CO2)
+
+
+
+
+                            gs(iainia) = gstot(iainia)*gstot_frac(iainia,jv,ilev) / lai_per_level(iainia,jv,ilev)
+
+                            IF (gs(iainia) .gt. gstot(iainia)) THEN
+                                gs(iainia) = gstot(iainia)
+                            END IF
+                            
+                            !write(*,*) 'gs_jdiffuco_pft',jv,'ilev',ilev,gs(iainia)
+
+                            ! define gs, based on vbeta3
+
+                            IF (gs(iainia) .GE. g0(jv)) THEN
+                               assimi(iainia) = (((gs(iainia) - g0(jv)) * (new_leaf_ci(iainia,jv,ilev) - ci_star)) / fvpd(iainia)) &
+                                    & - Rd(iainia)
+                            ELSE
+                               assimi(iainia) = -Rd(iainia)
+
+                            ENDIF
+
+                           ! assimi(iainia) = (gs(iainia) - g0(jv)) * (new_leaf_ci(iainia,jv,ilev) - ci_star) / fvpd(iainia) &
+                           !       & - Rd(iainia)
+ 
+                            assimi_store(iainia, jv, ilev) = assimi(iainia)
+
+
+                            ! IF (assimi(iainia) .lt. min_sechiba) THEN
+                            !     WRITE(numout,*) '281113 assimi is: ', assimi
+                            ! END IF
+
+                             IF (assimi(iainia) .lt. min_sechiba) THEN
+                                 assimi(iainia) = 0.0d0
+                             !    WRITE(numout,*) 'assimi(iainia) is negative ***************************************'
+                             !    WRITE(numout,*) 'assimi(iainia) is: ', assimi(iainia)
+                             !    WRITE(numout,*) 'gs(iainia) is: ', gs(iainia)
+                             !    WRITE(numout,*) 'g0(jv) is: ', g0(jv)
+                             !    WRITE(numout,*) 'new_leaf_ci(iainia,jv,ilev) is: ', new_leaf_ci(iainia,jv,ilev)
+                             !    WRITE(numout,*) 'ci_star is: ', ci_star
+                             !    WRITE(numout,*) 'fvpd(iainia) is: ', fvpd(iainia)
+                             !    WRITE(numout,*) 'Rd(iainia) is: ', Rd(iainia)
+                             !    WRITE(numout,*) '*********************************************************'
+                              ELSE IF (assimi(iainia) .gt. 500.0d0) THEN
+                             !    WRITE(numout,*) 'assimi(iainia) is very large'
+                             !    WRITE(numout,*) 'assimi(iainia) is: ', assimi(iainia)
+                             !    WRITE(numout,*) 'temp_sol(iainia) is: ', temp_sol(iainia)
+                             !    WRITE(numout,*) 'vbeta3(iainia, jv) is: ', vbeta3(iainia, jv)
+                             !    WRITE(numout,*) 'gs(iainia) is: ', gs(iainia)
+                             !    WRITE(numout,*) 'g0(jv) is: ', g0(jv)
+                             !    WRITE(numout,*) 'new_leaf_ci(iainia,jv,ilev) is: ', new_leaf_ci(iainia,jv,ilev)
+                             !    WRITE(numout,*) 'ci_star is: ', ci_star
+                             !    WRITE(numout,*) 'Ca(iainia) is: ', Ca(iainia)
+                             !    WRITE(numout,*) 'fvpd(iainia) is: ', fvpd(iainia)
+                             !    WRITE(numout,*) 'Rd(iainia) is: ', Rd(iainia)
+                             !    WRITE(numout,*) 'gstot(iainia) is: ', gstot(iainia)
+                             !    WRITE(numout,*) 'sum_rveget_rstruct(iainia,jv) is: ', sum_rveget_rstruct(iainia,jv)
+                             !    WRITE(numout,*) 'speed is: ', speed
+                             !    WRITE(numout,*) 'q_cdrag(iainia) is: ',q_cdrag(iainia)
+                             !    WRITE(numout,*) 'rveg_pft(jv) is: ', rveg_pft(jv)
+                             !    WRITE(numout,*) 'gstot_frac(iainia,jv,ilev) is: ', gstot_frac(iainia,jv,ilev)
+                             !    WRITE(numout,*) 'lai_per_level(iainia,jv,ilev) is: ', lai_per_level(iainia,jv,ilev)
+                             !    WRITE(numout,*) '*********************************************************'      
+                              END IF
+
+
+
+
+                            ! WRITE(numout,*) '151113 assimi(iainia) (jdiffuco_trans_co2) is: ', assimi(iainia)              
+
+                        ENDIF  ! (hydrol_flag3(iainia, jv))
+ 
+                        ! with new assimilation rates for the grid squares and the PFTs for
+                        ! which the supply term restriction replies, we let the rest of the
+                        ! routine run its course from here, to calculate gs and gpp (vbeta3
+                        ! remains the same as that calculated within enerbil)
+
+                        ! JR %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+                        ! Eq. 25 of Yin et al. (2009)
+                        ! It should be Cs instead of Ca but it seems that 
+                        ! other equations in Appendix C make use of Ca
+                       ! IF ( ABS( assimi(iainia) + Rd(iainia) ) .LT. min_sechiba ) THEN
+                        IF ( gs(iainia) .LT. min_sechiba ) THEN
+                            gs(iainia) = g0(jv)
+                        ELSE
+                            ! gs(iainia) = g0(jv) + ( assimi(iainia) + Rd(iainia) ) / ( Ca(iainia) - Cs_star ) * fvpd(iainia)                    
+                            gs(iainia) = gs(iainia) ! as calculated in loop
+                        ENDIF
+
+
+
+                  ENDIF
+                  
+
+                  !
+                  ! @addtogroup Photosynthesis
+                  ! @{   
+                  !
+                  !! 2.4.4 Estimatation of the stomatal conductance (Ball et al., 1987).\n
+                  !! \latexonly
+                  !! \input{jdiffuco_trans_co2_2.4.4.tex}
+                  !! \endlatexonly
+                  ! @}           
+                  !
+                  !
+                  ! keep stomatal conductance of the levels which we decide
+                  ! are the top levels.  Notice that we multiply by the LAI
+                  ! in the level here, so this is no longer a per leaf quantity,
+                  ! but the whole quantity.
+                  IF ( top_level(iainia,ilev) ) THEN
+                     gs_top(iainia) = gs_top(iainia)+gs(iainia)*lai_per_level(iainia,jv,ilev)
+                     !
+                  ENDIF
+                  !
+                  ! @addtogroup Photosynthesis
+                  ! @{   
+                  !
+                  !! 2.4.5 Integration at the canopy level\n
+                  !! \latexonly
+                  !! \input{jdiffuco_trans_co2_2.4.5.tex}
+                  !! \endlatexonly
+                  ! @}           
+                  ! total assimilation and conductance
+                  !assimtot(iainia) = assimtot(iainia) + &
+                  !     assimi(iainia) * (lai_per_level(ilev+1)-lai_per_level(ilev))
+                  !Rdtot(iainia) = Rdtot(iainia) + &
+                  !     Rd(iainia) * (lai_per_level(ilev+1)-lai_per_level(ilev))
+                  !gstot(iainia) = gstot(iainia) + &
+                  !     gs(iainia) * (lai_per_level(ilev+1)-lai_per_level(ilev))
+                  ! 
+                  !++++++++++++++++++++
+                  ! The equations give the amount of carbon produced per m**2 if
+                  ! leaf surface.  Therefore, since we want GPP in units of m**2 of land surface,
+                  ! we have to multiply by the LAI.
+                  assimtot(iainia) = assimtot(iainia) + &
+                       assimi(iainia) * lai_per_level(iainia,jv,ilev)
+!                       assimi(iainia) 
+                  IF(test_pft == jv .AND. ld_photo)THEN
+                     WRITE(numout,*) 'assimi ',ilev,iainia,assimi(iainia),lai_per_level(iainia,jv,ilev)
+                  ENDIF
+                  Rdtot(iainia) = Rdtot(iainia) + &
+!                       Rd(iainia) 
+                       Rd(iainia) * lai_per_level(iainia,jv,ilev)
+                  gstot(iainia) = gstot(iainia) + &
+                       gs(iainia) * lai_per_level(iainia,jv,ilev)
+!                       gs(iainia) 
+                  ! WRITE(numout,*) '151113 iainia is: ', iainia, 'gs(iainia) is: ', gs(iainia)
+
+                  !
+                 gstot_output(iainia,jv,ilev) = gstot(iainia)
+                 gs_output(iainia,jv,ilev) = gs(iainia)
+                  !
+
+               ENDIF ! if there is absorbed light
+            ENDDO  ! loop over grid points
+         ENDDO gridloop1 ! loop over LAI steps
+
+
+
+         IF (ld_warn .AND. assimtot(iainia) .gt. 20) THEN
+             WRITE(numout,*) 'assimtot is very high'
+             WRITE(numout,*) 'assimtot is: ', assimtot(iainia)
+             DO ilev=1,nlevels_tot
+                 WRITE (numout,*) 'level: ', ilev, ' pft: ', jv , ' assimi_store: ', assimi_store(iainia, jv, ilev), &
+                                     &' lai_per_level: ', lai_per_level(iainia, jv, ilev)
+             END DO
+         END IF
+
+
+
+
+         DO jij = 1, kjpindex
+             IF (hydrol_flag2(jij)) THEN
+                ! WRITE(*,*) '091113 new assimi(grid point) is: ', assimi(jij)
+             END IF
+         END DO !jij =1, nvm
+  
+     ! WRITE(numout,*) '151113b gstot is: ', gstot
+     ! WRITE(numout,*) '151113b lai_per_level is: ', lai_per_level
+
+      ! Due to the water limited by the transpiration, we nned to recalculated 
+      ! the stomata conductance(resistance) for the GPP.
+      ! In this section, the assimlation should be recalculated.
+      
+      !! 2.5 Calculate resistances
+
+         gridloop2: DO inia=1,nia
+            !
+            iainia=index_assi(inia)
+            !
+            ! We hit a fringe case above where we could not
+            ! calculate the GPP.  Skip this loop so we don't
+            ! divide by zero.
+            IF(lskip(iainia)) CYCLE
+
+           ! DO inina=1,nina
+                 IF (hydrol_flag3(iainia, jv)) THEN
+                 !nothing              
+                 ELSE
+                    CYCLE gridloop2
+                 END IF !(hydrol_flag3)
+           ! END DO !inina=1,nina
+
+
+            !++++++ CHECK ++++++
+            ! We introduce ::coupled_lai to calculate the :: vbeta3 
+            ! In an closed canopy not all the leaves fully interact with the
+            ! atmosphere because leaves can shelter each other. In a more open
+            ! canopy most leaves can interact with the atmosphere. We use the
+            ! ratio of lai over ::Pgap as a proxy for the amount of canopy that
+            ! can interact with the atmosphere. Clearly that amount of lai that
+            ! interacts should never exceed the:: total_lai.
+            coupled_lai(iainia, jv) = biomass_to_coupled_lai( biomass(iainia, &
+                 jv, ileaf, icarbon), veget(iainia,jv), jv)
+            
+            total_lai(iainia, jv) = biomass_to_lai( biomass(iainia, jv, ileaf,&
+                 icarbon), jv )
+            
+            gstot(iainia) = gstot(iainia)* (coupled_lai(iainia,jv)/total_lai(iainia,jv))
+            
+           
+            ! WRITE(numout,*) '151113 inia is: ', inia, 'gstot is: ', gstot(iainia)
+            !
+            !! Mean stomatal conductance for CO2 (mol m-2 s-1)
+            gsmean(iainia,jv) = gstot(iainia)
+            !
+            ! cimean is the "mean ci" calculated in such a way that assimilation 
+            ! calculated in enerbil is equivalent to assimtot
+            !
+            IF((assimtot(iainia)+Rdtot(iainia)) .GT. min_sechiba)THEN
+               cimean(iainia,jv) = (gsmean(iainia,jv)-g0(jv)) &
+                    / (fvpd(iainia)*(assimtot(iainia)+Rdtot(iainia))) &
+                    + gamma_star(iainia) 
+            ELSE
+               ! According to Nicolas, this variable is completely diagnostic and not
+               ! used for anything.  If the analytical photosynthesis is unable to find
+               ! a solution for the A_1 coefficients in any of the levels, assimtot will
+               ! be equal to -Rd, which means we will be dividing by zero.  This loop
+               ! is to prevent that, and since cimean is diagnostic is doesn't matter
+               ! what the value is.
+               cimean(iainia,jv) = val_exp
+            ENDIF
+                 
+            ! conversion from umol m-2 (PFT) s-1 to gC m-2 (mesh area) tstep-1
+            gpp(iainia,jv) = assimtot(iainia)*12e-6*veget_max(iainia,jv)*dtradia
+
+            ! IF (gpp(iainia, jv) .lt. min_sechiba) THEN
+            !    WRITE(numout,*) 'gpp is very small ***************************************'
+            !    WRITE(numout,*) 'assimtot(iainia) is: ', assimtot(iainia)
+            !    WRITE(numout,*) 'fvpd(iainia) is: ', fvpd(iainia)
+            !    WRITE(numout,*) 'Rdtot(iainia) is: ', Rdtot(iainia)
+            !    WRITE(numout,*) 'veget_max(iainia,jv) is: ', veget_max(iainia,jv)
+            !    WRITE(numout,*) 'gsmean(iainia,jv) is: ', gsmean(iainia,jv)
+            !    WRITE(numout,*) 'g0(jv) is: ', g0(jv)
+            !    WRITE(numout,*) '*********************************************************'
+            ! ELSE IF (gpp(iainia, jv) .gt. 100.0d0) THEN
+            !    WRITE(numout,*) 'gpp is very large'
+            ! END IF
+
+            !IF(test_grid ==1 .AND. jv == test_pft)THEN
+            !   istep=istep+1
+            !   WRITE(numout,*) 'gpp jdiffuco: ',istep, gpp(iainia,jv), assimtot(iainia),veget_max(iainia,jv)
+            !ENDIF
+
+            ! conversion from (mol m-2 s-1) to (umol m-2 s-1)
+            gsmean(iainia,jv) = gsmean(iainia,jv)*1e-6
+            !
+            ! conversion from mol/m^2/s to m/s
+            !
+            ! As in Pearcy, Schulze and Zimmermann
+            ! Measurement of transpiration and leaf conductance
+            ! Chapter 8 of Plant Physiological Ecology
+            ! Field methods and instrumentation, 1991
+            ! Editors:
+            !
+            !    Robert W. Pearcy,
+            !    James R. Ehleringer,
+            !    Harold A. Mooney,
+            !    Philip W. Rundel
+            !
+            ! ISBN: 978-0-412-40730-7 (Print) 978-94-010-9013-1 (Online)
+            !
+            !
+            !we have already do the unit convertoion in the assimilation loop (gridloop1) 
+            ! 
+            !gstot(iainia) =  mmol_to_m_1 *(temp_sol(iainia)/tp_00)*&
+            !     (pb_std/pb(iainia))*gstot(iainia)*ratio_H2O_to_CO2
+            !gstop(iainia) =  mmol_to_m_1 * (temp_sol(iainia)/tp_00)*&
+            !     (pb_std/pb(iainia))*gs_top(iainia)*ratio_H2O_to_CO2
+             
+            
+            !+++++++++Output some information regarding ::rveget and pft 
+            !IF (jv == test_pft .AND. test_grid == 1) THEN
+             !                  WRITE(numout, '(A20, ES15.5)' ) 'New_Vbeta3:', vbeta3(iainia,jv)
+             !                  WRITE(numout, '(A20, I5)'    ) 'pft type is:    ', jv
+             !                  WRITE(numout, '(A20, ES15.5)') 'New_Gs_total:', gstot(iainia)    
+            !ENDIF
+            !+++++++++++++++++++++++++++++++++++ 
+            
+            !rveget(iainia,jv) = un/gstop(iainia)
+            
+            !+++++CHECK+++++++++++++++++++++++++
+            !For the grass land, we assume that there are still  
+            !some stomata on the other side of its leaves.
+            !IF (.NOT. is_tree(jv) ) THEN
+            !    gstot(iainia) = 1.25_r_std * gstot(iainia)
+            !ENDIF
+            !we try to set rvegt as un/gstot 
+            rveget(iainia,jv) = un/gstot(iainia)
+            
+            IF (lai(iainia, jv) .lt. 0.1d0) THEN
+                rveget_min(iainia,jv) = (defc_plus / kzero(jv)) * (un / 0.1d0)
+            ELSE
+                rveget_min(iainia,jv) = (defc_plus / kzero(jv)) * (un / lai(iainia,jv))
+            END IF
+
+            !
+            ! 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)
+            !
+            !
+            !! wind is a global variable of the diffuco module.
+            speed = MAX(min_wind, jwind(iainia))
+            !
+            ! beta for transpiration
+            !
+            ! Corrections Nathalie - 28 March 2006 - on advices of Fred Hourdin
+            !! Introduction of a potentiometer rveg_pft to settle the rveg+rstruct sum problem in the coupled mode.
+            !! rveg_pft=1 in the offline mode. rveg_pft is a global variable declared in the diffuco module.
+            !vbeta3(iainia,jv) = veget_max(iainia,jv) * &
+            !  (un - zqsvegrap(iainia)) * &
+            !  (un / (un + speed * q_cdrag(iainia) * (rveget(iainia,jv) + &
+            !   rstruct(iainia,jv))))
+
+
+            !! Global resistance of the canopy to evaporation
+            cresist=(un / (un + speed * q_cdrag(iainia) * &
+                 (rveg_pft(jv)*(rveget(iainia,jv) ))))
+
+           !WRITE(*,*) '051113 within jdiffuco_trans_co2 before defn. vbeta3(1,:) is', vbeta3(1,:)
+
+           ! 051113 commenting out the calculation of vbeta3 (as this is already defined, either from 
+           ! the first call to this module or as part of the new enerbil (when constrained by the supply
+           ! term))
+
+!            vbeta3(icinic,jv) = veget_max(icinic,jv) * &
+!                 (un - zqsvegrap(icinic)) * cresist + &
+!    !!                 $          ! Addition Nathalie - June 2006
+!    !!            $          vbeta3(icinic,jv) = vbeta3(icinic,jv) + &
+!                 ! Corrections Nathalie - 09 November 2009 : veget => veget_max
+!    !                 MIN( vbeta23(icinic,jv), veget(icinic,jv) * &
+!                 MIN( vbeta23(icinic,jv), veget_max(icinic,jv) * &
+!     !                 zqsvegrap(icinic) * humrel(icinic,jv) * &
+!                 zqsvegrap(icinic) * cresist )
+            ! Fin ajout Nathalie
+
+           !WRITE(*,*) '051113 within jdiffuco_trans_co2 after defn. vbeta3(1,:) is', vbeta3(1,:)
+
+
+
+
+            ! vbeta3pot for computation of potential transpiration (needed for irrigation)
+           ! vbeta3pot(iainia,jv) = MAX(zero, veget_max(iainia,jv) * cresist)
+
+
+
+
+          ! 211013 - we have derived a new vbeta3 from the enerbil segment
+
+
+       !   WRITE(*,*) '051113 2nd call: vbeta3(iainia, jv) is: ', vbeta3(icinic, jv) 
+       !   WRITE(*,*) '051113 2nd call: veget_max(iainia, jv) is: ', veget_max(icinic, jv) 
+       !   WRITE(*,*) '051113 2nd call: zqsvegrap(iainia) is: ', zqsvegrap(icinic) 
+       !   WRITE(*,*) '051113 2nd call: vbeta23(iainia, jv) is: ', vbeta23(icinic, jv) 
+       !   WRITE(*,*) '051113 2nd call: cresist is: ', cresist 
+
+
+
+
+
+
+          ! first case
+          !WRITE(*,*) '051113 previous cresist: ', cresist
+          !cresist = vbeta3(iainia, jv) / &
+          !      &  ( veget_max(iainia, jv) * (1.0d0 - zqsvegrap(iainia)) + &
+          !      &  veget_max(iainia, jv) * zqsvegrap(iainia) )
+
+
+          !IF (vbeta23(iainia, jv) .le. &
+          !       &  (veget_max(iainia, jv) * zqsvegrap(iainia) * cresist) ) THEN
+             ! do nothing
+          ! ELSE
+          ! cresist = vbeta3(iainia, jv) / &
+          !       & ( veget_max(iainia, jv) * (1.0d0 - zqsvegrap(iainia)) + &
+          !       & vbeta23(iainia, jv) )
+          !cresist = (vbeta3(iainia, jv) - vbeta23(iainia, jv)  )  / &
+          !      & ( veget_max(iainia, jv) * (1.0d0 - zqsvegrap(iainia))  )
+
+          !END IF !
+
+
+
+
+
+
+
+          !WRITE(*,*) '051113 new cresist: ', cresist
+
+
+          !! Potentiometer to set vegetation resistance (unitless)
+
+          !sum_rveget_rstruct(iainia,jv) = &
+          !      & (1.0d0/cresist) * (1.0d0 / (speed * q_cdrag(iainia) * rveg_pft(jv)))
+
+
+
+
+
+
+
+
+          !WRITE(*,*) '051113 previous vbeta3pot: ', vbeta3pot
+          !vbeta3pot(iainia,jv) = MAX(zero, veget_max(iainia,jv) * cresist)
+          !WRITE(*,*) '051113 new vbeta3pot: ', vbeta3pot
+
+
+
+
+
+
+
+       ! vbetaco2 is not used anymore, replaced by gsmean, so I need to rethink the calculation
+       !   of these co-efficients when restriction by the supply term applies
+
+       !   WRITE(*,*) '211013c previous vbetaco2: ', vbetaco2
+       !   vbetaco2(iainia,jv) = veget_max(iainia,jv) * &
+       !      (un / (un + speed * q_cdrag(iainia) * &
+       !      (sum_rveget_rstruct(iainia,jv)))) / O2toCO2_stoechio
+       !   WRITE(*,*) '211013c new vbetaco2: ', vbetaco2
+
+       !   cimean(iainia,jv) = ccanopy(iainia) - &
+       !      assimtot(iainia) / &
+       !      ( vbetaco2(iainia,jv)/veget_max(iainia,jv) * &
+       !      rau(iainia) * speed * q_cdrag(iainia))
+
+
+
+
+!          ! beta for transpiration
+!          !
+!          ! Corrections Nathalie - 28 March 2006 - on advices of Fred Hourdin
+!          !! Introduction of a potentiometer rveg_pft to settle the rveg+rstruct sum problem in the coupled mode.
+!          !! rveg_pft=1 in the offline mode. rveg_pft is a global variable declared in the diffuco module.
+!          !vbeta3(iainia,jv) = veget_max(iainia,jv) * &
+!          !  (un - zqsvegrap(iainia)) * &
+!          !  (un / (un + speed * q_cdrag(iainia) * (rveget(iainia,jv) + &
+!          !   rstruct(iainia,jv))))
+!          !! Global resistance of the canopy to evaporation
+!          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 + &
+!!!$          ! Addition Nathalie - June 2006
+!!!$          vbeta3(iainia,jv) = vbeta3(iainia,jv) + &
+!             ! Corrections Nathalie - 09 November 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
+
+!          ! vbeta3pot for computation of potential transpiration (needed for irrigation)
+!          vbeta3pot(iainia,jv) = MAX(zero, veget_max(iainia,jv) * cresist)
+          !
+          ! beta for assimilation. The difference is that surface 
+          ! covered by rain (un - zqsvegrap(iainia)) is not taken into account
+          ! The factor 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
+          !
+
+!          !! Global resistance of the canopy to CO2 transfer
+!          vbetaco2(iainia,jv) = veget_max(iainia,jv) * &
+!             (un / (un + speed * q_cdrag(iainia) * &
+!             (rveget(iainia,jv) + rstruct(iainia,jv)))) / O2toCO2_stoechio
+          !
+          ! 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 gridloop2 !loop over grid points
+         !
+      ENDIF ! if nia LT zero
+      !
+   ENDDO ! loop over vegetation types
+   !
+   IF (long_print) WRITE (numout,*) ' jdiffuco_trans_co2 done '
+
+   !WRITE (numout,*) 'calling jnetcdf_trans_co2'
+
+    ! this writes canopy profile data from this routine to a seperate netCDF file every time step,
+    !   though it does slow the runtime considerably, so is only for diagnostics
+
+    !CALL jnetcdf_trans_co2(kjpindex, james_netcdf_flag, gs_distribution(1,:,:), gs_output(1,:,:), &
+    !                      & lai_per_level(1,:,:), light_tran_to_level(1,:,:), gs_diffuco_output(1,:,:), &
+    !                      & gstot_output(1,:,:))   
+    
+    
+             
+                          
+    IF(ld_photo)THEN
+       WRITE(numout,*) 'gpp at the end of jdiffuco_trans_co2 ',gpp
+    ENDIF
+
+
+END SUBROUTINE jdiffuco_trans_co2
+
+
+
+ ! ---------------------------------------------------------------------------------------
+
+
+
+  FUNCTION Arrhenius (kjpindex,temp,ref_temp,energy_act) RESULT ( val_arrhenius )
+    !! 0.1 Input variables
+
+    INTEGER(i_std),INTENT(in)                     :: kjpindex          !! Domain size (-)
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)    :: temp              !! Temperature (K)
+    REAL(r_std), INTENT(in)                       :: ref_temp          !! Temperature of reference (K)
+    REAL(r_std),INTENT(in)                        :: energy_act        !! Activation Energy (J mol-1)
+    
+    !! 0.2 Result
+
+    REAL(r_std), DIMENSION(kjpindex)              :: val_arrhenius     !! Temperature dependance based on
+                                                                       !! a Arrhenius function (-)
+    
+    val_arrhenius(:)=EXP(((temp(:)-ref_temp)*energy_act)/(ref_temp*RR*(temp(:))))
+  END FUNCTION Arrhenius
+
+  FUNCTION Arrhenius_modified (kjpindex,temp,ref_temp,energy_act,energy_deact,entropy) RESULT ( val_arrhenius )
+    !! 0.1 Input variables
+
+    INTEGER(i_std),INTENT(in)                     :: kjpindex          !! Domain size (-)
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)    :: temp              !! Temperature (K)
+    REAL(r_std), INTENT(in)                       :: ref_temp          !! Temperature of reference (K)
+    REAL(r_std),INTENT(in)                        :: energy_act        !! Activation Energy (J mol-1)
+    REAL(r_std),INTENT(in)                        :: energy_deact      !! Deactivation Energy (J mol-1)
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)    :: entropy           !! Entropy term (J K-1 mol-1)
+        
+    !! 0.2 Result
+
+    REAL(r_std), DIMENSION(kjpindex)              :: val_arrhenius     !! Temperature dependance based on
+                                                                       !! a Arrhenius function (-)
+    
+    val_arrhenius(:)=EXP(((temp(:)-ref_temp)*energy_act)/(ref_temp*RR*(temp(:))))  &
+         * (1. + EXP( (ref_temp * entropy(:) - energy_deact) / (ref_temp * RR ))) &
+         / (1. + EXP( (temp(:) * entropy(:) - energy_deact) / ( RR*temp(:))))
+         
+  END FUNCTION Arrhenius_modified
+
+
+ ! ---------------------------------------------------------------------------------------
+
+
+ SUBROUTINE jnetcdf_trans_co2(kjpindex, james_netcdf_flag, gs_distribution_in, gs_output_in, &
+                               lai_per_level_in, light_tran_to_level_in, gs_diffuco_output_in, &
+                               gstot_output_in) 
+ 
+    USE netcdf
+
+    IMPLICIT NONE
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                                         :: kjpindex         !! Domain size (unitless)
+
+    CHARACTER(LEN=80)                                                  :: jamescdfname          
+ 
+    REAL(r_std), DIMENSION (nvm, nlevels_tot), INTENT(in)              :: gs_distribution_in     
+    REAL(r_std),DIMENSION (nvm, nlevels_tot), INTENT(in)               :: gs_output_in
+    REAL(r_std),DIMENSION (nvm, nlevels_tot), INTENT(in)               :: gstot_output_in
+    REAL(r_std),DIMENSION (nvm, nlevels_tot), INTENT(in)               :: lai_per_level_in
+    REAL(r_std),DIMENSION (nvm, nlevels_tot), INTENT(in)               :: light_tran_to_level_in
+    REAL(r_std),DIMENSION (nvm, nlevels_tot), INTENT(in)               :: gs_diffuco_output_in
+
+
+    LOGICAL                                                            :: james_netcdf_flag    
+
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std), SAVE                     :: gsd_id
+    INTEGER(i_std), SAVE                     :: gso_id
+    INTEGER(i_std), SAVE                     :: gsto_id
+    INTEGER(i_std), SAVE                     :: lpl_id
+    INTEGER(i_std), SAVE                     :: lttl_id
+    INTEGER(i_std), SAVE                     :: gsdo_id
+
+    INTEGER(i_std)                           :: ii, jj
+    INTEGER(i_std), SAVE                     :: james_step_count    
+
+    INTEGER(i_std), SAVE                     :: iret, iret2, fid, fid2
+    INTEGER(i_std)                           :: TimeDimID, jtid, ts_id, HeightDimID, i
+    INTEGER(i_std)                           :: height_dim_id, height_dim_id2, time_dim_id
+    INTEGER(i_std)                           :: pftno_dim_id
+    INTEGER(i_std)                           :: dimids(3) 
+    INTEGER(i_std), SAVE                     :: tap_id
+    INTEGER, DIMENSION(3)                    :: jstartnc, jcountnc    
+
+
+    jamescdfname = '/home/users/jryder/james.ryder/outputcdf.nc'
+ 
+    IF (james_netcdf_flag) THEN
+
+        james_netcdf_flag = .FALSE.
+        
+        ! james_step_count = 0
+ 
+        ! WRITE(numout,*) 'james_netcdf_flag call here'
+
+        ! âŠ define the parameters here
+ 
+        iret = nf90_create(jamescdfname, nf90_write, fid)
+        
+  
+        ! define the dimensions
+
+        iret = nf90_def_dim(fid, "pftno", nvm, pftno_dim_id)        
+        iret = nf90_def_dim(fid, "height", nlevels_tot, height_dim_id)
+        iret = nf90_def_dim(fid, "time", nf90_unlimited, time_dim_id)
+
+        dimids = (/ pftno_dim_id, height_dim_id, time_dim_id /)
+
+ 
+        ! define the variables
+        iret = nf90_def_var (fid, "gs_distribution_in", nf90_real4, dimids, gsd_id)
+        iret = nf90_def_var (fid, "gs_output_in", nf90_real4, dimids, gso_id)
+        iret = nf90_def_var (fid, "gstot_output_in", nf90_real4, dimids, gsto_id)
+        iret = nf90_def_var (fid, "lai_per_level_in", nf90_real4, dimids, lpl_id)
+        iret = nf90_def_var (fid, "light_tran_to_level_in", nf90_real4, dimids, lttl_id)
+        iret = nf90_def_var (fid, "gs_diffuco_output_in", nf90_real4, dimids, gsdo_id)
+
+ 
+        iret = nf90_enddef (fid)
+         
+    END IF !(james_netcdf_flag)
+
+
+    ! open the netCDF file at each step
+    iret = nf90_open(jamescdfname, nf90_Write, fid) 
+
+    jstartnc = (/ 1, 1, 1 /)  ! vector of integers specifying the index in the variable from 
+                              !   which the first of the data values will be read
+    jcountnc = (/ nvm, nlevels_tot, 1 /)  ! vector of integers specifying the number of indices 
+                                     !   selected along each dimension
+
+    james_step_count = james_step_count + 1    ! this is the time step counter
+    
+        
+    jstartnc(3) = james_step_count   ! (2) refers to the time dimension at present (it 
+                                     !   must always come last)
+ 
+
+    iret = nf90_put_var(fid, gsd_id, gs_distribution_in, start = jstartnc, count = jcountnc) 
+    iret = nf90_put_var(fid, gso_id, gs_output_in, start = jstartnc, count = jcountnc) 
+    iret = nf90_put_var(fid, gsto_id, gstot_output_in, start = jstartnc, count = jcountnc) 
+    iret = nf90_put_var(fid, lpl_id, lai_per_level_in, start = jstartnc, count = jcountnc) 
+    iret = nf90_put_var(fid, lttl_id, light_tran_to_level_in, start = jstartnc, count = jcountnc) 
+    iret = nf90_put_var(fid, gsdo_id, gs_diffuco_output_in, start = jstartnc, count = jcountnc) 
+
+
+
+    ! close the netCDF file and write to disk                   
+    iret = nf90_close(fid)
+
+ 
+ END SUBROUTINE jnetcdf_trans_co2
+
+ 
+ ! ------------------------------------------------------------------------------------------------------------------------------------- 
+
+
+
+END MODULE sechiba_hydrol_arch
Index: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/sechiba_io.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/sechiba_io.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/sechiba_io.f90	(revision 7236)
@@ -0,0 +1,467 @@
+!! 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: 2442 $, $Date: 2014-12-17 23:40:26 +0100 (Wed, 17 Dec 2014) $
+!! 
+!< $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_sechiba/sechiba_io.f90 $
+!< $Date: 2014-12-17 23:40:26 +0100 (Wed, 17 Dec 2014) $
+!< $Author: sebastiaan.luyssaert $
+!< $Revision: 2442 $
+!! IPSL (2006)
+!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!!
+MODULE sechiba_io
+
+  USE defprec
+  USE constantes
+  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
+!$OMP THREADPRIVATE(long_print_setvar)
+
+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)
+      CALL ipslerr(3,'sechiba_io.f90','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)
+      CALL ipslerr(3,'sechiba_io.f90','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: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/sechiba_io_p.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/sechiba_io_p.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/sechiba_io_p.f90	(revision 7236)
@@ -0,0 +1,530 @@
+!! 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 ioipsl
+  USE ioipsl_para
+  USE mod_orchidee_para
+
+  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
+!$OMP THREADPRIVATE(long_print_setvar_p)
+
+CONTAINS 
+
+!! pour declencher les restarts rajoutes avec un parametre 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) THEN
+              ALLOCATE( val_tmp_g(nbp_glo) )
+           ELSE
+              ALLOCATE( val_tmp_g(1) )
+           ENDIF
+           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 )
+           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)
+      CALL ipslerr(3,'sechiba_io_p.f90','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)
+      CALL ipslerr(3,'sechiba_io_p.f90','setvar','','')
+  END IF
+
+  DEALLOCATE(val_tmp)
+  
+END SUBROUTINE r21setvar_p
+
+
+!! Interface for initialising a real 2D array with a scalar parameter from run.def or an other 2D array in argument
+SUBROUTINE r22setvar_p (var, val_exp, key_wd, val_put)
+  
+  ! interface for 2D array to 2D array real
+  ! If a key_wd is set, it is supposed to be a scalar parameter will be read from run.def
+  ! It is not possible to read a 2D variable from run.def
+
+  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
+  REAL(r_std)                                  :: val_scal            !! Temporary variable to read a scalar value from run.def
+  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
+        ! This case only read a scalar value with getin
+        val_scal=val_exp
+        CALL getin_p(key_wd, val_scal)
+        ! If a value was found in run.def, then set val_tmp to this value.
+        IF (val_scal/=val_exp) val_tmp(:,:)=val_scal 
+     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: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/slowproc.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/slowproc.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/slowproc.f90	(revision 7236)
@@ -0,0 +1,6945 @@
+! =================================================================================================================================
+! MODULE       : slowproc
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         Groups the subroutines that: (1) initialize all variables used in 
+!! slowproc_main, (2) prepare the restart file for the next simulation, (3) Update the 
+!! vegetation cover if needed, and (4) handle all slow processes if the carbon
+!! cycle is activated (call STOMATE) or update the vegetation properties (LAI and 
+!! fractional cover) in the case of a run with only SECHIBA.
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	:
+!!
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_sechiba/slowproc.f90 $
+!! $Date: 2014-12-17 23:40:26 +0100 (Wed, 17 Dec 2014) $
+!! $Revision: 2442 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE slowproc
+
+  ! modules used:
+#ifdef __NAGFOR
+  USE,INTRINSIC :: IEEE_ARITHMETIC
+#endif
+
+  USE defprec
+  USE constantes 
+  USE constantes_soil
+  USE pft_parameters
+  USE structures
+  USE ioipsl
+  USE xios_orchidee
+  USE ioipsl_para
+  USE sechiba_io
+  USE interpol_help
+  USE stomate
+  USE stomate_data
+  USE grid
+  USE mod_orchidee_para
+  USE stomate_laieff
+  USE function_library,   ONLY : wood_to_qmheight
+
+  IMPLICIT NONE
+
+  ! Private & public routines
+
+  PRIVATE
+  PUBLIC slowproc_main,slowproc_clear
+
+!!??VB Are these old comments? Questions you have yourself. I'm not clear what it's about anyway.
+  ! Specific To use OLD or NEW interpolation schemes depending on the given arguments
+  ! For interpol the OLD routines correspond to the tag 1.6 and should be dropped ???
+  ! For interpol ONLY the subroutines *_g are used ?? (should delete the others ?)
+  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
+  !
+!!?? Many units are lacking (even flags should be stated as "unitless")
+!!?? You should use a sign (eg. !Â£!) which can be automatically searched and points to obsolete/dispensable variables
+  LOGICAL, SAVE                                   :: l_first_slowproc = .TRUE.  !! Flag to do the initialisation only one time
+!$OMP THREADPRIVATE(l_first_slowproc)
+  REAL(r_std), SAVE                               :: dt_slow                    !! time step of slow processes and STOMATE
+!$OMP THREADPRIVATE(dt_slow)
+  !
+  REAL(r_std), SAVE                                :: slope_default = 0.1
+!$OMP THREADPRIVATE(slope_default)
+  !
+  INTEGER(i_std) , SAVE                           :: veget_update=0             !! update frequency in years for landuse (nb of years)
+!$OMP THREADPRIVATE(veget_update)
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: clayfraction            !! Clayfraction (0-1, unitless)
+!$OMP THREADPRIVATE(clayfraction)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: laimap                  !! LAI map when the LAI is prescribed and not calculated by STOMATE
+!$OMP THREADPRIVATE(laimap)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: soilclass_default
+!$OMP THREADPRIVATE(soilclass_default)
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: veget_nextyear          !! next year fraction of vegetation type (0-1, unitless)
+!$OMP THREADPRIVATE(veget_nextyear)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: frac_nobio_nextyear     !! next year fraction of ice+lakes+cities+... (0-1, unitless)
+!$OMP THREADPRIVATE(frac_nobio_nextyear)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: totfrac_nobio_nextyear  !! next year total fraction of ice+lakes+cities+... (0-1, unitless)
+!$OMP THREADPRIVATE(totfrac_nobio_nextyear)
+
+  ! Update vegetation and bare soil fraction
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_bare_soil    !! total evaporating bare soil fraction 
+!$OMP THREADPRIVATE(tot_bare_soil)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: frac_bare        !! Fraction (of veget_max) of bare soil in each vegetation type           
+!$OMP THREADPRIVATE(frac_bare)
+
+  PUBLIC tot_bare_soil,frac_bare
+
+CONTAINS
+
+!!?? The "brief" section should be more precise (check and drop the "possibly").
+!!?? Rather than "main routine that managed variable utilisation", be more precise:
+!!?? Calls slowproc_init (which intialize variables) ...
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_main
+!!
+!>\BRIEF         Main routine that manage variable initialisation (slowproc_init), 
+!! prepare the restart file with the slowproc variables, update the time variables 
+!! for slow processes, and possibly update the vegetation cover, before calling 
+!! STOMATE in the case of the carbon cycle activated or just update LAI (and possibly
+!! the vegetation cover) for simulation with only SECHIBA   
+!!
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): The subroutine manages 
+!! diverses tasks:
+!! (1) Initializing all variables of slowproc (first call)
+!! (2) Preparation of the restart file for the next simulation with all prognostic variables
+!! (3) Compute and update time variable for slow processes
+!! (4) Update the vegetation cover if there is some land use change (only every years)
+!! (5) Call STOMATE for the runs with the carbone cycle activated (ok_stomate) and compute the respiration
+!!     and the net primary production
+!! (6) Compute the LAI and possibly update the vegetation cover for run without STOMATE 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):  ::co2_flux, ::fco2_lu, ::lai, ::height, ::veget, ::frac_nobio,  
+!! ::veget_max, ::totfrac_nobio, ::soiltype, ::assim_param, ::deadleaf_cover, ::qsintmax,
+!! and resp_maint, resp_hetero, resp_growth, npp that are calculated and stored
+!! in stomate is activated.  
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : 
+! \latexonly 
+! \includegraphics(scale=0.5){SlowprocMainFlow.eps} !PP to be finalize!!)
+! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE slowproc_main (kjit, kjpij, kjpindex, dtradia, date0, &
+       ldrestart_read, ldrestart_write, ldforcing_write, ldcarbon_write, IndexLand, &
+       indexveg, lalo, neighbours, resolution, contfrac, &
+       soiltile, reinf_slope, t2m, t2m_min, temp_sol, &
+       stempdiag, humrel, shumdiag, litterhumdiag, precip_rain, &
+       precip_snow, gpp, deadleaf_cover, assim_param, lai, &
+       frac_age, height, veget, frac_nobio, njsc, &
+       veget_max, totfrac_nobio, qsintmax, rest_id, hist_id, &
+       hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC, co2_flux, &
+       fco2_lu, sinang, circ_class_biomass, circ_class_n, &
+       transpir, stressed, unstressed, transpir_supply, &
+       biomass, ind, lai_per_level, laieff_fit, &
+       vir_transpir_supply, temp_growth, Isotrop_Tran_Tot_p,&
+       sum_veget_diff,stem_plc,psi_stem, psi_leaf, psi_root)
+
+  
+!! INTERFACE DESCRIPTION
+
+!! 0.1 Input variables
+
+    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 - terrestrial pixels only
+    REAL(r_std),INTENT(in)                              :: dtradia             !! Time step of SECHIBA
+    REAL(r_std),INTENT (in)                             :: date0               !! Initial date of what ???
+    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 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 identifier
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)    :: IndexLand           !! Indices of the points on the land map
+    INTEGER(i_std),DIMENSION (kjpindex*nvm), INTENT (in):: indexveg            !! Indices of the points on the vegetation (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. In what ??? indices or 
+                                                                               !! geographical coordinates (lat/lon) ??? 
+    REAL(r_std),DIMENSION(kjpindex,2), INTENT(in)       :: resolution          !! The length of each grid-box in X and Y
+                                                                               !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: contfrac            !! Fraction of continent in the grid (0-1, unitless)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)   :: humrel              !! Relative humidity ("moisture stress") (0-1, unitless)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)   :: transpir            !! transpiration @tex $(kg m^{-2} days^{-1})$ @endtex
+    REAL(r_std), DIMENSION(kjpindex,nvm),INTENT (in)    :: transpir_supply     !! Supply of water for transpiration @tex $(mm dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(kjpindex,nvm),INTENT (in)    :: vir_transpir_supply !! Virtual supply of water for transpiration to deal
+                                                                               !! with water stress when PFT1 becomes vegetated in LCC
+                                                                               !! @tex $(mm dt^{-1})$ @endtex
+    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 (K)
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in)  :: stempdiag           !! Soil temperature (K)
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in)  :: shumdiag            !! Relative soil moisture (0-1, unitless)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: litterhumdiag       !! Litter humidity  (0-1, unitless)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: precip_rain         !! Rain precipitation (mm dt_slow^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: precip_snow         !! Snow precipitation (mm dt_slow^{-1})
+    REAL(r_std),DIMENSION(kjpindex,nvm), INTENT(in)     :: gpp                 !! GPP of total ground area (gC m^{-2} time step^{-1}).  
+                                                                               !! Calculated in sechiba, account for vegetation cover and 
+                                                                               !! effective time step to obtain gpp_d
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)        :: sinang              !! the sine of the solar angle from the horizon (unitless)
+    REAL(r_std),DIMENSION (:,:,:), INTENT (in)          :: Isotrop_Tran_Tot_p  !! Transmitted radiation per level (unitless)
+ 
+!! 0.2 Output variables 
+
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(out)  :: co2_flux            !! CO2 flux per average ground area (gC m^{-2} dt_slow^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: fco2_lu             !! CO2 flux from land-use (without forest management) (gC m^{-2} dt_slow^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: sum_veget_diff      !! A debugging array to see if the amount
+                                                                               !! of vegetated fraction on a pixel changes between
+                                                                               !! this year and next.
+
+!! 0.3 Modified variables
+ 
+   INTEGER(i_std), DIMENSION(kjpindex), INTENT(inout)       :: njsc               !! Index of the dominant soil textural class in the grid cell (1-nscm, unitless)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)     :: lai                !! Leaf area index (m^2 m^{-2})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)     :: height             !! height of vegetation (m)
+    REAL(r_std),DIMENSION (kjpindex,nvm,nleafages), INTENT(inout):: frac_age       !! Age efficacity from STOMATE for isoprene
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)     :: veget              !! Fraction of vegetation type including none biological fraction (unitless)
+    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          !! Maximum fraction of vegetation type including none biological fraction (unitless)
+    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)    :: soiltile           !! Fraction of each soil tile (0-1, unitless)
+    REAL(r_std),DIMENSION (kjpindex), INTENT(inout)          :: reinf_slope        !! slope coef for reinfiltration
+    REAL(r_std),DIMENSION (kjpindex,nvm,npco2),INTENT (inout):: assim_param        !! min+max+opt temperatures & vmax for photosynthesis (K, \mumol m^{-2} s^{-1})
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: deadleaf_cover     !! Fraction of soil covered by dead leaves (unitless)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)     :: qsintmax           !! Maximum water storage on vegetation from interception (mm)
+    REAL(r_std), DIMENSION(kjpindex,nvm,ncirc,nparts,nelements), &
+                                               INTENT(inout) :: circ_class_biomass !!  Biomass components of the model tree  
+                                                                                   !! within a circumference class
+                                                                                   !! class @tex $(g C ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(kjpindex,nvm,ncirc), INTENT(inout)&
+                                                             :: circ_class_n       !! Number of trees within each circumference
+                                                                                   !! class @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(kjpindex,nvm,nparts,nelements),INTENT(inout) &
+                                                             :: biomass            !! Biomass per PFT 
+                                                                                   !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(inout)      :: ind                !! Individuals
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)             :: lai_per_level      !! This is the LAI per vertical level
+                                                                                   !! @tex $(m^{2} m^{-2})$
+    TYPE(laieff_type),DIMENSION (:,:,:), INTENT(inout)       :: laieff_fit         !! Fitted parameters for the effective LAI
+    REAL(r_std),DIMENSION (kjpindex), INTENT(inout)          :: temp_growth        !! Growth temperature (Â°C) - Is equal to t2m_month
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(inout)      :: stressed           !! adjusted ecosystem functioning. Takes the unit of the variable
+                                                                                   !! used as a proxy for waterstress (assigned in sechiba)
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(inout)      :: unstressed         !! initial ecosystem functioning after the first calculation and 
+                                                                                   !! before any recalculations. Takes the unit of the variable used
+                                                                                   !! as a proxy for unstressed.
+   
+!! 0.4 Local variables
+
+    INTEGER(i_std)                                     :: j, jv, ipts, m          !! indices 
+    INTEGER(i_std), SAVE                               :: lcanop               !! canopy levels used for LAI
+!$OMP THREADPRIVATE(lcanop)
+    REAL(r_std)                                        :: tmp_day(1)           !! temporary variable for I/O
+    CHARACTER(LEN=80)                                  :: var_name             !! To store variables names for I/O
+    REAL(r_std), DIMENSION(kjpindex,nvm)               :: resp_maint           !! Maitanance component of autotrophic respiration in (gC m^{-2} dt_slow^{-1})
+    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 component of autotrophic respiration in gC m^{-2} dt_slow^{-1})
+    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
+!$OMP THREADPRIVATE(veget_year)
+    LOGICAL                                            :: land_use_updated     !! logical for landuse
+    LOGICAL, PARAMETER                                 :: check = .FALSE.      !! logical 
+    REAL(r_std), SAVE                                  :: sec_old = zero       !! Time counter for to save the old  
+!$OMP THREADPRIVATE(sec_old)
+   ! REAL(r_std), DIMENSION(kjpindex,nvm)               :: hydrol_stress        !! Water stress accounting for hydraulic architecture for use in stomate 
+    REAL(r_std),DIMENSION (kjpindex,nvmap)             :: veget_ny_map         !! Fraction of vegetation type for PFTs ignoring age classes
+    REAL(r_std),DIMENSION (kjpindex,nvmap)             :: veget_max_temp       !! Fraction of vegetation type for PFTs ignoring age classes
+    REAL(r_std),DIMENSION (kjpindex,nvmap)             :: veget_max_map        !! Fraction of vegetation type for PFTs ignoring age classes
+    INTEGER(i_std)                                     :: ivma,ivm,jvm         !! Indices
+    INTEGER(i_std)                                     :: nfound               !! The number of PFTs for this pixel which have veget_max
+    LOGICAL(r_std),DIMENSION (nvm)                     :: lfound_veget         !! Do we have a given threshold of veget_max on for this pixel?
+    REAL(r_std)                                        :: excess_veg           !! The veget_max which we have to redistribute
+                                                                               !! to other pixels.
+    REAL(r_std)                                        :: nobio_frac_sum_old   !! Total vegetated land for the current year.
+    REAL(r_std)                                        :: nobio_frac_sum_new   !! Total vegetated land for next year.
+    REAL(r_std)                                        :: nobio_diff           !! How much the nonvegetative land coverage changes
+                                                                               !! between the current and next year.i
+    REAL(r_std)                                        :: nobio_scale          !! This scaling factor is trying to redistribute the nobio_diff to new one    
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc), INTENT(inout)  :: stem_plc
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc), INTENT(inout)  :: psi_stem
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc), INTENT(inout)  :: psi_leaf
+   REAL(r_std), DIMENSION(kjpindex,nvm,ncirc), INTENT(inout)  :: psi_root
+
+    !TEMP
+    LOGICAL :: force_eoy
+!_ ================================================================================================================================
+
+! 1 Initialize all variables at the first call 
+!
+
+
+
+    IF (l_first_slowproc) THEN
+
+       ! 1.1 Perform the allocation of all variables, define some files and some flags. 
+       !     Restart file read for Sechiba.
+       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, frac_age, veget, frac_nobio, totfrac_nobio, soiltile, reinf_slope, veget_max, njsc, &
+            & circ_class_biomass, circ_class_n, biomass, lai_per_level, height, lcanop, veget_update, veget_year)
+
+       WRITE(numout,*) 'Calculating a nobio fraction land use 1',frac_nobio
+
+       !
+       ! 1.2 Define Time step in days for stomate
+       dt_days = dt_slow / one_day
+
+       ! 1.3 Set to zero all respiration fluxes
+       resp_maint(:,:)  = zero
+       resp_hetero(:,:) = zero
+       resp_growth(:,:) = zero
+
+       ! 1.4 check time step coherence between slow processes and fast processes
+       IF ( dt_slow .LT. dtradia ) THEN
+          CALL ipslerr(3, 'slowproc.f90',&
+               'slow_processes: time step smaller than forcing time step.',&
+               '','')
+       ENDIF
+
+       ! 1.5 Call stomate to initialize all variables managed in stomate,
+       !     when Stomate is used or when the "watchout"?? diagnostics are requested 
+       IF ( control%stomate_watchout .OR. control%ok_stomate ) THEN
+         CALL stomate_main (kjit, kjpij, kjpindex, dtradia, dt_slow, &
+               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, frac_age, &
+               veget, veget_max, veget_nextyear, totfrac_nobio_nextyear, &
+               rest_id_stom, hist_id_stom, hist_id_stom_IPCC, &
+               co2_flux, fco2_lu, resp_maint, resp_hetero, resp_growth, temp_growth, &
+               sinang, circ_class_biomass, circ_class_n, transpir, stressed, &
+               unstressed, transpir_supply, biomass, ind, lai_per_level, laieff_fit, &
+               vir_transpir_supply,Isotrop_Tran_Tot_p,stem_plc,psi_stem,psi_leaf,psi_root)
+
+       WRITE(numout,*) 'Calculating a nobio fraction land use 2',frac_nobio
+
+          ! Calculate height from biomass
+          DO jv = 2,nvm
+             DO ipts = 1,kjpindex
+
+                IF(veget_max(ipts,jv) == zero)THEN
+                   ! this vegetation type is not present, so no reason to do the 
+                   ! calculation
+                   CYCLE
+                ENDIF
+
+                height(ipts,jv) = wood_to_qmheight(circ_class_biomass(ipts,jv,:,:,icarbon), &
+                  circ_class_n(ipts,jv,:), jv)
+             ENDDO
+          ENDDO
+          height(:,1) = zero
+
+          ! We also need to update veget, since the biomass has possibly been read in
+          ! from the restart file.
+          CALL slowproc_veget (kjpindex, frac_nobio, totfrac_nobio, circ_class_biomass, &
+               circ_class_n, biomass, lai_per_level, lai, veget_max, veget, soiltile)
+
+       ENDIF
+       
+      
+      
+       ! 1.6 Specific run without the carbon cycle (STOMATE not called): 
+       !     Need to initialize some variables that will be used in SECHIBA:
+       !     height, deadleaf_cover, assim_param, lai, qsintmax.
+       IF ( .NOT. control%ok_stomate ) THEN
+
+          CALL slowproc_derivvar (kjpindex, veget, lai, &
+               qsintmax, deadleaf_cover, assim_param, height,temp_growth)
+       ELSE
+          qsintmax(:,:) = qsintcst * veget(:,:) * lai(:,:)
+          qsintmax(:,1) = zero
+       ENDIF
+
+       RETURN
+
+    ENDIF
+
+    ! 2 preparation of a restart file for the next simulation 
+    !  that will contain all pronostic variables to be used
+    !  use restput routine for scalar and restput_p routine for arrays
+    IF (ldrestart_write) THEN
+
+       
+       IF (long_print) &
+            WRITE (numout,*) ' we have to complete restart file with SLOWPROC variables '
+
+       ! 2.1 Write a series of variables controled by slowproc: day
+       ! counter, vegetation fraction, max vegetation fraction, LAI
+       ! variable from stomate, fraction of bare soil, soiltype
+       ! fraction, clay fraction, height of vegetation, map of LAI
+
+       ! write day counter
+       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)
+
+       IF ( control%ok_sechiba ) THEN
+
+          var_name= 'soiltile_frac'
+          CALL restput_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, soiltile, 'scatter',  nbp_glo, index_g)
+          !
+          var_name= 'njsc'
+          CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, REAL(njsc, r_std), 'scatter',  nbp_glo, index_g)
+
+          IF ( control%hydrol_cwrr ) THEN
+             var_name= 'reinf_slope'
+             CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, reinf_slope, 'scatter',  nbp_glo, index_g)
+          END IF
+
+       END IF !( control%ok_sechiba )
+
+       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.
+       !+++CHECK+++
+       ! Unclear what is so tedious about recalculating the height. When stomate is used it can be simply
+       ! derived from circ_class_biomass. When stomate is not used it is prescribed. In stomate and its 
+       ! subroutines height is now recalculated from circ_class_biomass whenever it is needed. this prevents
+       ! a decoupling between biomass and height in the case that both variables are passed. In sechiba and
+       ! its subroutines circ_class_biomass is not updated so height and biomass cannot get decoupled. Because
+       ! sechiba mostly uses height at the pixel level, height rather than biomass is still passed. For
+       ! consistency it would be nice that one day circ_class_biomass is passed to enerbil.f90 and condveg.f90
+       ! rather than height.
+       var_name= 'height'
+       CALL restput_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, height, 'scatter',  nbp_glo, index_g)
+       !+++++++++++
+       !
+       ! Specific case where the LAI is read and not calculated by STOMATE: need to be saved
+       IF (read_lai) THEN     
+          var_name= 'laimap'
+          CALL restput_p (rest_id, var_name, nbp_glo, nvm, 12, kjit, laimap)
+       ENDIF
+       !
+       ! If there is some land use change, write the year for the land use ??? 
+       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
+       
+       ! 2.2 call STOMATE to write specific variables managed by STOMATE in the RESTART files 
+       ! when Stomate is used or when the "watchout"?? diagnostics are requested 
+       IF ( control%stomate_watchout .OR. control%ok_stomate ) THEN
+          CALL stomate_main (kjit, kjpij, kjpindex, dtradia, dt_slow, &
+               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, frac_age, &
+               veget, veget_max, veget_nextyear, totfrac_nobio_nextyear, &
+               rest_id_stom, hist_id_stom, hist_id_stom_IPCC, &
+               co2_flux, fco2_lu, resp_maint, resp_hetero, resp_growth, temp_growth,&
+               sinang,  circ_class_biomass, circ_class_n, transpir, stressed, &
+               unstressed, transpir_supply, biomass, ind, lai_per_level, laieff_fit, &
+               vir_transpir_supply,Isotrop_Tran_Tot_p,stem_plc,psi_stem, psi_leaf, psi_root)
+
+          ! Calculate height from biomass
+          DO jv = 2,nvm
+             DO ipts = 1,kjpindex
+
+                IF(veget_max(ipts,jv) == zero)THEN
+                   ! this vegetation type is not present, so no reason to do the 
+                   ! calculation
+                   CYCLE
+                ENDIF
+
+                height(ipts,jv) = wood_to_qmheight(circ_class_biomass(ipts,jv,:,:,icarbon), &
+                     circ_class_n(ipts,jv,:), jv)
+             ENDDO
+          ENDDO
+          height(:,1) = zero
+
+       ENDIF
+
+       RETURN
+
+    ENDIF
+
+    ! 3 Compute and update all variables linked to the date and time
+    !   counter for the call of STOMATE
+    !
+    ! 3.1 update day counter
+    day_counter = day_counter + dtradia
+    IF (check) WRITE(numout,*) "slowproc: day_counter 3",day_counter
+
+    ! 3.2 Check if we are turning from one day to the next day 
+    !     Assert all slow processes (days and years)
+    IF ( sec_old >= one_day - dtradia .AND.  sec >= zero ) THEN
+
+       ! 3.2.1 reset daily counter
+       day_counter = zero
+       IF (check) WRITE(numout,*) "slowproc: day_counter 2",day_counter
+
+       ! 3.2.2 Activate slow processes
+       do_slow = .TRUE.
+
+       ! 3.2.3 Count the number of days 
+       date = date + nint(dt_days)
+       IF (check) WRITE(numout,*) "New date : ",date, 'year_length ',year_length,kjit
+
+       ! 3.2.4 Calculate if we have just turned into a new year
+       !       Note that: 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
+
+       !+++++ TEMP
+       ! This is basically for Land cover change testing, but in theory
+       ! you can use it for any processes that require the end of year to be set.
+       force_eoy=.FALSE.
+       CALL getin_p('FORCE_EOY',force_eoy)
+       IF(force_eoy)THEN
+          WRITE(numout,*) 'Are we forcing the end of year to be every day? ',force_eoy 
+          EndOfYear = .TRUE.
+       ENDIF
+       !++++++
+    
+    ! 3.3 We are not a new day so that slow processes in STOMATE will
+    ! not be done (but why end of year set to false ???)
+    ELSE
+       do_slow = .FALSE.
+       EndOfYear = .FALSE.
+    ENDIF
+
+    ! 3.4 Reset old time counter to the new value
+    sec_old = sec
+
+    IF ( EndOfYear ) THEN
+       WRITE(numout,*)  'slowproc: EndOfYear is activated.'
+    ENDIF
+
+    ! 4 Define the Land USE and update the vegetation for the next year
+    !   This is done only every "veget_update" years (veget_update correspond
+    !   to a number of years between each vegetation updates)
+    land_use_updated=.FALSE.
+    sum_veget_diff(:)=zero
+    IF ( (land_use) .AND. (veget_update .GT. 0) ) THEN
+
+       ! Check if we are effectively at the end of the year 
+       IF ( EndOfYear ) THEN
+          !
+          veget_year = veget_year + 1
+
+          ! Update of the vegetation cover with Land Use only if 
+          ! the current year match the requested condition (a multiple of
+          ! "veget_update")
+          IF ( MOD(veget_year - veget_year_orig, veget_update) == 0 ) THEN
+          
+             WRITE(numout,*)  'We are updating land use veget for year =' , veget_year
+             
+             ! Call the routine to update the vegetation (output is veget_nextyear)
+             ! If we are using age classes, we have to do this a little differently.
+             IF(nagec .GT. 1)THEN
+
+                veget_max_temp(:,:)=zero
+                DO ivma=1,nvmap
+                   veget_max_temp(:,ivma)=SUM(veget_max(:,start_index(ivma):start_index(ivma)+nagec_pft(ivma)-1),2)
+                ENDDO
+                veget_ny_map(:,:)=zero
+                CALL slowproc_update(kjpindex, lalo, neighbours, resolution, contfrac, &
+                     &               veget_max_temp, frac_nobio, veget_ny_map, frac_nobio_nextyear, veget_year)
+                ! Now we need to change this into the map with age classes. 
+                ! We have the total area for each PFT for next year from the map.  However, we
+                ! do not have the area for each age class; this is only present in the simulation, not the
+                ! maps.  I am going to put all of the vegetmax for a given PFT in only the youngest
+                ! age class for now.  This will be properly taken into account in land_cover_change_main.
+                !  The reason we don't do it here is because the age classes can change between this part
+                ! of the code and between land_cover_change main, due to growth or death.
+                veget_nextyear(:,:)=zero
+                DO ivma=1,nvmap
+                   veget_nextyear(:,start_index(ivma))=veget_ny_map(:,ivma)
+                ENDDO
+
+             ELSE
+                CALL slowproc_update(kjpindex, lalo, neighbours, resolution, contfrac, &
+                     &               veget_max, frac_nobio, veget_nextyear, frac_nobio_nextyear, veget_year)
+             ENDIF
+
+             ! There is a variable in the code, min_vegfrac, which dictates the minimum acceptable size
+             ! of the vegetational coverage.  The maps that we read in may or may not have vegetation
+             ! which respects this limit, so we check for that here.  If we find a fraction less
+             ! than this limit, we divide this fraction up over the remaining PFTs in the grid square.
+             DO ipts=1,kjpindex
+                lfound_veget(:)=.FALSE.
+                nfound=0
+                excess_veg=zero
+
+                ! The total sum of vegetation should never be greater than 1.0, since otherwise
+                ! there will be a negative nobio fraction.  So check for that now, at the 
+                ! beginning, before doing all the other adjustments.  If there is a problem,
+                ! scale all the values by a factor to set it exactly equal to one.
+                nobio_frac_sum_new=SUM(veget_nextyear(ipts,:))
+                IF(nobio_frac_sum_new .GT. un)THEN
+                   WRITE(numout,*) "WARNING: Scaling vegetation fractions location 1"
+                   WRITE(numout,*) "ipts,ivm,nobio_frac_sum_new: ",&
+                        ipts,ivm,nobio_frac_sum_new
+                   CALL ipslerr_p (2,'slowproc_main', 'The nobio fraction of this square on the new map',&
+                        'is negative.  Scaling all vegetation fractions to compensate.  Look for',&
+                        '"WARNING: Scaling vegetation fractions location 1" for more details.')
+                   
+                   veget_nextyear(ipts,:)=veget_nextyear(ipts,:)/nobio_frac_sum_new
+
+                ENDIF
+
+                ! We also want to check to see if the nonbio fraction changes at all.  If it does,
+                ! this needs to be handled different in sapiens_lcchange.  Right now our maps
+                ! might vary by a very small number, close to min_stomate.  If that is the 
+                ! case, we scale the fraction of all vegetation fraction so that the nobio fraction
+                ! is the same size as the previous year.  If the difference in the nobio fraction
+                ! is greater than min_vegfrac, then we have a problem, and someone needs to change
+                ! the maps or fix sapiens_lcchange.
+                nobio_frac_sum_old=SUM(veget_max(ipts,:))
+                nobio_frac_sum_new=SUM(veget_nextyear(ipts,:))
+                nobio_diff=(un-nobio_frac_sum_new)-(un-nobio_frac_sum_old)
+                sum_veget_diff(ipts)=nobio_frac_sum_new-nobio_frac_sum_old
+               
+                IF(ld_lcc .AND. ipts == test_grid)THEN
+                   WRITE(numout,*) 'Difference in nobio fraction between new and old map'
+                   WRITE(numout,*) 'nobio_diff: ',nobio_diff
+                ENDIF
+                
+                ! Is this a real difference, or just something numerical?
+                IF(ABS(nobio_diff) .GT. min_vegfrac)THEN
+                   WRITE(numout,*) 'ipts: ',ipts
+                   WRITE(numout,*) 'ivm  veget_max  veget_nextyear'
+                   DO ivm=1,nvm
+                      WRITE(numout,*) ivm,veget_max(ipts,ivm),veget_nextyear(ipts,ivm)
+                   ENDDO
+                   WRITE(numout,*) 'SUM(veget_max): ',nobio_frac_sum_old
+                   WRITE(numout,*) 'SUM(veget_nextyear): ',nobio_frac_sum_new
+                   IF(lignore_lcc_stops)THEN
+                      CALL ipslerr_p (2,'slowproc_main', 'Not stopping here, but I should be!  Place 1',&
+                           'The difference in nobio fractions between the old and the new maps is',&
+                           'signficiant for this pixel.')
+                      WRITE(numout,'(A,F10.4,A,F10.4,A,I10)') "WARNING: nobio frac coordinate, lat:", &
+                           lalo(kjpindex, 1)," lon:", lalo(kjpindex,2),"ipts:", ipts  
+                      WRITE(numout, *) "WARNING: nobio frac veget_max of each pft: ", veget_nextyear(ipts,:)
+                      WRITE(numout, *) "WARNING: difference is ", sum_veget_diff(ipts)
+                   ELSE
+                      
+                      CALL ipslerr_p (3,'slowproc_main', 'The nobio frac for the new map is significantly different',&
+                           'than that of the old map.  We do not know how to handle this.',& 
+                           'Please change your maps or fix sapiens_lcchange.f90.')
+                   ENDIF
+                   
+                ELSE
+
+                   IF(nobio_diff .GT. zero)THEN
+                      ! Our nobio fraction increases slightly.  We add this
+                      ! difference to excess_veg, which will be distributed
+                      ! over the PFTs.
+                      excess_veg=excess_veg+nobio_diff
+
+                   ELSE
+                      ! Our nobio fraction decreases slightly.  We therefore
+                      ! remove this fraction from excess_veg.  We need to check
+                      ! later to make sure that excess_veg is still positive.
+                      excess_veg=excess_veg-ABS(nobio_diff)
+
+                   ENDIF
+                ENDIF
+
+                IF(ld_lcc .AND. ipts == test_grid)THEN
+                   WRITE(numout,*) 'excess_veg after nobio check'
+                   WRITE(numout,*) 'excess_veg: ',excess_veg
+                ENDIF
+
+                ! Even if the extra fraction is less than
+                ! min_stomate, we'll redistribute it, just
+                ! to be sure since a difference an order
+                ! of magnitude less than min_stomate could cause
+                ! a mass balance error later.
+                DO ivm=1,nvm
+                   IF(veget_nextyear(ipts,ivm) .GT. min_vegfrac)THEN
+                      lfound_veget(ivm)=.TRUE.
+                      nfound=nfound+1
+                   ELSE
+                      excess_veg=excess_veg+veget_nextyear(ipts,ivm)
+                      veget_nextyear(ipts,ivm)=zero
+                   ENDIF
+                ENDDO
+
+                IF(ld_lcc .AND. ipts == test_grid)THEN
+                   WRITE(numout,*) 'excess_veg after lower than min_vegfrac'
+                   WRITE(numout,*) 'excess_veg: ',excess_veg
+                ENDIF
+
+                ! If this threshold is zero, there are numbers like 1e-17 which
+                ! trigger it.  If I used min_stomate, we can get small mass
+                ! balance errors in land cover change.
+                IF(ABS(excess_veg) .GT. min_stomate*0.01)THEN
+                   IF(nfound .LE. 0)THEN
+                      WRITE(numout,*) 'ipts, ivm: ',ipts,ivm
+                      WRITE(numout,*) 'nfound, excess_veg: ',nfound, excess_veg, min_stomate*0.01
+                      DO ivm=1,nvm
+                         WRITE(numout,*) 'veget_nextyear: ',ivm,veget_nextyear(ipts,ivm)
+                      ENDDO
+                      CALL ipslerr_p (2,'slowproc_main', 'When reading in the new PFT maps, we found',&
+                           'a pixel with extra vegetation but',&
+                           'with no PFTs left which to add it to!')
+                      veget_nextyear(ipts,1)=veget_nextyear(ipts,1)+excess_veg
+                      excess_veg=zero 
+                   ENDIF
+
+                   ! We have vegetation to distribute.
+!                   excess_veg=excess_veg/REAL(nfound)
+                   loop1:DO ivm=1,nvm
+                      IF(lfound_veget(ivm))THEN
+                         IF((veget_nextyear(ipts,ivm)+excess_veg) .GT. min_vegfrac .AND.&
+                              (veget_nextyear(ipts,ivm)+excess_veg) .GT. min_stomate)THEN
+                            IF(ld_lcc .AND. ipts == test_grid)THEN
+                               WRITE(numout,*) 'Found a place to put extra map vegetation'
+                               WRITE(numout,*) 'ivm,excess_veg,veget_nextyear: ',&
+                                    ivm,excess_veg,veget_nextyear(ipts,ivm)
+                            ENDIF
+                            veget_nextyear(ipts,ivm)=veget_nextyear(ipts,ivm)+excess_veg
+                            excess_veg=zero
+                            EXIT loop1
+                         ENDIF
+                      ENDIF
+                   ENDDO loop1
+
+                   ! If this threshold is zero, there are numbers like 1e-17 which
+                   ! trigger it.  If I used min_stomate, we can get small mass
+                   ! balance errors in land cover change.
+                   IF(ABS(excess_veg) .GT. min_stomate*0.01)THEN
+                      WRITE(numout,*) 'ipts, ivm: ',ipts,ivm
+                      WRITE(numout,*) 'excess_veg: ',excess_veg
+                      DO jvm=1,nvm
+                         WRITE(numout,*) 'veget_nextyear: ',jvm,veget_nextyear(ipts,jvm)
+                      ENDDO
+                      CALL ipslerr_p (3,'slowproc_main', 'When reading in the new PFT maps, we could',&
+                           'not find a place to dump the extra vegetation!',&
+                           '')
+                   ENDIF
+
+                   IF(ld_lcc .AND. ipts == test_grid)THEN
+                      nobio_frac_sum_old=SUM(veget_max(ipts,:))
+                      nobio_frac_sum_new=SUM(veget_nextyear(ipts,:))
+                      WRITE(numout,*) 'Sum of vegetation fractions'
+                      WRITE(numout,*) 'SUM (new): ',nobio_frac_sum_new
+                      WRITE(numout,*) 'SUM (old): ',nobio_frac_sum_old
+                   ENDIF
+
+                   ! excess_veg might be negative.  This removes a small
+                   ! fraction from every PFT.  We need to check that we did not
+                   ! make any PFT less than min_vegfrac by doing this.
+                   DO ivm=1,nvm
+                      IF(lfound_veget(ivm))THEN
+                         IF(veget_nextyear(ipts,ivm) .LT. min_vegfrac)THEN
+                            WRITE(numout,*) 'ipts, ivm: ',ipts,ivm
+                            DO jvm=1,nvm
+                               WRITE(numout,*) 'veget_nextyear: ',jvm,veget_nextyear(ipts,jvm)
+                            ENDDO
+                            CALL ipslerr_p (3,'slowproc_main', 'When reading in the new PFT maps, we corrected',&
+                                 'vegetation fractions but our corrections reduced one PFT to below',&
+                                 'the detectable limit!')
+                         ENDIF
+                      ENDIF
+                   ENDDO
+
+                ENDIF
+
+             ENDDO
+
+             DO j = 1, nnobio
+                totfrac_nobio_nextyear(:) = totfrac_nobio_nextyear(:) + frac_nobio_nextyear(:,j)
+             ENDDO
+             land_use_updated=.TRUE.
+             !
+          ENDIF
+          !
+          CALL histwrite_p(hist_id, 'sum_veget_diff', kjit, sum_veget_diff(:), kjpindex, indexLand)
+       ENDIF
+    ENDIF 
+    IF (EndOfYear .AND. .NOT. land_use_updated) THEN
+       control%ok_land_cover_change = .FALSE.
+    ENDIF
+
+    ! 5 call STOMATE, either because we want to keep track of
+    !   long-term variables (WATCHOUT case) or just because STOMATE is
+    !   activated
+    IF ( control%stomate_watchout .OR. control%ok_stomate ) THEN
+
+       ! 5.1 call stomate main routine that will call all c-cycle routines       !
+       CALL stomate_main (kjit, kjpij, kjpindex, dtradia, dt_slow, &
+            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, frac_age, &
+            veget, veget_max, veget_nextyear, totfrac_nobio_nextyear, &
+            rest_id_stom, hist_id_stom, hist_id_stom_IPCC, &
+            co2_flux, fco2_lu, resp_maint, resp_hetero, resp_growth, temp_growth, &
+            sinang, circ_class_biomass, circ_class_n, transpir, stressed, &
+            unstressed, transpir_supply, biomass, ind, lai_per_level, laieff_fit, &
+            vir_transpir_supply,Isotrop_Tran_Tot_p,stem_plc,psi_stem,psi_leaf,psi_root)
+
+
+
+       ! Calculate height from biomass
+          DO jv = 2,nvm
+             DO ipts = 1,kjpindex
+
+                IF(veget_max(ipts,jv) == zero)THEN
+                   ! this vegetation type is not present, so no reason to do the 
+                   ! calculation
+                   CYCLE
+                ENDIF
+
+                height(ipts,jv) = wood_to_qmheight(circ_class_biomass(ipts,jv,:,:,icarbon), &
+                  circ_class_n(ipts,jv,:), jv)
+             ENDDO
+          ENDDO
+          height(:,1) = zero
+
+       ! 5.2 output the respiration terms and the net primary
+       !     production (NPP) that are calculated in STOMATE
+
+
+       IF ( control%ok_stomate .AND. control%ok_sechiba ) THEN
+          CALL xios_orchidee_send_field("maint_resp",resp_maint/dt_sechiba)
+          CALL xios_orchidee_send_field("hetero_resp",resp_hetero/dt_sechiba)
+          CALL xios_orchidee_send_field("growth_resp",resp_growth/dt_sechiba)
+
+          CALL histwrite_p(hist_id, 'maint_resp', kjit, resp_maint, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'hetero_resp', kjit, resp_hetero, kjpindex*nvm, indexveg)
+          CALL histwrite_p(hist_id, 'growth_resp', kjit, resp_growth, kjpindex*nvm, indexveg)
+
+          ! 5.2.2 Compute the net primary production as the diff from
+          ! Gross primary productin and the growth and maintenance
+          ! respirations (WHY making separate case for index 1 (bare
+          ! soil) ?)
+          npp(:,1)=zero
+          DO j = 2,nvm
+             npp(:,j) = gpp(:,j) - resp_growth(:,j) - resp_maint(:,j)
+          ENDDO
+
+          CALL xios_orchidee_send_field("npp",npp/dt_sechiba)
+
+          CALL histwrite_p(hist_id, 'npp', kjit, npp, kjpindex*nvm, indexveg)
+
+       ENDIF
+
+       IF ( hist2_id > 0 ) THEN
+          IF ( control%ok_stomate ) THEN
+             CALL histwrite_p(hist2_id, 'maint_resp', kjit, resp_maint, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'hetero_resp', kjit, resp_hetero, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'growth_resp', kjit, resp_growth, kjpindex*nvm, indexveg)
+             CALL histwrite_p(hist2_id, 'npp', kjit, npp, kjpindex*nvm, indexveg)
+          ENDIF
+       ENDIF
+
+    ENDIF
+
+    ! 6 STOMATE is not activated: we have to compute the LAI  
+    !   and possibly update the vegetation fraction if there was
+    !   updated land use 
+    IF ( .NOT. control%ok_stomate ) THEN
+
+       IF (land_use_updated) THEN
+          veget_max(:,:)=veget_nextyear(:,:)
+          frac_nobio(:,:)=frac_nobio_nextyear(:,:)
+       ENDIF
+
+       IF ( do_slow ) THEN
+          !
+          ! 2.2.1 do daily processes if necessary
+          !
+          IF (long_print) WRITE (numout,*) 'slowproc_main : We update the daily variables'
+
+          ! 6.1.1 Updates the LAI each dt_slow (day)
+          CALL slowproc_lai (kjpindex, lcanop,stempdiag, &
+               lalo,resolution,lai,month,day,read_lai,laimap)
+
+          frac_age(:,:,1) = un
+          frac_age(:,:,2) = zero
+          frac_age(:,:,3) = zero
+          frac_age(:,:,4) = zero
+       ENDIF
+
+       ! 6.3 Define the CO2 flux from the grid point to zero (no carbone cycle)
+       co2_flux(:,:) = zero
+
+    ELSE IF (land_use_updated) THEN
+       !
+       frac_nobio(:,:)=frac_nobio_nextyear(:,:)
+       !
+    ENDIF
+
+    !
+    ! 2.4 do daily processes if necessary
+    !
+    IF ( do_slow .OR. land_use_updated ) THEN
+       !
+       ! 2.4.1 updates veget
+       CALL slowproc_veget (kjpindex, frac_nobio, totfrac_nobio, circ_class_biomass, &
+            circ_class_n, biomass, lai_per_level, lai, veget_max, veget, soiltile)
+
+       ! 2.4.2 updates qsintmax and other derived variables
+       IF ( .NOT. control%ok_stomate ) THEN
+          CALL slowproc_derivvar (kjpindex, veget, lai, &
+               qsintmax, deadleaf_cover, assim_param, height, temp_growth)
+       ELSE
+          qsintmax(:,:) = qsintcst * veget(:,:) * lai(:,:)
+          qsintmax(:,1) = zero
+       ENDIF
+       !
+    END IF
+
+    !
+    ! Do some basic tests on the surface fractions updated above
+    !
+    CALL slowproc_checkveget(kjpindex, frac_nobio, veget_max, veget, soiltile)
+
+    IF ( control%ok_sechiba ) THEN
+       CALL xios_orchidee_send_field("tot_bare_soil",tot_bare_soil)
+       CALL xios_orchidee_send_field("frac_bare",frac_bare)
+
+       IF ( .NOT. almaoutput) THEN
+          CALL histwrite_p(hist_id, 'tot_bare_soil', kjit, tot_bare_soil, kjpindex, IndexLand)
+          CALL histwrite_p(hist_id, 'frac_bare', kjit, frac_bare, kjpindex*nvm, indexveg)
+       ENDIF
+    END IF
+  
+    IF (long_print) WRITE (numout,*) ' slowproc_main done '
+
+  END SUBROUTINE slowproc_main
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_init
+!!
+!>\BRIEF         Initialisation of all variables linked to SLOWPROC
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): The subroutine manages 
+!! diverses tasks:
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::lcanop, ::veget_update, ::veget_year,
+!! ::lai, ::veget, ::frac_nobio, ::totfrac_nobio, ::veget_max, ::height, ::soiltype
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+SUBROUTINE slowproc_init (kjit, ldrestart_read, dtradia, date0, kjpindex, IndexLand, lalo, neighbours, resolution, contfrac, &
+       & rest_id, read_lai, lai, frac_age, veget, frac_nobio, totfrac_nobio, soiltile, reinf_slope, veget_max, njsc, &
+       & circ_class_biomass, circ_class_n, biomass, lai_per_level, height, lcanop, veget_update, veget_year)
+
+  !! INTERFACE DESCRIPTION
+
+  !! 0. Parameters values
+  LOGICAL, PARAMETER                                    :: check = .FALSE.!! Flag to check what???
+
+  !! 0.1 input variables and 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 for SECHIBA (fast processes)
+  REAL(r_std), INTENT (in)                              :: date0          !! intial date of the simulation ???
+  INTEGER(i_std), INTENT (in)                           :: kjpindex       !! Domain size - Terrestrial pixels only 
+  INTEGER(i_std), INTENT (in)                           :: rest_id        !! Restart file identifier
+
+  INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)      :: IndexLand      !! Indices of the land 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     !! 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(kjpindex,2), INTENT(in)         :: resolution     !! The length of each grid-box in X and Y
+                                                                          !! @tex $(m)$ @endtex
+  REAL(r_std),DIMENSION (kjpindex), INTENT (in)         :: contfrac       !! Fraction of continent in the grid (unitless)
+  LOGICAL, INTENT(in)                                   :: read_lai       !! Flag related to the read of laimap 
+  REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(IN)         :: circ_class_biomass !!  Biomass components of the model tree  
+                                                                          !! within a circumference class
+                                                                          !! class @tex $(g C ind^{-1})$ @endtex
+  REAL(r_std), DIMENSION(:,:,:), INTENT(IN)             :: circ_class_n   !! Number of trees within each circumference
+                                                                          !! class @tex $(m^{-2})$ @endtex
+  REAL(r_std), DIMENSION(:,:,:,:),INTENT(IN)            :: biomass        !! Biomass per PFT 
+                                                                          !! @tex $(gC m^{-2})$ @endtex
+  !! 0.2 output variables and scalar
+  INTEGER(i_std), INTENT(out)                           :: lcanop         !! Number of Canopy level used to compute LAI
+  INTEGER(i_std), INTENT(out)                           :: veget_update   !! update frequency in timesteps (years or days ??) for landuse
+  INTEGER(i_std), INTENT(out)                           :: veget_year     !! first year for landuse   (year or index ???)
+
+  REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)    :: lai            !! Leaf Area index (m^2 / m^2)
+  REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)    :: veget          !! Fraction of vegetation type (unitless)
+  REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (out) :: frac_nobio     !! Fraction of ice,lakes,cities, ... (unitless)
+  REAL(r_std),DIMENSION (kjpindex), INTENT (out)        :: totfrac_nobio  !! Total fraction of ice+lakes+cities+... (unitless)
+  REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)    :: veget_max      !! Max fraction of vegetation type (unitless)
+  REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)    :: height         !! Height of vegetation or surface in genral ??? (m)
+  REAL(r_std),DIMENSION (kjpindex,nvm,nleafages), INTENT (out):: frac_age !! Age efficacity from STOMATE for isoprene
+  REAL(r_std), DIMENSION (kjpindex,nstm), INTENT(out)   :: soiltile       !! Fraction of each soil tile (0-1, unitless)
+  REAL(r_std), DIMENSION (kjpindex), INTENT(out)        :: reinf_slope    !! slope coef for reinfiltration
+  INTEGER(i_std), DIMENSION(kjpindex), INTENT(out)      :: njsc           !! Index of the dominant soil textural class in the grid cell (1-nscm, unitless)
+  REAL(r_std), DIMENSION(:,:,:), INTENT(out)             :: lai_per_level !! This is the LAI per vertical level
+                                                                          !! @tex $(m^{2} m^{-2})$
+    
+  !! 0.4 local scalar and variables 
+  REAL(r_std)                                           :: tmp_day(1)        !! temporary variable 
+  REAL(r_std)                                           :: tmp_veget_year(1) !! temporary variable
+  REAL(r_std)                                           :: zcanop            !! ???? soil depth taken for canopy
+  INTEGER(i_std)                                        :: vtmp(1)           !! temporary variable
+  REAL(r_std), DIMENSION(nbdl)                          :: zsoil             !! soil depths at diagnostic levels
+  INTEGER(i_std)                                        :: j,l, ivma, ivm    !! Indices
+  CHARACTER(LEN=80)                                     :: var_name          !! To store variables names for I/O
+  INTEGER(i_std)                                        :: ji, jv, ier       !! Indices 
+  LOGICAL                                               :: get_slope
+  REAL(r_std)                                           :: frac_nobio1       !! temporary variable for frac_nobio(see above)
+  REAL(r_std), DIMENSION(kjpindex)                      :: tmp_real
+  REAL(r_std), DIMENSION(kjpindex,nbdl)                 :: stempdiag2_bid    !! matrix to store stempdiag_bid
+  REAL(r_std), DIMENSION (kjpindex,nscm)                :: soilclass         !! Fractions of each soil textural class in the grid cell (0-1, unitless)
+  CHARACTER(LEN=4)                                      :: vegsoil_dist      !! Flag to choose the soil/vegetation distribution
+  !
+  CHARACTER(LEN=30), SAVE                               :: veget_str         !! update frequency for landuse
+!$OMP THREADPRIVATE(veget_str)
+  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 at global scale
+  REAL(r_std), DIMENSION(kjpindex)                      :: frac_crop_tot     !! Total fraction occupied by crops (0-1, unitless)
+  REAL(r_std),DIMENSION (kjpindex,nvmap)                :: veget_max_map     !! Fraction of vegetation type for PFTs ignoring age classes
+  REAL(r_std),DIMENSION (kjpindex,nvmap)                :: veget_ny_map      !! Fraction of vegetation type for PFTs ignoring age classes
+!_ ================================================================================================================================
+
+    ! 1 Allocation and initialisation of the different arrays: clayfraction, veget_nextyear,
+    !   frac_nobio_nextyear
+    !
+
+!!$    IF (long_print) 
+    WRITE (numout,*) "In slowproc_init"
+
+    ALLOCATE (clayfraction(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in clayfraction allocation. We stop. We need kjpindex words = ',kjpindex
+       CALL ipslerr(3, 'slowproc.f90','slowproc_init','','')
+    END IF
+    !? why there is a specific undef for sechiba ?
+    clayfraction(:)=undef_sechiba
+
+    ! Initialisation of the fraction of the different vegetation: Start with 100% of bare soil
+    !? (RISKY to have bare soil index fixed to 1)
+    ALLOCATE (soilclass_default(nscm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in indexveg allocation. We stop. We need nstm words = ',nscm
+       CALL ipslerr(3, 'slowproc.f90','slowproc_init','','')
+    END IF
+    soilclass_default(:)=undef_sechiba
+    !
+    veget_max(:,1) = un
+    veget_max(:,2:nvm) = zero
+    frac_nobio(:,:) = zero
+    totfrac_nobio(:) = zero
+
+    ! Allocation of next year vegetation fraction in case of land use change
+    ier=-1
+    ALLOCATE(veget_nextyear(kjpindex, nvm), STAT=ier)
+    IF (ier/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of veget_nextyear : ",ier
+      CALL ipslerr(3, 'slowproc.f90','slowproc_init','','') 
+    ENDIF
+    veget_nextyear(:,1) = un
+    veget_nextyear(:,2:nvm) = zero
+
+    ! Allocation of the fraction of non biospheric areas 
+    ier=-1
+    ALLOCATE(frac_nobio_nextyear(kjpindex, nnobio), STAT=ier)
+    IF (ier/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of frac_nobio_nextyear : ",ier
+      CALL ipslerr(3, 'slowproc.f90','slowproc_init','','') 
+    ENDIF
+    frac_nobio_nextyear(:,:) = zero
+    
+    ier=-1
+    ALLOCATE(totfrac_nobio_nextyear(kjpindex), STAT=ier)
+    IF (ier/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of totfrac_nobio_nextyear : ",ier
+      CALL ipslerr(3, 'slowproc.f90','slowproc_init','','')  
+    ENDIF
+    !
+    ALLOCATE (tot_bare_soil(kjpindex),STAT=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tot_bare_soil allocation. We stop. We need kjpindex words = ',kjpindex
+       CALL ipslerr(3, 'slowproc.f90','slowproc_init','','') 
+    END IF
+    !
+    ALLOCATE (frac_bare(kjpindex,nvm),STAT=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in frac_bare allocation. We stop. We need kjpindex*nvm words = ',kjpindex*nvm
+       CALL ipslerr(3, 'slowproc.f90','slowproc_init','','') 
+    END IF
+
+!!$    IF (long_print) 
+    WRITE (numout,*) 'slowproc_init : End of allocations'
+
+    !? Danger: it should be rather divided by nnobio if nnobio >1 
+!MM must be corrected when nnobio > 1 !!
+    totfrac_nobio_nextyear(:) = nnobio*un
+
+    ! 2 read the day counter from the restart file: 
+    ! val_exp is a default value to test if the variable exist in the restart file
+    ! tmp_day is the current value of day_counter from the restart file: only readed
+    ! by the main processor (parallelisation)
+    ! Day_counter is set to zero if we are at the first time step of the simulation    
+    !?? BUT DAY_counter is not used anymore: we should remove this variable
+    var_name= 'day_counter'
+    CALL ioconf_setatt_p('UNITS', 'd')
+    CALL ioconf_setatt_p('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
+    ! specific for parallelisation (synchronize day_counter)
+    CALL bcast(day_counter)
+
+!!$    IF (long_print) 
+    WRITE (numout,*) 'slowproc_init : End of allocationsGot restart file set'
+
+    ! get restart value if none were found in the restart file
+    !
+
+    !Config Key   = SECHIBA_DAY
+    !Config Desc  = Time within the day simulated
+    !Config if    = OK_SECHIBA
+    !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.
+    !Config Units = [days]
+    !
+    CALL setvar_p (day_counter, val_exp, 'SECHIBA_DAY', zero)
+
+    var_name= 'veget_max'
+    CALL ioconf_setatt_p('UNITS', '-')
+    CALL ioconf_setatt_p('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)
+
+    !---TEMP---
+!!$    WRITE(numout,*) 'just read in veget_max from restart',veget_max
+    !----------
+
+    ! Get frac_nobio from the restart file 
+    frac_nobio(:,:) = val_exp
+    var_name= 'frac_nobio'
+    CALL ioconf_setatt_p('UNITS', '-')
+    CALL ioconf_setatt_p('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)
+
+    veget_update=0
+
+    !
+    ! control%do_land_use is not activate if land use map won't be updated
+    control%do_land_use = .FALSE.
+    !
+    IF (land_use) THEN
+       !
+       var_name= 'veget_year'
+       CALL ioconf_setatt_p('UNITS', '-')
+       CALL ioconf_setatt_p('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.
+       !Config Units = [years]
+       !
+       veget_update=0
+       WRITE(veget_str,'(a)') '0Y'
+     !?? danger : VEGET_UPDATE now called VEGET_LENGTH in Thomas L. run.def ??!!  
+       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
+       !
+       ! control%do_land_use is activated if update frequency is not zero.
+       IF ( veget_update > 0 ) THEN
+          control%do_land_use = .TRUE.
+       ENDIF
+
+       IF ( veget_update == 0 .AND. control%ok_land_cover_change ) THEN
+          CALL ipslerr_p (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.')
+          control%ok_land_cover_change = .FALSE.
+       ENDIF
+
+    ENDIF
+    !
+    IF (long_print) WRITE (numout,*) 'slowproc_init : End of Land_Use configuration'
+
+    IF ( control%ok_sechiba ) THEN
+       
+       var_name= 'soiltile_frac'
+       CALL ioconf_setatt_p('UNITS', '-')
+       CALL ioconf_setatt_p('LONG_NAME','Fraction of each soil type')
+       CALL restget_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, .TRUE., soiltile, "gather", nbp_glo, index_g)
+
+       ! Test if the soiltile_frac was in restartfile. If not, try the old name 'soiltype_frac'.
+       IF ( ALL(soiltile(:,:) == val_exp ) ) THEN
+          WRITE(numout,*) 'The variable soiltile_frac was not in restart file. Try to read old variable name soiltype_frac instead.'
+          var_name= 'soiltype_frac'
+          CALL restget_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, .TRUE., soiltile, "gather", nbp_glo, index_g)
+       END IF
+
+       IF ( control%hydrol_cwrr ) THEN
+          var_name= 'reinf_slope'
+          CALL ioconf_setatt_p('UNITS', '-')
+          CALL ioconf_setatt_p('LONG_NAME','Slope coef for reinfiltration')
+          CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., reinf_slope, "gather", nbp_glo, index_g)
+       END IF
+       var_name= 'njsc'
+       CALL ioconf_setatt_p('UNITS', '-')
+       CALL ioconf_setatt_p('LONG_NAME','Index of soil type')
+       CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., tmp_real, "gather", nbp_glo, index_g)
+       WHERE ( tmp_real .LT. val_exp )
+          njsc = NINT(tmp_real)
+       ENDWHERE
+       
+    END IF !( control%ok_sechiba ) 
+    !
+    var_name= 'clay_frac'
+    CALL ioconf_setatt_p('UNITS', '-')
+    CALL ioconf_setatt_p('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)
+    !
+    IF (long_print) WRITE (numout,*) 'slowproc_init : End CWRR configuration'
+    !
+    var_name= 'lai'
+    CALL ioconf_setatt_p('UNITS', '-')
+    CALL ioconf_setatt_p('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_p('UNITS', 'm')
+    CALL ioconf_setatt_p('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
+          CALL ipslerr(3, 'slowproc.f90','slowproc_init','','')
+       END IF
+       laimap(:,:,:) = val_exp
+       !
+       var_name= 'laimap'
+       CALL ioconf_setatt_p('UNITS', '-')
+       CALL ioconf_setatt_p('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 used for canopy development (if STOMATE disactivated)
+    !Config If    = OK_SECHIBA and .NOT. OK_STOMATE  
+    !Config Def   = 0.5
+    !Config Help  = The temperature at this soil depth is used to determine the LAI when
+    !Config         STOMATE is not activated.
+    !Config Units = [m]
+    !
+    zcanop = 0.5_r_std
+    CALL setvar_p (zcanop, val_exp, 'SECHIBA_ZCANOP', 0.5_r_std)
+    !
+    ! 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 If    = OK_SECHIBA 
+    !Config Def   = 0.1
+    !Config Help  = Transforms leaf area index into size of interception reservoir
+    !Config         for slowproc_derivvar or stomate
+    !Config Units = [m]
+    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 If    = OK_STOMATE
+    !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.
+    !Config Units = [seconds]
+
+    dt_slow = one_day
+    CALL getin_p('DT_SLOW', dt_slow)
+
+    !
+    ! get restart value if none were found in the restart file
+    !
+    !
+    IF ( impveg ) THEN
+       !
+       !  We are on a point and thus we can read the information from the run.def
+       !
+       !
+       !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.
+       !Config Units = [-]
+       !
+       CALL setvar_p (veget_max, val_exp, 'SECHIBA_VEGMAX', veget_ori_fixed_test_1)
+       IF (SUM(veget_ori_fixed_test_1) > un) THEN
+          CALL ipslerr_p (2,'slowproc_init', &
+             &     'The sum of the fractions of the array SECHIBA_VEGMAX is greater than 1.', &
+             &     'The sum should be equal to 1.', &
+             &     'Check your configuration file.')
+       ENDIF
+
+       !
+       !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.
+       !Config Units = [-]
+       !
+     !?? problem with frac_nobio : everything intialized as if every frac_nobio point is 
+        ! covered with ice sheets (continental ice) 
+     !?? direct calculation possible from vegetmax not possible ?
+       ! 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.
+       !Config Units = [-]
+       !
+       CALL setvar_p (lai, val_exp, 'SECHIBA_LAI', llaimax)
+
+       IF (impsoilt) THEN
+
+          ! If njsc is not in restart file, then initialize soilclass from values 
+          ! from run.def file and recalculate njsc
+          IF ( ALL(njsc(:) .EQ. undef_int )) THEN
+             !Config Key   = SOIL_FRACTIONS
+             !Config Desc  = Fraction of the 3 soil types (0-dim mode)
+             !Config Def   = undef_sechiba
+             !Config If    = IMPOSE_VEG and IMPOSE_SOILT
+             !Config Help  = Determines the fraction for the 3 soil types
+             !Config         in the mesh in the following order : sand loam and clay.
+             !Config Units = [-]
+          
+             soilclass(1,:) = soilclass_default(:)
+             CALL getin_p('SOIL_FRACTIONS',soilclass(1,:))
+             DO ji=2,kjpindex
+                soilclass(ji,:) = soilclass(1,:)
+             ENDDO
+
+             njsc(:) = 0
+             DO ji = 1, kjpindex
+                njsc(ji) = MAXLOC(soilclass(ji,:),1)
+             ENDDO
+          END IF
+
+          !Config Key   = CLAY_FRACTION
+          !Config Desc  = Fraction of the clay fraction (0-dim mode)
+          !Config Def   = 0.2
+          !Config If    = IMPOSE_VEG and IMPOSE_SOIL
+          !Config Help  = Determines the fraction of clay in the grid box.
+          !Config Units = [-] 
+          !
+          CALL setvar_p (clayfraction, val_exp, 'CLAY_FRACTION', clayfraction_default)
+       ELSE
+          IF ( MINVAL(clayfraction) .EQ. MAXVAL(clayfraction) .AND. MAXVAL(clayfraction) .EQ. val_exp .OR. &
+               MINVAL(njsc) .EQ. MAXVAL(njsc) .AND. MAXVAL(njsc) .EQ. undef_int ) THEN
+             
+             CALL slowproc_soilt(kjpindex, lalo, neighbours, resolution, contfrac, soilclass, clayfraction)
+             njsc(:) = 0
+             DO ji = 1, kjpindex
+                njsc(ji) = MAXLOC(soilclass(ji,:),1)
+             ENDDO
+          ENDIF
+       ENDIF
+
+       !Config Key   = REINF_SLOPE
+       !Config Desc  = Slope coef for reinfiltration 
+       !Config Def   = 0.1
+       !Config If    = IMPOSE_VEG
+       !Config Help  = Determines the reinfiltration ratio in the grid box due to flat areas
+       !Config Units = [-]
+       !
+       slope_default=0.1
+       CALL setvar_p (reinf_slope, val_exp, 'SLOPE', slope_default)
+
+       !Config Key   = SLOWPROC_HEIGHT
+       !Config Desc  = Height for all vegetation types 
+       !Config Def   = 0., 30., 30., 20., 20., 20., 15., 15., 15., .5, .6, 1.0, 1.0
+       !Config If    = OK_SECHIBA
+       !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.
+       !Config Units = [m]
+       !
+       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
+
+             ! 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
+                   DO jv=2,nvm
+                      IF (natural(jv)) THEN 
+                         veget_max(:,jv)=zero
+                      ENDIF
+                   ENDDO
+                   !
+                   ! 1. Here we calculate the fraction of crop for each point
+                   frac_crop_tot(:) = zero
+                   ! 2. we sum only on the indexes corresponding to the non_natural pfts
+                   DO jv = 2,nvm
+                      IF (.NOT. natural(jv)) THEN
+                         DO ji = 1, kjpindex               
+                            frac_crop_tot(ji) = frac_crop_tot(ji) + veget_max(ji,jv)
+                         ENDDO
+                      ENDIF
+                   ENDDO
+                   ! 3. we calculate the fraction of bare soil
+                   DO ji = 1, kjpindex
+                      veget_max(ji,1) = un - frac_crop_tot(ji) - 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
+             WRITE(numout,*)  '    Number of age classes = ' , nagec
+             ! Call the routine to update the vegetation (output is veget_nextyear)
+             ! If we are using age classes, we have to do this a little differently.
+             ! We pass fake arrays which get the new vegetation from the maps for
+             ! the PFTs ignoring the age classes, and then we set up the vegetation
+             ! for the age classes using that information.
+             IF(nagec .GT. 1)THEN
+                veget_ny_map(:,:)=zero
+                DO ivma=1,nvmap
+                   veget_ny_map(:,ivma)=SUM(veget_nextyear(:,start_index(ivma):start_index(ivma)+nagec_pft(ivma)-1))
+                ENDDO
+                CALL slowproc_update(kjpindex, lalo, neighbours, resolution, contfrac, &
+                     &               veget_ny_map, frac_nobio_nextyear, veget_max_map, frac_nobio, veget_year, init=.TRUE.)
+                ! Now we need to change this into the map with age classes. 
+                ! Since this is an initialization, I will just assign the whole PFT to the youngest age class.
+                veget_max(:,:)=zero
+                DO ivma=1,nvmap
+                   veget_max(:,start_index(ivma))=veget_max_map(:,ivma)
+                ENDDO
+                
+             ELSE
+                ! 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.)
+             ENDIF
+             !
+             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
+                   !
+                   DO jv = 2, nvm
+                      IF (natural(jv)) THEN 
+                         veget_max(:,jv)=zero
+                      ENDIF
+                   ENDDO
+                   !
+                   ! 1. Here we calculate the fraction of crop for each point
+                   frac_crop_tot(:) = zero
+                   ! 2. we sum only on the indexes corresponding to the non_natural pfts
+                   DO jv = 2, nvm
+                      IF(.NOT. natural(jv)) THEN
+                         DO ji = 1, kjpindex
+                            frac_crop_tot(ji) = frac_crop_tot(ji) + veget_max(ji,jv)
+                         ENDDO
+                      ENDIF
+                   ENDDO
+                   ! 3. we calculate the fraction of bare soil
+                   DO ji = 1, kjpindex
+                      veget_max(ji,1) = un - frac_crop_tot(ji) - 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
+                ! 1 .We calculate the total fraction of crops for each point
+                frac_crop_tot(:) = zero
+                DO jv = 2, nvm  
+                   IF ( .NOT. natural (jv))  THEN
+                      DO ji = 1, kjpindex
+                         frac_crop_tot(ji) = frac_crop_tot(ji) + veget_max(ji,jv)
+                      ENDDO
+                   ENDIF
+                ENDDO
+                ! 2. We add to the fraction of bare soil the fraction of crops
+                DO ji = 1, kjpindex
+                   veget_max(ji,1) = veget_max(ji,1) + frac_crop_tot(ji)
+                ENDDO
+                ! 3. We set the fractions of crops to zero
+                DO jv = 2, nvm                  
+                   IF ( .NOT. natural (jv))  THEN
+                      veget_max(:,jv) = zero
+                   ENDIF
+                ENDDO
+                !-
+             ENDIF
+             !
+          ENDIF
+          !
+       ENDIF
+       !
+       !
+       IF (read_lai) THEN
+
+          !
+          !  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)
+          !
+          ! If we start from scratch, we set lai to zero for consistency with stomate
+          IF ( .NOT. read_lai ) THEN
+             lai(:,:) = zero
+          ENDIF
+          !   
+          frac_age(:,:,1) = un
+          frac_age(:,:,2) = zero
+          frac_age(:,:,3) = zero
+          frac_age(:,:,4) = zero
+
+          ! Make sure that we redo the computation when we will be back in slowproc_main
+          day_counter = dt_slow - dtradia
+
+       ENDIF
+
+       IF ( MINVAL(height) .EQ. MAXVAL(height) .AND. MAXVAL(height) .EQ. val_exp) THEN
+       
+          ! Impose height
+          DO jv = 1, nvm
+             height(:,jv) = height_presc(jv)
+          ENDDO
+
+       ENDIF
+
+       IF ( MINVAL(clayfraction) .EQ. MAXVAL(clayfraction) .AND. MAXVAL(clayfraction) .EQ. val_exp .OR. &
+            MINVAL(njsc) .EQ. MAXVAL(njsc) .AND. MAXVAL(njsc) .EQ. undef_int ) THEN
+
+          CALL slowproc_soilt(kjpindex, lalo, neighbours, resolution, contfrac, soilclass, clayfraction)
+
+          njsc(:) = 0
+          DO ji = 1, kjpindex
+             njsc(ji) = MAXLOC(soilclass(ji,:),1)
+          ENDDO
+       ENDIF
+
+
+       !Config Key   = GET_SLOPE
+       !Config Desc  = Read slopes from file and do the interpolation
+       !Config Def   = .FALSE.
+       !Config If    =
+       !Config Help  = Needed for reading the slopesfile and doing the interpolation. This will be
+       !               used by the re-infiltration parametrization
+       !Config Units = [FLAG]
+       get_slope = .FALSE.
+       CALL getin_p('GET_SLOPE',get_slope)
+       
+       IF ( control%hydrol_cwrr ) THEN
+          IF ( MINVAL(reinf_slope) .EQ. MAXVAL(reinf_slope) .AND. MAXVAL(reinf_slope) .EQ. val_exp .OR. get_slope) THEN
+             
+             CALL slowproc_slope(kjpindex, lalo, neighbours, resolution, contfrac, reinf_slope)
+             
+          ENDIF
+       END IF
+    ENDIF
+
+    WRITE(numout,*) 'almost done with slowproc_init'
+    ! Have a first guess at the vegetation fraction
+    lai_per_level(:,:,:)=zero
+    CALL slowproc_veget (kjpindex, frac_nobio, totfrac_nobio, circ_class_biomass, &
+       circ_class_n, biomass, lai_per_level, lai, veget_max, veget, soiltile)
+
+    l_first_slowproc = .FALSE.
+
+!!$    IF (long_print) 
+    WRITE (numout,*) 'slowproc_init done '
+
+! tzjtexture
+!WRITE(*,*) "tzjtexture soilindex", nscm, njsc
+!
+!DO ji=1,kjpindex
+!IF (njsc(ji) .EQ. 6) njsc(ji)=12
+!ENDDO
+!
+!WRITE(*,*) "tzjtexture soilindex new", njsc
+
+  END SUBROUTINE slowproc_init
+
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_clear
+!!
+!>\BRIEF          Clear all variables related to slowproc and stomate modules  
+!!
+!_ ================================================================================================================================
+
+  SUBROUTINE slowproc_clear 
+
+  ! 1 Reset l_first_slowproc and clear all the variables defined as common for the routines in slowproc 
+
+    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)
+    !
+    IF ( ALLOCATED (soilclass_default)) DEALLOCATE (soilclass_default)
+    !
+    IF (ALLOCATED  (tot_bare_soil)) DEALLOCATE (tot_bare_soil)
+    IF (ALLOCATED  (frac_bare)) DEALLOCATE (frac_bare)
+    !
+
+ ! 2. Clear all the variables in stomate 
+
+    CALL stomate_clear 
+    !
+  END SUBROUTINE slowproc_clear
+
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_derivvar
+!!
+!>\BRIEF         Initializes variables related to the
+!! parameters to be assimilated, the maximum water on vegetation, the vegetation height, 
+!! and the fraction of soil covered by dead leaves and the vegetation height 
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags):
+!! (1) Initialization of the variables relevant for the assimilation parameters  
+!! (2) Intialization of the fraction of soil covered by dead leaves
+!! (3) Initialization of the Vegetation height per PFT
+!! (3) Initialization the maximum water on vegetation for interception with a particular treatement of the PFT no.1
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::qsintmax, ::deadleaf_cover, ::assim_param, ::height  
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE slowproc_derivvar (kjpindex, veget, lai, &
+       qsintmax, deadleaf_cover, assim_param, height, temp_growth)
+
+    !! INTERFACE DESCRIPTION
+
+    !! 0.1 Input scalar and fields 
+    INTEGER(i_std), INTENT (in)                                :: kjpindex       !! Domain size - terrestrial pixels only
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)          :: veget          !! Fraction of pixel covered by PFT. Fraction accounts for none-biological land covers (unitless)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)          :: lai            !! PFT leaf area index (m^{2} m^{-2})
+
+    !! 0.2. Output scalar and fields 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)          :: qsintmax       !! Maximum water on vegetation for interception(mm)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)              :: deadleaf_cover !! fraction of soil covered by dead leaves (unitless)
+    REAL(r_std), DIMENSION (kjpindex,nvm,npco2), INTENT (out)   :: assim_param    !! min+max+opt temperatures & vmax for photosynthesis (K, \mumol m^{-2} s^{-1})
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)          :: height         !! height of the vegetation or surface in general ??? (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)              :: temp_growth    !! growth temperature (Â°C) 
+    !
+    !! 0.3 Local declaration
+    INTEGER(i_std)                                              :: ji, jv         !! Local indices
+!_ ================================================================================================================================
+
+    !
+    ! 1. Initialize (why here ??) the variables revelant for the assimilation parameters
+    !
+    DO jv = 1, nvm
+       assim_param(:,jv,ivcmax) = vcmax_fix(jv)
+    ENDDO
+
+    !
+    ! 2. Intialize the fraction of soil covered by dead leaves 
+    !
+    deadleaf_cover(:) = zero
+
+    !
+    ! 3. Initialize the Vegetation height per PFT
+    !
+    DO jv = 1, nvm
+       height(:,jv) = height_presc(jv)
+    ENDDO
+    !
+    ! 4. Initialize the maximum water on vegetation for interception
+    !
+    qsintmax(:,:) = qsintcst * veget(:,:) * lai(:,:)
+
+    ! Added by Nathalie - July 2006
+    !  Initialize the case of the PFT no.1 to zero 
+    qsintmax(:,1) = zero
+    
+    temp_growth(:)=25.
+
+  END SUBROUTINE slowproc_derivvar
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_mean
+!!
+!>\BRIEF          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! 
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): 
+!! (1) AcumAcuumlm 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::field_main
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE slowproc_mean (npts, n_dim2, dt_tot, dt, ldmean, field_in, field_mean)
+
+    !
+    !! 0 declarations
+
+    !! 0.1 input scalar and variables 
+    INTEGER(i_std), INTENT(in)                           :: npts     !! Domain size- terrestrial pixels only 
+    INTEGER(i_std), INTENT(in)                           :: n_dim2   !! Number of PFTs 
+    REAL(r_std), INTENT(in)                              :: dt_tot   !! Time step of stomate (in days). The period over which the accumulation or the mean is computed 
+    REAL(r_std), INTENT(in)                              :: dt       !! Time step in days 
+    LOGICAL, INTENT(in)                                  :: ldmean   !! Flag to calculate the mean after the accumulation ???
+    REAL(r_std), DIMENSION(npts,n_dim2), INTENT(in)      :: field_in !! Daily field 
+
+    !! 0.3 Modified field; The computed sum or mean field over dt_tot time period depending on the flag ldmean 
+    REAL(r_std), DIMENSION(npts,n_dim2), INTENT(inout)   :: field_mean !! Accumulated field at dt_tot time period or mean field over dt_tot 
+ 
+
+!_ ================================================================================================================================
+
+    !
+    ! 1. Accumulation the field over dt_tot period 
+    !
+    field_mean(:,:) = field_mean(:,:) + field_in(:,:) * dt
+
+    !
+    ! 2. If the flag ldmean set, the mean field is computed over dt_tot period  
+    !
+    IF (ldmean) THEN
+       field_mean(:,:) = field_mean(:,:) / dt_tot
+    ENDIF
+
+  END SUBROUTINE slowproc_mean
+
+
+  
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_long
+!!
+!>\BRIEF        Calculates a temporally smoothed field (field_long) from
+!! instantaneous input fields.Time constant tau determines the strength of the smoothing.
+!! For tau -> infinity??, 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! 
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): 
+!! (1) Testing the time coherence betwen the time step dt and the time tau over which
+!! the rescaled of the mean is performed   
+!!  (2) Computing the rescaled mean over tau period 
+!! MAIN OUTPUT VARIABLE(S): field_long  
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::field_long
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE slowproc_long (npts, n_dim2, dt, tau, field_inst, field_long)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input scalar and fields 
+
+    INTEGER(i_std), INTENT(in)                                 :: npts        !! Domain size- terrestrial pixels only
+    INTEGER(i_std), INTENT(in)                                 :: n_dim2      !! Second dimension of the fields, which represents the number of PFTs
+    REAL(r_std), INTENT(in)                                    :: dt          !! Time step in days   
+    REAL(r_std), INTENT(in)                                    :: tau         !! Integration time constant (has to have same unit as dt!)  
+    REAL(r_std), DIMENSION(npts,n_dim2), INTENT(in)            :: field_inst  !! Instantaneous field 
+
+
+    ! 0.2 modified field
+
+    ! Long-term field
+    REAL(r_std), DIMENSION(npts,n_dim2), INTENT(inout)         :: field_long  !! Mean value of the instantaneous field rescaled at tau time period 
+
+!_ ================================================================================================================================
+
+    !
+    ! 1 test coherence of the time 
+
+    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 of the field over tau 
+
+    field_long(:,:) = ( field_inst(:,:)*dt + field_long(:,:)*(tau-dt) ) / tau
+
+  END SUBROUTINE slowproc_long
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_veget
+!!
+!>\BRIEF        Sum up veget_max and frac_nobio and test if sum is equal to 1.
+!! In case there is a problem, a correction is performed when possible, otherwise
+!! it stops.    
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): 
+!! (1) Summing up frac_nobio and veget_max. Test if the sum is equal to unity.
+!!  If not, when possible a solution is proposed, otherwise the routine stops 
+!! (2) Setting veget to veget_max 
+!! (3) Testing the  lai of a vegetation type. If small the soil part of the pixel is increased
+!! (4) Summing the surface fractions and test if it is equal to 1. If not, when
+!! possible, a solution is given, otherwise the routine stops.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::veget
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE slowproc_veget (kjpindex, frac_nobio, totfrac_nobio, circ_class_biomass, &
+       circ_class_n, biomass, lai_per_level, lai, veget_max, veget, soiltile)
+    !
+    ! 0. Declarations
+    !
+
+    ! 0.1 Input variables 
+    INTEGER(i_std), INTENT(in)                              :: kjpindex    !! Domain size - terrestrial pixels only
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(IN)           :: circ_class_biomass !!  Biomass components of the model tree  
+                                                                           !! within a circumference class
+                                                                           !! class @tex $(g C ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(IN)               :: circ_class_n !! Number of trees within each circumference
+                                                                           !! class @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:),INTENT(IN)              :: biomass     !! Biomass per PFT 
+                                                                           !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(IN)               :: lai_per_level !! This is the LAI per vertical level
+                                                                           !! @tex $(m^{2} m^{-2})$
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in)        :: lai         !! PFT leaf area index (m^{2} m^{-2})LAI
+
+    ! 0.2 Modified variables 
+    REAL(r_std), DIMENSION(kjpindex,nnobio), INTENT(inout)  :: frac_nobio  !! Fraction of the mesh which is covered by ice, lakes, ...
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(inout)     :: veget_max   !! Maximum fraction of vegetation type including 
+                                                                           !! non biological fraction (unitless)
+
+    ! 0.3 Output variables 
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)       :: veget       !! Fraction of pixel covered by PFT. 
+                                                                           !! Fraction accounts for none-biological land covers (unitless)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)          :: totfrac_nobio
+    REAL(r_std), DIMENSION (kjpindex,nstm), INTENT(out)     :: soiltile    !! Fraction of each soil tile (0-1, unitless)
+
+    ! 0.4 Local scalar and varaiables 
+    REAL(r_std), DIMENSION(kjpindex)                        :: fracsum     !! Sum of both fracnobio and veget_max 
+    INTEGER(i_std)                                          :: nbad        !!
+    INTEGER(i_std)                                          :: ilev, ji, jv, jst, ivm !! indices 
+
+    REAL(r_std), DIMENSION(kjpindex,nvm,1)                  :: z_level_loc !! The physical height of the levels used in the
+                                                                           !! effective LAI routines.  Will be equal to zero
+                                                                           !! everywhere in this routine.
+                                                                           !! @tex $(m)$
+    REAL(r_std), DIMENSION(kjpindex,nvm,1)                  :: Pgap        !! The transmission probability of light through to
+                                                                           !! canopy to the soil. (unitless, 0-1)
+    REAL(r_std), DIMENSION(1,kjpindex,nvm)                  :: laieff_temp !! The effective LAI.  Not used here, just need it as an
+                                                                           !! argument in this routine.
+    REAL(r_std), DIMENSION(kjpindex,nvm,1)                  :: lai_per_level_temp !! The total LAI found for the PFT and grid square.
+    REAL(r_std), DIMENSION(kjpindex)                        :: cosang      !! The cosine of the solar zenith angle.
+
+    ! Test Nathalie	
+    REAL(r_std)                                             :: SUMveg      !!
+!_ ================================================================================================================================
+
+    ! 0. Set to zero fractions of frac_nobio and veget_max smaller than min_vegfrac
+    ! I moved this to slowproc_update, due to conflicts with land cover change
+    ! nobio fraction checking.
+!!$    DO ji = 1, kjpindex
+!!$       IF ( SUM(frac_nobio(ji,:)) .LT. min_vegfrac ) THEN
+!!$          frac_nobio(ji,:) = zero
+!!$       ENDIF
+!!$       DO jv = 1, nvm
+!!$          IF ( veget_max(ji,jv) .LT. min_vegfrac ) THEN
+!!$             veget_max(ji,jv) = zero
+!!$          ENDIF
+!!$       ENDDO
+!!$       SUMveg = SUM(frac_nobio(ji,:))+SUM(veget_max(ji,:))
+!!$       frac_nobio(ji,:) = frac_nobio(ji,:)/SUMveg
+!!$       veget_max(ji,:) = veget_max(ji,:)/SUMveg
+!!$    ENDDO
+
+    !
+    ! 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,:)) )
+          IF(lignore_lcc_stops)THEN
+             WRITE(numout,*) 'ERROR: Not stopping, but should stop here in place 123!'
+             frac_nobio(ji,:)=frac_nobio(ji,:)/fracsum(ji)
+             veget_max(ji,:)=veget_max(ji,:)/fracsum(ji)
+             fracsum(ji)=un
+          ELSE
+             CALL ipslerr(3, 'slowproc.f90','slowproc_veget','','')
+          ENDIF
+        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
+    !
+    veget(:,1)=veget_max(:,1)
+    !
+    ! 3. Determine the coverage based on stand structure and LAI.
+    !
+    ! This can only be done if we have trees!
+    IF(control%ok_stomate)THEN
+       ! The veget should be related to the effective LAI if you are looking
+       ! straight down on the canopy.  So let us use the same routine
+       ! that we use for the effective LAI but put the solar angle equal to
+       ! the zenith, zero degrees.  We only need one level at the soil, 
+       ! which makes the calculation faster. Here we take advantage of an 
+       ! optional argument which returns the transmission probability 
+       ! through the canopy.  The transmission  probability will be between 
+       ! zero and one.  This takes into account the canopy structure as well 
+       ! as the LAI thickness.  We set our z_level to be equal to zero 
+       ! since we are interested in how  much reaches the ground.
+       z_level_loc(:,:,:)=zero
+       cosang(:)=un
+       lai_per_level_temp(:,:,:)=zero
+       lai_per_level_temp(:,:,1)=SUM(lai_per_level(:,:,:),3)
+       CALL effective_lai(kjpindex, 1, z_level_loc,  circ_class_biomass, &
+            circ_class_n, veget_max, cosang, biomass, lai_per_level_temp,&
+            laieff_temp, Pgap_out=Pgap(:,:,:))
+
+       ! Now convert the transmission probability (1, light makes it through
+       ! without hitting anything) to veget (1*veget_max, the canopy is
+       ! completely opaque).
+       DO ivm=1,nvm
+          ! We don't want to overwrite the bare soil value, since that
+          ! means something different than the other values.
+          IF(ivm == ibare_sechiba) CYCLE
+          veget(:,ivm)=veget_max(:,ivm)*(un-Pgap(:,ivm,1))
+       ENDDO
+
+       DO ji = 1, kjpindex
+          SUMveg = zero
+          tot_bare_soil(ji) = veget_max(ji,1)
+          DO jv = 2, nvm
+             ! This was the old way to calculate veget.  We replaced it above.
+             !          veget(ji,jv) = veget_max(ji,jv) * ( un - exp( - lai(ji,jv) * ext_coeff(jv) ) )
+             tot_bare_soil(ji) = tot_bare_soil(ji) + (veget_max(ji,jv) - veget(ji,jv))
+             SUMveg = SUMveg + veget(ji,jv)
+          ENDDO
+          SUMveg = SUMveg + tot_bare_soil(ji) + 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,:)
+             WRITE(numout,*)  '              ',tot_bare_soil(ji)
+          ENDIF
+       ENDDO
+
+    ELSE
+
+        ! This is if we are using an LAI map.  This is how it
+       ! was done in the trunk.
+
+       DO ji = 1, kjpindex
+          SUMveg = zero
+          tot_bare_soil(ji) = veget_max(ji,1)
+          DO jv = 2, nvm
+             veget(ji,jv) = veget_max(ji,jv) * ( un - exp( - lai(ji,jv) * ext_coeff(jv) ) )
+             tot_bare_soil(ji) = tot_bare_soil(ji) + (veget_max(ji,jv) - veget(ji,jv))
+             SUMveg = SUMveg + veget(ji,jv)
+          ENDDO
+          SUMveg = SUMveg + tot_bare_soil(ji) + 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,:)
+             WRITE(numout,*)  '              ',tot_bare_soil(ji)
+          ENDIF
+       ENDDO
+
+
+    ENDIF
+
+    !
+    ! 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,:)))
+             CALL ipslerr(3, 'slowproc.f90','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 ji = 1, kjpindex
+          IF ( ABS(fracsum(ji)-un) .GT. EPSILON(un) ) THEN
+             veget_max(ji,1) = veget_max(ji,1) / fracsum(ji)
+          ENDIF
+       ENDDO
+       veget(:,1)=veget_max(:,1)
+       !
+       DO jv = 2, nvm
+          DO ji = 1, kjpindex
+             IF ( ABS(fracsum(ji)-un) .GT. EPSILON(un) ) THEN
+                veget_max(ji,jv) = veget_max(ji,jv) / fracsum(ji)
+                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
+
+    !
+    tot_bare_soil(:) = veget_max(:,1)
+    DO jv = 2, nvm
+       DO ji =1, kjpindex
+          tot_bare_soil(ji) = tot_bare_soil(ji) + (veget_max(ji,jv) - veget(ji,jv))
+       ENDDO
+    END DO
+    
+    DO ji =1, kjpindex
+       IF( veget_max(ji,1) .GT. min_sechiba ) THEN
+          frac_bare(ji,1) = un
+       ELSE
+          frac_bare(ji,1) = zero
+       ENDIF
+    ENDDO
+    DO jv = 2, nvm
+       DO ji =1, kjpindex
+          IF( veget_max(ji,jv) .GT. min_sechiba ) THEN
+             frac_bare(ji,jv) = un - veget(ji,jv)/veget_max(ji,jv)
+          ELSE
+             frac_bare(ji,jv) = zero
+          ENDIF
+       ENDDO
+    ENDDO
+
+    totfrac_nobio(:) = zero
+    DO jv = 1, nnobio
+       totfrac_nobio(:) = totfrac_nobio(:) + frac_nobio(:,jv)
+    ENDDO
+    
+    ! Soiltiles are only used in hydrol, but we fix them in here because some time it might depend
+    ! on a changing vegetation (but then some adaptation should be made to hydrol) and be also used
+    ! in the other modules to perform separated energy balances
+    soiltile(:,:) = zero
+    soiltile(:,1) = totfrac_nobio(:)
+    DO jv = 1, nvm
+       jst = pref_soil_veg(jv)
+       DO ji = 1, kjpindex
+          soiltile(ji,jst) = soiltile(ji,jst) + veget_max(ji,jv)
+!!$          IF (jv==1) THEN
+!!$             soiltile(ji,jst) = soiltile(ji,jst) + tot_bare_soil(ji)
+!!$          ENDIF
+       ENDDO
+    ENDDO
+!!$    ! Avoid soiltile < 0.01
+!!$    DO jst = 1, nstm
+!!$       DO ji = 1, kjpindex
+!!$          IF (soiltile(ji,jst) .LT. 0.01) THEN
+!!$             soiltile(ji,MAXLOC(soiltile(ji,:),1)) = soiltile(ji,MAXLOC(soiltile(ji,:),1)) + soiltile(ji,jst)
+!!$             soiltile(ji,jst) = zero
+!!$          ENDIF
+!!$       ENDDO
+!!$    ENDDO
+
+  END SUBROUTINE slowproc_veget
+ 
+ 
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_lai
+!!
+!>\BRIEF        Do the interpolation of lai for the PFTs in case the laimap is not read   
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): 
+!! (1) Interplation by using the mean value of laimin and laimax for the PFTs    
+!! (2) Interpolation between laimax and laimin values by using the temporal
+!!  variations 
+!! (3) If problem occurs during the interpolation, the routine stops 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::lai
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE slowproc_lai (kjpindex,lcanop,stempdiag,lalo,resolution,lai,mm,dd,read_lai,laimap)
+    !
+    ! 0. Declarations
+    !
+    !! 0.1 Input variables 
+    INTEGER(i_std), INTENT(in)                          :: kjpindex   !! Domain size - terrestrial pixels only
+    INTEGER(i_std), INTENT(in)                          :: lcanop     !! soil level used for LAI
+    INTEGER(i_std), INTENT(in)                          :: mm, dd     !! Number of the month in the year and number of day of the month 
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in)  :: stempdiag  !! Soil temperature (K) ???
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (in)     :: lalo       !! Geogr. coordinates (latitude,longitude) (degrees)
+    REAL(r_std),DIMENSION(kjpindex,2), INTENT(in)       :: resolution     !! The length of each grid-box in X and Y
+                                                                          !! @tex $(m)$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)           :: laimap     !! map of lai read 
+    LOGICAL, INTENT(in)                                 :: read_lai   !! Flag for the reading of laimap 
+
+    !! 0.2 Output
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)   :: lai        !! PFT leaf area index (m^{2} m^{-2})LAI
+
+    !! 0.4 Local
+    INTEGER(i_std)                                      :: ji,jv      !! Local indices 
+!_ ================================================================================================================================
+
+    !
+    IF  ( .NOT. read_lai ) THEN
+    
+       lai(: ,1) = zero
+       ! On boucle sur 2,nvm au lieu de 1,nvm
+       DO jv = 2,nvm
+          SELECT CASE (type_of_lai(jv))
+             
+          CASE ("mean ")
+             !
+             ! 1. do the interpolation between laimax and laimin
+             !
+             lai(:,jv) = undemi * (llaimax(jv) + llaimin(jv))
+             !
+          CASE ("inter")
+             !
+             ! 2. do the interpolation between laimax and laimin
+             !
+             DO ji = 1,kjpindex
+                lai(ji,jv) = llaimin(jv) + tempfunc(stempdiag(ji,lcanop)) * (llaimax(jv) - llaimin(jv))
+             ENDDO
+             !
+          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) 
+             CALL ipslerr(3, 'slowproc.f90','slowproc_lai','','')
+             
+          END SELECT
+          
+       ENDDO
+       !
+    ELSE
+       lai(: ,1) = zero
+       ! On boucle sur 2,nvm au lieu de 1,nvm
+       DO jv = 2,nvm
+
+          SELECT CASE (type_of_lai(jv))
+             
+          CASE ("mean ")
+             !
+             ! 1. force MAXVAL of laimap on lai on this PFT
+             !
+             DO ji = 1,kjpindex
+                lai(ji,jv) = MAXVAL(laimap(ji,jv,:))
+             ENDDO
+             !
+          CASE ("inter")
+             !
+             ! 2. do the interpolation between laimax and laimin
+             !
+             !
+             ! If January
+             !
+             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
+                !
+                ! If December
+                !
+             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
+          !
+             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
+             !
+          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) 
+             CALL ipslerr(3, 'slowproc.f90','slowproc_lai','','')
+             
+          END SELECT
+          
+       ENDDO
+    ENDIF
+
+  END SUBROUTINE slowproc_lai
+
+! SHOULD BE DROPED (not commented) ???
+
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_interlai_OLD
+!!
+!>\BRIEF         Interpolate the LAI map to the grid of the model 
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::laimap
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  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 m 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
+    !
+    !
+    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
+    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
+
+!_ ================================================================================================================================
+    !
+    !
+    !Config Key   = LAI_FILE
+    !Config Desc  = Name of file from which the vegetation map is to be read
+    !Config If    = NOT(LAI_MAP)
+    !Config Def   = 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. 
+    !Config Units = [FILE]
+    !
+    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. ), mincos )*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'
+          WRITE(numout,'(a1)',ADVANCE='NO') '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
+
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_interlai_NEW
+!!
+!>\BRIEF         Interpolate the LAI map to the grid of the model 
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::laimap
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  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 = 1 : latitude, 2 : longitude)
+    REAL(r_std), INTENT(in)             :: resolution(nbpt,2)    !! The size in m 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=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW) 
+                            
+    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                               !! name of the LAI map read
+    INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, it, jj, jv
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_lu, lon_lu    !! latitude and
+                                                                !! longitude, extract from LAI map
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat, lon        !! en 2D ???
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)    :: sub_area     !! the area of the fine grid in the model grid ???
+                                                                !! cf src_global/interpol_help.f90, line 377, called "areaoverlap"
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:)  :: sub_index !! the indexes from the grid boxes from the data that go into the 
+                                                                !! model's boxes  
+                                                                !! cf src_global/interpol_help.f90,line 300, called "ip"
+
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:,:) :: laimap_lu   !! value in LAIMAP
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: resol_lu
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask
+    !
+    REAL(r_std) :: coslat, lmax, lmin, ldelta
+    INTEGER(i_std) :: nix, njx
+    REAL(r_std) :: totarea
+    INTEGER(i_std) :: idi, nbvmax                               !! nbvmax : number of maximum vegetation map
+                                                                !! points in the GCM grid ; idi : its counter
+    CHARACTER(LEN=30) :: callsign                               !! Allows to specify which variable is beeing treated
+    !
+    LOGICAL ::           renormelize_lai  ! flag to force LAI renormelization
+    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   = 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. 
+    !Config Units = [FILE]
+    !
+    filename = 'lai2D.nc'
+    CALL getin_p('LAI_FILE',filename)
+    !
+    !
+    !Config Key   = RENORM_LAI
+    !Config Desc  = flag to force LAI renormelization
+    !Config If    = LAI_MAP
+    !Config Def   = n
+    !Config Help  = If true, the laimap will be renormalize between llaimin and llaimax parameters.
+    !Config Units = [FLAG]
+    !
+    renormelize_lai = .FALSE.
+    CALL getin_p('RENORM_LAI',renormelize_lai)
+
+    !
+    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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_interlai_NEW','','') 
+    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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_interlai_NEW','','') 
+    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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_interlai_NEW','','') 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of resol_lu : ",ALLOC_ERR
+      CALL ipslerr(3, 'slowproc.f90','slowproc_interlai_NEW','','') 
+    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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_interlai_NEW','','') 
+    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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_interlai_NEW','','') 
+    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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_interlai_NEW','','') 
+    ENDIF
+    !
+    ! Consider all points a priori
+    !
+    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 ( ANY(laimap_lu(ip,jp,:,:) < 20.) ) THEN
+             mask(ip,jp) = 1
+          ENDIF
+          !
+          ! Resolution in longitude
+          !
+          coslat = MAX( COS( lat(ip,jp) * pi/180. ), mincos )     
+          IF ( ip .EQ. 1 ) THEN
+             resol_lu(ip,jp,1) = ABS( lon(ip+1,jp) - lon(ip,jp) ) * pi/180. * R_Earth * coslat
+          ELSEIF ( ip .EQ. iml ) THEN
+             resol_lu(ip,jp,1) = ABS( lon(ip,jp) - lon(ip-1,jp) ) * pi/180. * R_Earth * coslat
+          ELSE
+             resol_lu(ip,jp,1) = ABS( lon(ip+1,jp) - lon(ip-1,jp) )/2. * pi/180. * R_Earth * coslat
+          ENDIF
+          !
+          ! Resolution in latitude
+          !
+          IF ( jp .EQ. 1 ) THEN
+             resol_lu(ip,jp,2) = ABS( lat(ip,jp) - lat(ip,jp+1) ) * pi/180. * R_Earth
+          ELSEIF ( jp .EQ. jml ) THEN
+             resol_lu(ip,jp,2) = ABS( lat(ip,jp-1) - lat(ip,jp) ) * pi/180. * R_Earth
+          ELSE
+             resol_lu(ip,jp,2) =  ABS( lat(ip,jp-1) - lat(ip,jp+1) )/2. * pi/180. * R_Earth
+          ENDIF
+          !
+       ENDDO
+    ENDDO
+    !
+    ! The number of maximum vegetation map points in the GCM grid is estimated.
+    ! Some lmargin is taken.
+    !
+    IF (is_root_prc) THEN
+       nix=INT(MAXVAL(resolution_g(:,1))/minval(resol_lu(:,:,1)))+1
+       njx=INT(MAXVAL(resolution_g(:,2))/minval(resol_lu(:,:,2)))+1
+       nbvmax = nix*njx
+    ENDIF
+    CALL bcast(nbvmax)
+    !
+    callsign = 'LAI map'
+    !
+    ok_interpol = .FALSE.
+    DO WHILE ( .NOT. ok_interpol )
+       WRITE(numout,*) "Projection arrays for ",callsign," : "
+       WRITE(numout,*) "nbvmax = ",nbvmax, nix, njx
+       !
+       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
+          CALL ipslerr(3, 'slowproc.f90','slowproc_interlai_NEW','','') 
+       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
+          CALL ipslerr(3, 'slowproc.f90','slowproc_interlai_NEW','','') 
+       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
+          !
+       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
+    !
+    ! Normelize the read LAI by the values SECHIBA is used to
+    !
+    IF ( renormelize_lai ) THEN
+       DO ib=1,nbpt
+          DO jv=1,nvm
+             lmax = MAXVAL(laimap(ib,jv,:))
+             lmin = MINVAL(laimap(ib,jv,:))
+             ldelta = lmax-lmin
+             IF ( ldelta < min_sechiba) THEN
+                ! LAI constante ... keep it constant
+                laimap(ib,jv,:) = (laimap(ib,jv,:)-lmin)+(llaimax(jv)+llaimin(jv))/deux
+             ELSE
+                laimap(ib,jv,:) = (laimap(ib,jv,:)-lmin)/(lmax-lmin)*(llaimax(jv)-llaimin(jv))+llaimin(jv)
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDIF
+    !
+    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)
+    DEALLOCATE (resol_lu)
+    !
+    RETURN
+    !
+  END SUBROUTINE slowproc_interlai_NEW
+
+! NOT COMMENTED YET!
+
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_update
+!!
+!>\BRIEF          Interpolate a vegetation map (by pft) NEED TO BE DONE!!!!!!!!
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  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 !)
+    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 m 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,nvmap), 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,nvmap), 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
+    !
+    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
+    INTEGER                  :: max_index                     ! The location of the maximum value in a vector
+    LOGICAL                  :: ltemp                          ! A check for NaN values
+    REAL(r_std)                                             :: SUMveg      !!
+    LOGICAL                  :: linterpolate_pft_maps                      !! See Config documentation below
+    REAL(r_std)                                             :: new_sum,old_sum    !! Sums of vegetation fractions for
+                                                                                  !! the new and old land cover maps
+    
+!_ ================================================================================================================================
+    !
+    !Config Key   = VEGETATION_FILE
+    !Config Desc  = Name of file from which the vegetation map is to be read
+    !Config If    = LAND_USE
+    !Config Def   = PFTmap.nc
+    !Config Help  = The name of the file to be opened to read a vegetation
+    !Config         map (in pft) is to be given here. 
+    !Config Units = [FILE]
+    !
+    filename = 'PFTmap.nc'
+    CALL getin_p('VEGETATION_FILE',filename)
+    !
+    !
+    !Config Key   = INTERPOLATE_PFT_MAP
+    !Config Desc  = If true, the vegetation maps (both new and old) are interpolated.
+    !Config If    = LAND_USE
+    !Config Def   = TRUE
+    !Config Help  = If TRUE, the PFT map is interpolated to be on the same grid as the
+    !Config         forcing file.  If false, only the value for the grid point with the
+    !COnfig         largest sub area is used.  CAUTION: Only to be used if you have
+    !Config         interpolated the PFT maps to match the forcing maps yourself!
+    !Config Units = [-]
+    !
+    linterpolate_pft_maps = .TRUE.
+    CALL getin_p('INTERPOLATE_PFT_MAP',linterpolate_pft_maps)
+    !
+    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)
+
+    tml=0	!@FM_130917
+    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)
+    ELSE
+       tml=0
+    END IF
+    WRITE(numout,*) "tml =",tml
+
+    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)
+
+    ! This is a check to see if the number of PFTs in the map is equal to the
+    ! number of PFTs in our simulation.  That's a good check.  However, in the
+    ! case we are using age classes, it is wrong.  Since we do not want to
+    ! prescribe our age classes, all we need from the PFT map is the
+    ! total area of a PFT.  We will scale what comes from the restart file to
+    ! match it, in the case we are not taking into account land cover change.
+    ! Instead of nvm we us nvmap here.  Without age classes they are equal.
+    IF (lml /= nvmap) &
+         CALL ipslerr_p (3,'slowproc_update', &
+               &          'Problem with vegetation file for Land Use','lml /= nvmap', &
+               &          '(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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_update','','') 
+    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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_update','','')
+    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
+             CALL ipslerr(3, 'slowproc.f90','slowproc_update','','') 
+          ENDIF
+       ENDIF
+    END IF
+       
+    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
+
+    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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_update','','') 
+    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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_update','','') 
+    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,nvmap,1), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of vegmap : ",ALLOC_ERR
+      CALL ipslerr(3, 'slowproc.f90','slowproc_update','','') 
+    ENDIF
+    IF ( veget_year == 0 ) THEN
+       IF (is_root_prc) THEN
+          ALLOC_ERR=-1
+          ALLOCATE(vegmap_1(iml,jml,nvmap), STAT=ALLOC_ERR)
+          IF (ALLOC_ERR/=0) THEN
+             WRITE(numout,*) "ERROR IN ALLOCATION of vegmap_1 : ",ALLOC_ERR
+             CALL ipslerr(3, 'slowproc.f90','slowproc_update','','') 
+          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, nvmap, 1 /))
+             ELSE
+                CALL fliogetv (fid,"maxvegetfrac", vegmap, start=(/ 1, 1, 1, tml /), count=(/ iml, jml, nvmap, 1 /))
+             ENDIF
+          ENDIF
+       ELSE
+          IF (is_root_prc) THEN
+             CALL fliogetv (fid,"maxvegetfrac", vegmap_1, start=(/ 1, 1, 1 /), count=(/ iml, jml, nvmap /))
+             vegmap(:,:,:,1)=vegmap_1(:,:,:)
+             DEALLOCATE(vegmap_1)
+          ENDIF
+       ENDIF
+       CALL bcast(vegmap)
+       IF (is_root_prc) CALL flioclo (fid)
+    ELSE
+       CALL ipslerr_p (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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_update','','') 
+    ENDIF
+    !
+    mask(:,:) = 0
+    DO ip=1,iml
+       DO jp=1,jml
+          ! If all the values are NaN, compilers with debug options will crash here when we
+          ! try to use an IF statement with NaN values.  So we check if they are NaN first.
+          sum_veg=SUM(vegmap(ip,jp,:,1))
+#ifdef __NAGFOR
+          ltemp=IEEE_IS_NAN(sum_veg)
+#else
+          ltemp=isnan(sum_veg)
+#endif
+          IF( .NOT. ltemp)THEN
+             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
+          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
+          CALL ipslerr(3, 'slowproc.f90','slowproc_update','','') 
+       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
+          CALL ipslerr(3, 'slowproc.f90','slowproc_update','','') 
+       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
+          sumf=zero
+          ! Interpolation of next year's PFT maps can cause problems with land cover change,
+          ! as the nobio fraction can change based on interpolation.  If you have created
+          ! your own maps, and if you know that they are identical to the grid on the
+          ! forcing file maps, I am creating an option to not interpolate; we just
+          ! use a single point, that with the largest sub_area.  If the maps are identical,
+          ! the sub area for the points which overlap should be much larger than the 
+          ! other points.
+          IF(linterpolate_pft_maps)THEN
+             DO idi=1, nbvmax
+                ! Leave the do loop if all sub areas are treated, sub_area <= 0
+                IF ( sub_area(ib,idi) <= zero ) EXIT
+                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)
+             ENDDO
+          ELSE
+             max_index=maxloc(sub_area(ib,:),1)
+             ip = sub_index(ib,max_index,1)
+             jp = sub_index(ib,max_index,2)
+             ! There is the chance that there will be no sub_area.  In that case,
+             ! just put everything to bare soil.
+             IF(ip == 0 .OR. jp == 0)THEN
+                veget_next(ib,:)=zero
+                veget_next(ib,1)=un
+                sumf=zero
+                WRITE(numout,*) "WARNING: No map point for the PFT map, but interpolation is turned off."
+                WRITE(numout,*) "WARNING: Setting this point equal to only bare soil."
+                WRITE(numout,*) "WARNING: ",ib,",(",lalo(ib,1),",",lalo(ib,2),")" 
+                CALL ipslerr_p (2,'slowproc_update', &
+                     &          'No land point, but interpolation turned off.', &
+                     &          "Setting pixel to pure bare soil.", &
+                     &          'Check output file for details.')
+             ELSE
+                WRITE(numout,*) 'jifojezfe ',ip,jp,sub_area(ib,:)
+                veget_next(ib,:) = veget_next(ib,:) + vegmap(ip,jp,:,1)*sub_area(ib,max_index)
+                sumf=sumf + sub_area(ib,max_index)
+             ENDIF
+          ENDIF
+
+!!!$          !
+!!!$          !  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_p (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) = un
+                    veget_next(ib,2:nvmap) = zero
+                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(numout,*) "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, nvmap
+             ! If the DGVM is activated, only anthropiques PFT are utpdated 
+             IF ( .NOT. natural(jv) ) THEN
+                veget_next(ib,jv) = zero
+             ENDIF
+          ENDDO
+          !
+          sumf=zero
+          DO idi=1, nbvmax
+             ! Leave the do loop if all sub areas are treated, sub_area <= 0
+             IF ( sub_area(ib,idi) <= zero ) EXIT
+             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, nvmap
+                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)
+          ENDDO
+!!!$          !
+!!!$          !  Limit the smalest vegetation fraction to 0.5%
+!!!$          !
+!!!$          DO jv = 2, nvmap
+!!!$             ! 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.
+          ! Modification de Nathalie : 
+          ! Si les PFTs anthropique diminue, on les remplace plutÃŽt par du sol nu.
+          ! Le DGVM est chargÃ© de rÃ©-introduire les PFTs naturels.
+          IF (sumf > min_sechiba) THEN
+             sumvAnthro_old = zero
+             sumvAnthro     = zero
+             DO jv = 2, nvmap
+                IF ( .NOT. natural(jv) ) THEN
+                   veget_next(ib,jv) = veget_next(ib,jv) / sumf
+                   sumvAnthro = sumvAnthro + veget_next(ib,jv)
+                   sumvAnthro_old = sumvAnthro_old + veget_last(ib,jv)
+                ENDIF
+             ENDDO
+
+             IF ( sumvAnthro_old < sumvAnthro ) THEN
+                ! deforestation
+                ! conservation :
+                rapport = ( sum_veg - sumvAnthro ) / ( sum_veg - sumvAnthro_old )
+                DO jv = 1, nvmap
+                   IF ( natural(jv) ) THEN
+                      veget_next(ib,jv) = veget_last(ib,jv) * rapport
+                   ENDIF
+                ENDDO
+             ELSE
+                ! reforestation
+                DO jv = 1, nvmap
+                   IF ( natural(jv) ) THEN
+                      veget_next(ib,jv) = veget_last(ib,jv)
+                   ENDIF
+                ENDDO
+                veget_next(ib,1) = veget_next(ib,1) + sumvAnthro_old - sumvAnthro
+             ENDIF
+
+             ! test
+             IF ( ABS( SUM(veget_next(ib,:)) - sum_veg ) > 10*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 modifications : last ",sumvAnthro_old," new ",sumvAnthro     
+                CALL ipslerr_p (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_p (3,'slowproc_update', &
+             CALL ipslerr_p (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,nvmap
+          !
+          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_p (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:nvmap) = zero
+          frac_nobio_next(ib,:) = zero
+!!!$          CALL ipslerr_p (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)
+    !
+
+    ! This is something that used to be done in slowproc_veget.  However, since it changes veget_max, and
+    ! since we check veget_max in LCC and crash if the nobio fractions are not equal in subsequent years,
+    ! it is better to do it here, before the check.
+    DO ib = 1, nbpt
+       IF ( SUM(frac_nobio_next(ib,:)) .LT. min_vegfrac ) THEN
+          frac_nobio_next(ib,:) = zero
+       ENDIF
+       DO jv = 1, nvmap
+          IF ( veget_next(ib,jv) .LT. min_vegfrac ) THEN
+             veget_next(ib,jv) = zero
+          ENDIF
+       ENDDO
+       SUMveg = SUM(frac_nobio_next(ib,:))+SUM(veget_next(ib,:))
+       frac_nobio_next(ib,:) = frac_nobio_next(ib,:)/SUMveg
+       veget_next(ib,:) = veget_next(ib,:)/SUMveg
+       IF(ABS(SUM(frac_nobio_next(ib,:))+SUM(veget_next(ib,:))-un) .GT. min_stomate)THEN
+          WRITE(numout,*) 'ERROR: in slowproc update, our final normalization did not work!'
+          WRITE(numout,*) 'ib, SUM(frac_nobio_next(ib,:)), SUM(veget_next(ib,:))',&
+               ib, SUM(frac_nobio_next(ib,:)), SUM(veget_next(ib,:))
+          CALL ipslerr(3, 'slowproc.f90','problem in slowproc_update','','')
+       ENDIF
+    ENDDO
+
+    ! Due to map interpolation and a few other small things, the nobio fractions
+    ! are not always identical (differ by 0.0001 or so) between this old
+    ! and new land cover maps.  This causes a crash in land cover change, as it
+    ! requires that nobio fractions do not change (figuring out what to do with soil
+    ! carbon and water in the case of glacial retreat has not been done in sapiens_lccchange).
+    ! Therefore we are giving an option to scale the new map to be identical to the old map,
+    ! in terms of nobio fraction.  If you are not sure that your maps conserve nobio
+    ! fraction, DO NOT USE this option.  If you are sure, you are probably safe.
+    IF(lscale_lcc_nobio)THEN
+       DO ib = 1, nbpt
+          old_sum=SUM(veget_last(ib,:))
+          new_sum=SUM(veget_next(ib,:))
+          IF(new_sum .GT. min_stomate)THEN
+             veget_next(ib,:)=veget_next(ib,:)/new_sum*old_sum
+             ! Assumes only one form of nobio! This assumption is made often
+             ! in the code.
+             frac_nobio_next(ib,:)=zero
+             frac_nobio_next(ib,iice)=un-old_sum
+             IF(frac_nobio_next(ib,iice) .LT. min_stomate) frac_nobio_next(ib,iice)=zero
+          ELSE
+             ! This is a problem case.  The new map has nothing, but 
+             ! the old map has something.  Just take the values of the old map.
+             veget_next(ib,:)=veget_last(ib,:)
+             frac_nobio_next(ib,:)=frac_nobio_last(ib,:)
+          ENDIF
+       ENDDO
+    ENDIF
+
+    RETURN
+    !
+  END SUBROUTINE slowproc_update
+
+
+! NEED TO GET RID OF SLOWPROC_INTERPOL_OLD because it is never called!
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_interpol_OLD
+!!
+!>\BRIEF         Interpolate the IGBP vegetation map to the grid of the model
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  !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 m 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
+    !
+    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
+    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
+!_ ================================================================================================================================
+    !
+    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    = NOT(IMPOSE_VEG)
+    !Config Def   = 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.
+    !Config Units = [FILE]
+    !
+    filename = '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(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
+       CALL ipslerr(3, 'slowproc.f90','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. ), mincos )*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'
+          WRITE(numout,'(a1)',ADVANCE='NO') '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
+
+
+! NEED TO GET RID OF SLOWPROC_INTERPOL_NEW because it is never called!
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_interpol_NEW
+!!
+!>\BRIEF         Interpolate the IGBP vegetation map to the grid of the model
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  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 m 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, nix, njx
+    !
+    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    = NOT(IMPOSE_VEG) and NOT(LAND_USE)
+    !Config Def   = 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.
+    !Config Units = [FILE]
+    !
+    filename = '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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_interpol_NEW','','')
+    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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_init','','')  
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(vegmap(iml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of vegmap : ",ALLOC_ERR
+      CALL ipslerr(3, 'slowproc.f90','slowproc_init','','')  
+    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
+       CALL ipslerr(3, 'slowproc.f90','slowproc_init','','') 
+    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 is estimated.
+    ! Some lmargin is taken.
+    !
+    IF (is_root_prc) THEN
+       nix=INT(MAXVAL(resolution_g(:,1))*2/resol_lon)+2
+       njx=INT(MAXVAL(resolution_g(:,2))*2/resol_lon)+2
+       nbvmax = nix*njx
+    ENDIF
+    CALL bcast(nbvmax)
+    !
+    callsign="Vegetation map"
+    !
+    ok_interpol = .FALSE.
+    DO WHILE ( .NOT. ok_interpol )
+       WRITE(numout,*) "Projection arrays for ",callsign," : "
+    WRITE(numout,*) "nbvmax = ",nbvmax, nix, njx
+       !
+       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
+          CALL ipslerr(3, 'slowproc.f90','slowproc_interpol_NEW','','') 
+       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
+          CALL ipslerr(3, 'slowproc.f90','slowproc_interpol_NEW','','') 
+       ENDIF
+       sub_area(:,:)=zero
+       !
+    WRITE(numout,*) 'Carteveg range LON:', MINVAL(lon_ful), MAXVAL(lon_ful)
+    WRITE(numout,*) 'Carteveg range LAT:', MINVAL(lat_ful), MAXVAL(lat_ful)
+    !
+       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
+             DO idi=1, nbvmax
+                ! Leave the do loop if all sub areas are treated, sub_area <= 0
+                IF ( sub_area(ib,idi) <= zero ) EXIT 
+                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)
+             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
+
+! NEED TO GET RID OF SLOWPROC_INTERPOL_OLD_g because it correspond to version 1.6 of the code
+! for CMIP3 simulations (too old)
+!
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_interpol_OLD_g
+!!
+!>\BRIEF         Interpolate the IGBP vegetation map to the grid of the model
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  !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 m 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
+    !
+    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
+    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
+
+!_ ================================================================================================================================
+    !
+    !
+    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    = NOT(IMPOSE_VEG)
+    !Config Def   = 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.
+    !Config Units = [FILE]
+    !
+    filename = '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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_interpol_NEW','','')
+    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. ), mincos )*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'
+          WRITE(numout,'(a1)',ADVANCE='NO') '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
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_interpol_NEW_g
+!!
+!>\BRIEF         Interpolate the IGBP vegetation map to the grid of the model
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::veget, ::frac_nobio
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  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 : 1=latitude ; 2=longitude)
+    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 m 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                                       !!vegetation map filename
+    INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, vid              
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_ful, lon_ful, vegmap  !! for 5km vegetation map 
+                                                                        !! latitude vector, longitude vector, and 
+                                                                        !! value of Olson's classes for each location
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area                !! the area of the fine grid in the model grid ??? 
+                                                                        !! cf src_global/interpol_help.f90, line 377, called "areaoverlap"
+    INTEGER(i_std),ALLOCATABLE, DIMENSION(:,:) :: sub_index             !! the indexes from the grid boxes from the data that go 
+                                                                        !! into the model's boxes 
+                                                                        !! cf src_global/interpol_help.f90,line 300, called "ip"
+    REAL(r_std), DIMENSION(nbpt,nolson) :: n_origveg                    !! number of points of each Olson type from the fine grid 
+                                                                        !! in each box of the (coarse) model grid 
+    REAL(r_std), DIMENSION(nbpt) :: n_found                             !! total number of different Olson types found in each 
+                                                                        !! box of the (coarse) model grid
+    REAL(r_std), DIMENSION(nbpt,nolson) :: frac_origveg                 !! fraction of each Olson type in each box of the (coarse) model grid
+    REAL(r_std) :: vegcorr(nolson,nvm)                                  !! correspondance table between Olson and the following SECHIBA Classes.
+                                                                        !!   vegcorr(i,:)+nobiocorr(i,:) = 1.  for all i 
+                                                                        !! see each class in src_parameters/constantes_veg.f90
+
+    REAL(r_std) :: nobiocorr(nolson,nnobio)                             !! non-biospheric surface typesi
+    CHARACTER(LEN=40) :: callsign                                       !! Allows to specify which variable is beeing treated
+    REAL(r_std) :: sumf, resol_lon, resol_lat                           !! sumf = sum veget + sum nobio
+                                                                        !! resol_lon, resol_lat  reolution in meters of the grid of the vegetation file
+    INTEGER(i_std) :: idi, jv, inear, nbvmax                            !! idi : counter for nbvmax, see below   
+                                                                        !! jv : counter for nvm, number of PFT
+                                                                        !! inear : location of the point of vegmap, which is the closest from the modelled point
+                                                                        !! nbvmax : number of maximum vegetation map points in the GCM grid 
+    INTEGER(i_std) :: nix, njx
+    !
+    INTEGER                  :: ALLOC_ERR                               !! location of the eventual missing value in vegmap
+
+!_ ================================================================================================================================
+    !
+    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    = NOT(IMPOSE_VEG) and NOT(LAND_USE)
+    !Config Def   = 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.
+    !Config Units = [FILE]
+    !
+    filename = 'carteveg5km.nc'
+    CALL getin('VEGETATION_FILE',filename)  ! GETIN_P !!
+    !
+    CALL flininfo(filename, iml, jml, lml, tml, fid)   
+    !
+    ! see IOIPSL/src/flincom.f90, line 665
+    ! fid      : File ID
+    !- iml      | These 4 variables give the size of the variables
+    !- jml      | to be read. It will be verified that the variables
+    !- lml      | fits in there.
+    !- tml     
+    ! iml, jml : horizontal size of the grid, lml = vertical size
+    ! tml : size of time axis
+
+    ! TL : pourquoi 2 variables pour la taille horizontale ? cf
+    ! IOIPSL/src/flincom.f90 , line 160 
+
+    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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_interpol_NEW_g','','')
+    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
+      CALL ipslerr(3, 'slowproc.f90','slowproc_interpol_NEW_g','','') 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(vegmap(iml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of vegmap : ",ALLOC_ERR
+      CALL ipslerr(3, 'slowproc.f90','slowproc_interpol_NEW_g','','') 
+    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)
+    !
+    WRITE(numout,*) 'File name : ', filename
+    WRITE(numout,*) 'Min and max vegetation numbers : ', MINVAL(vegmap), MAXVAL(vegmap)
+    !
+    CALL flinclo(fid)
+    !
+    IF (MAXVAL(vegmap) .LT. nolson) THEN
+       WRITE(numout,*) 'WARNING -- WARNING'
+       WRITE(numout,*) 'The vegetation map has too 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
+       CALL ipslerr(3, 'slowproc.f90','slowproc_interpol_NEW_g','','')
+    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.
+    !
+    
+    !TL : CODE EN DUR ????? 
+    resol_lon = 5000.
+    resol_lat = 5000.
+    !
+    !
+    ! The number of maximum vegetation map points in the GCM grid is estimated.
+    ! Some margin is taken.
+    !
+    nix=INT(MAXVAL(resolution_g(:,1)*2)/resol_lon)+1
+    njx=INT(MAXVAL(resolution_g(:,2)*2)/resol_lon)+1
+    nbvmax = nix*njx
+    !
+    ! No need to broadcast as this routine is only called on root_proc
+    !
+    callsign="Vegetation map"
+    !
+    ok_interpol = .FALSE.
+    DO WHILE ( .NOT. ok_interpol )
+       WRITE(numout,*) "Projection arrays for ",callsign," : "
+    WRITE(numout,*) "nbvmax = ",nbvmax, nix, njx
+       !
+       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
+          CALL ipslerr(3, 'slowproc.f90','slowproc_interpol_NEW_g','','') 
+       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
+          CALL ipslerr(3, 'slowproc.f90','slowproc_interpol_NEW_g','','') 
+       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)
+       !
+       ! Defined as aggregate_2d or aggregate_vec in src_global/interpol_help.f90, depending
+       ! on the dimensions (2D region or vector)i. 
+       ! 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.
+
+       IF ( .NOT. ok_interpol ) THEN
+          DEALLOCATE(sub_area)
+          DEALLOCATE(sub_index)
+          !
+          nbvmax = nbvmax * 2
+       ELSE
+          !
+          DO ib = 1, nbpt
+             DO idi=1, nbvmax
+                ! Leave the do loop if all sub areas are treated, sub_area <= 0
+                IF ( sub_area(ib,idi) <= zero ) EXIT
+
+                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)
+             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 smallest vegetation fraction to 0.5%
+       !
+       DO vid = 1, nvm
+          IF ( veget(ib,vid) .LT. min_vegfrac ) THEN  ! min_vegfrac=0.001 in constantes_veg.f90
+             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
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_nearest
+!!
+!>\BRIEF         looks for nearest grid point on the fine map
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::inear
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE slowproc_nearest(iml, lon5, lat5, lonmod, latmod, inear)
+
+    !! INTERFACE DESCRIPTION
+    
+    !! 0.1 input variables
+
+    INTEGER(i_std), INTENT(in)                   :: iml             !! size of the vector
+    REAL(r_std), DIMENSION(iml), INTENT(in)      :: lon5, lat5      !! longitude and latitude vector, for the 5km vegmap
+    REAL(r_std), INTENT(in)                      :: lonmod, latmod  !! longitude  and latitude modelled
+
+    !! 0.2 output variables
+    
+    INTEGER(i_std), INTENT(out)                  :: inear           !! location of the grid point from the 5km vegmap grid
+                                                                    !! closest from the modelled grid point
+
+    !! 0.4 Local variables
+
+    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
+      CALL ipslerr(3,'slowproc.f90','slowproc_nearest','','') 
+    ENDIF
+
+    pa = pi/2.0 - latmod*pi/180.0 ! dist. between north pole and the point a 
+                                                      !! COLATITUDE, in radian
+    cospa = COS(pa)
+    sinpa = SIN(pa)
+
+    DO i = 1, iml
+
+       sincolat = SIN( pi/2.0 - lat5(i)*pi/180.0 ) !! sinus of the colatitude
+       coscolat = COS( pi/2.0 - lat5(i)*pi/180.0 ) !! cosinus of the colatitude
+
+       p = (lonmod-lon5(i))*pi/180.0 !! angle between a & b (between their meridian)in radians
+
+       !! dist(i) = ACOS( cospa*coscolat + sinpa*sincolat*COS(p))
+       cosang(i) = cospa*coscolat + sinpa*sincolat*COS(p) !! TL : cosang is maximum when angle is at minimal value  
+!! orthodromic distance between 2 points : cosang = cosinus (arc(AB)/R), with
+!R = Earth radius, then max(cosang) = max(cos(arc(AB)/R)), reached when arc(AB)/R is minimal, when
+! arc(AB) is minimal, thus when point B (corresponding grid point from LAI MAP) is the nearest from
+! modelled A point
+    ENDDO
+
+    ineartab = MAXLOC( cosang(:) )
+    inear = ineartab(1)
+
+    DEALLOCATE(cosang)
+  END SUBROUTINE slowproc_nearest
+
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_soilt
+!!
+!>\BRIEF         Interpolate the Zobler soil type map
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::soiltype, ::clayfraction
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE slowproc_soilt(nbpt, lalo, neighbours, resolution, contfrac, soilclass, 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 m 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
+
+!!!!!! tzjFAB bug
+    !
+    REAL(r_std), INTENT(out)      :: soilclass(nbpt, nscm)   !! 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
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: soiltext, soiltext2
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)  :: sub_area
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:)  :: sub_index
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: resol_lu
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: solt, solt2
+    REAL(r_std) ::  sgn, coslat
+    CHARACTER(LEN=30) :: callsign
+    INTEGER(i_std) :: nix, njx
+    !
+    ! Number of texture classes in Zobler
+    !
+    INTEGER(i_std), PARAMETER :: nzobler = 7
+    REAL(r_std),ALLOCATABLE   :: textfrac_table(:,:)
+    !   
+    LOGICAL                  :: ok_interpol  ! optionnal return of aggregate_2d
+    !   
+    INTEGER                  :: ALLOC_ERR
+
+!_ ================================================================================================================================
+    !
+    !
+    !  Needs to be a configurable variable
+    !
+    !
+    !Config Key   = SOILCLASS_FILE
+    !Config Desc  = Name of file from which soil types are read
+    !Config Def   = soils_param.nc
+    !Config If    = NOT(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.
+    !Config Units = [FILE]
+    !
+    filename = 'soils_param.nc'
+    CALL getin_p('SOILCLASS_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
+      CALL ipslerr(3,'slowproc.f90','slowproc_nearest','','')
+    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
+      CALL ipslerr(3,'slowproc.f90','slowproc_nearest','','')
+    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
+      CALL ipslerr(3,'slowproc.f90','slowproc_nearest','','')
+    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
+      CALL ipslerr(3,'slowproc.f90','slowproc_nearest','','')
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(soiltext2(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of soiltext2 : ",ALLOC_ERR
+      CALL ipslerr(3,'slowproc.f90','slowproc_nearest','','')
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of resol_lu : ",ALLOC_ERR
+      CALL ipslerr(3,'slowproc.f90','slowproc_nearest','','') 
+    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
+          !
+          ! Resolution in longitude
+          !
+          coslat = MAX( COS( lat_rel(ip,jp) * pi/180. ), mincos )     
+          IF ( ip .EQ. 1 ) THEN
+             resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip,jp) ) * pi/180. * R_Earth * coslat
+          ELSEIF ( ip .EQ. iml ) THEN
+             resol_lu(ip,jp,1) = ABS( lon_rel(ip,jp) - lon_rel(ip-1,jp) ) * pi/180. * R_Earth * coslat
+          ELSE
+             resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat
+          ENDIF
+          !
+          ! Resolution in latitude
+          !
+          IF ( jp .EQ. 1 ) THEN
+             resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp) - lat_rel(ip,jp+1) ) * pi/180. * R_Earth
+          ELSEIF ( jp .EQ. jml ) THEN
+             resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp) ) * pi/180. * R_Earth
+          ELSE
+             resol_lu(ip,jp,2) =  ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp+1) )/2. * pi/180. * R_Earth
+          ENDIF
+          !
+       ENDDO
+    ENDDO
+    !
+    ! The number of maximum vegetation map points in the GCM grid is estimated.
+    ! Some lmargin is taken.
+    !
+    IF (is_root_prc) THEN
+       nix=INT(MAXVAL(resolution_g(:,1))/minval(resol_lu(:,:,1)))+1
+       njx=INT(MAXVAL(resolution_g(:,2))/minval(resol_lu(:,:,2)))+1
+       nbvmax = nix*njx
+    ENDIF
+    CALL bcast(nbvmax)
+    ! I don't know if these values are really useful, but they are printed out
+    ! below, and if they are not broadcast they will be uninitialzed on non-root
+    ! processors
+    CALL bcast(nix)
+    CALL bcast(njx)
+    !
+    callsign = "Soil types"
+    !
+    ok_interpol = .FALSE.
+    DO WHILE ( .NOT. ok_interpol )
+       WRITE(numout,*) "Projection arrays for ",callsign," : "
+       WRITE(numout,*) "nbvmax = ",nbvmax, nix, njx
+       !
+       ALLOC_ERR=-1
+       ALLOCATE(solt(nbvmax), STAT=ALLOC_ERR)
+       IF (ALLOC_ERR/=0) THEN
+          WRITE(numout,*) "ERROR IN ALLOCATION of solt : ",ALLOC_ERR
+          CALL ipslerr(3,'slowproc.f90','slowproc_nearest','','')
+       ENDIF
+       ALLOC_ERR=-1
+       ALLOCATE(solt2(nbvmax), STAT=ALLOC_ERR)
+       IF (ALLOC_ERR/=0) THEN
+          WRITE(numout,*) "ERROR IN ALLOCATION of solt2 : ",ALLOC_ERR
+          CALL ipslerr(3,'slowproc.f90','slowproc_nearest','','')
+       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
+          CALL ipslerr(3,'slowproc.f90','slowproc_nearest','','')
+       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
+          CALL ipslerr(3,'slowproc.f90','slowproc_nearest','','')
+       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)
+          DEALLOCATE(solt2)
+          !
+          nbvmax = nbvmax * 2
+       ENDIF
+    ENDDO
+    !
+    !
+    SELECTCASE(soil_classif)
+    CASE('none')
+       ALLOCATE(textfrac_table(nscm,ntext))
+       DO ib=1, nbpt
+          soilclass(ib,:) = soilclass_default_fao
+          clayfraction(ib) = clayfraction_default
+       ENDDO
+    CASE('zobler')
+       !
+       soilclass_default=soilclass_default_fao
+       !
+       WRITE(numout,*) "Using a soilclass map with Zobler classification"
+       !
+       ALLOCATE(textfrac_table(nzobler,ntext))
+! tzjsoilusda       !
+       CALL get_soilcorr_zobler (nzobler, textfrac_table)
+       !
+       !
+       DO ib =1, nbpt
+          !
+          ! GO through the point we have found
+          !
+          !
+          fopt = COUNT(sub_area(ib,:) > zero)
+          !
+          !    Check that we found some points
+          !
+          soilclass(ib,:) = zero
+          clayfraction(ib) = zero
+          !
+          IF ( fopt .EQ. 0) THEN
+             nbexp = nbexp + 1
+             soilclass(ib,:) = soilclass_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. nzobler) .AND. (solt(ilf) .GT. 0) .AND.&
+                     & (solt(ilf) .NE. 6)) THEN
+                   SELECTCASE(solt(ilf))
+                   CASE(1)
+                      soilclass(ib,1) = soilclass(ib,1) + sub_area(ib,ilf)
+                   CASE(2)
+                      soilclass(ib,2) = soilclass(ib,2) + sub_area(ib,ilf)
+                   CASE(3)
+                      soilclass(ib,2) = soilclass(ib,2) + sub_area(ib,ilf)
+                   CASE(4)
+                      soilclass(ib,2) = soilclass(ib,2) + sub_area(ib,ilf)
+                   CASE(5)
+                      !+++CHECK+++
+                      ! Silt and clay are given equal percentages in the 
+                      ! conversion table. This is the only case where clay
+                      ! wins and it results in a very high waterstress
+                      ! impairing plant growth. Therefore we change it
+                      ! to silt.
+                      !soilclass(ib,3) = soilclass(ib,3) + sub_area(ib,ilf)
+                      soilclass(ib,2) = soilclass(ib,2) + sub_area(ib,ilf)
+                      !+++++++++++
+                   CASE(7)
+                      soilclass(ib,2) = soilclass(ib,2) + sub_area(ib,ilf)
+                   CASE DEFAULT
+                      WRITE(numout,*) 'We should not be here, an impossible case appeared'
+                      CALL ipslerr(3,'slowproc.f90','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. nzobler) THEN
+                      WRITE(numout,*) 'The file contains a soil color class which is incompatible with this program'
+                      CALL ipslerr(3,'slowproc.f90','slowproc_soilt','','')
+                   ENDIF
+                ENDIF
+                !
+             ENDDO
+             !
+             ! Normalize the surface
+             !
+             IF ( sgn .LT. min_sechiba) THEN
+                nbexp = nbexp + 1
+                soilclass(ib,:) = soilclass_default(:)
+                clayfraction(ib) = clayfraction_default
+             ELSE
+                soilclass(ib,:) = soilclass(ib,:)/sgn
+                clayfraction(ib) = clayfraction(ib)/sgn
+             ENDIF
+             !
+          ENDIF
+          !
+       ENDDO
+   
+    !
+    CASE("fao")
+       !
+       soilclass_default=soilclass_default_fao
+       !
+       WRITE(numout,*) "Using a soilclass map with fao classification"
+       !
+       ALLOCATE(textfrac_table(nscm,ntext))
+       !
+       CALL get_soilcorr_zobler(nscm, textfrac_table)
+       !
+       DO ib =1, nbpt
+          !
+          ! GO through the point we have found
+          !
+          !
+          fopt = COUNT(sub_area(ib,:) > zero)
+          !
+          !    Check that we found some points
+          !
+          soilclass(ib,:) = 0.0
+          clayfraction(ib) = 0.0
+          !
+          IF ( fopt .EQ. 0) THEN
+             nbexp = nbexp + 1
+             soilclass(ib,:) = soilclass_default(:)
+             clayfraction(ib) = clayfraction_default
+          ELSE
+             !
+             DO ilf = 1,fopt
+                solt(ilf) = soiltext(sub_index(ib,ilf,1),sub_index(ib,ilf,2))
+             ENDDO
+             !
+             !
+             !   Compute the average bare soil albedo parameters
+             !
+             sgn = zero
+             !
+             DO ilf = 1,fopt
+                !
+                ! 
+                !
+                IF ( (solt(ilf) .LE. nscm) .AND. (solt(ilf) .GT. 0) ) THEN
+                   soilclass(ib,solt(ilf)) = soilclass(ib,solt(ilf)) + sub_area(ib,ilf)
+                   clayfraction(ib) = clayfraction(ib) + textfrac_table(solt(ilf),3) * sub_area(ib,ilf)
+                   sgn = sgn + sub_area(ib,ilf)
+                ELSE
+                   IF (solt(ilf) .GT. nscm) THEN
+                      WRITE(*,*) 'The file contains a soil color class which is incompatible with this program'
+                      CALL ipslerr(3,'slowproc.f90','slowproc_soilt','','')
+                   ENDIF
+                ENDIF
+                !
+             ENDDO
+             !
+             ! Normalize the surface
+             !
+             IF ( sgn .LT. min_sechiba) THEN
+                nbexp = nbexp + 1
+                soilclass(ib,:) = soilclass_default(:)
+                clayfraction(ib) = clayfraction_default
+             ELSE
+                soilclass(ib,:) = soilclass(ib,:)/sgn
+                clayfraction(ib) = clayfraction(ib)/sgn
+             ENDIF
+             !
+          ENDIF
+          !
+       ENDDO
+       !
+       !
+    CASE("usda")
+       !
+       soilclass_default=soilclass_default_usda
+       !
+       WRITE(numout,*) "Using a soilclass map with usda classification"
+ !      WRITE(numout,*) "tzjfab slowproc",nscm
+       !
+       ALLOCATE(textfrac_table(nscm,ntext))
+! tzjsoilusda       !
+       CALL get_soilcorr_usda (nscm, textfrac_table)
+       !
+       DO ib =1, nbpt
+          !
+          ! GO through the point we have found
+          !
+          !
+          fopt = COUNT(sub_area(ib,:) > zero)
+          !
+          !    Check that we found some points
+          !
+          soilclass(ib,:) = 0.0
+          clayfraction(ib) = 0.0
+          !
+          IF ( fopt .EQ. 0) THEN
+             nbexp = nbexp + 1
+             soilclass(ib,:) = soilclass_default
+             clayfraction(ib) = clayfraction_default
+          ELSE
+             !
+             DO ilf = 1,fopt
+                solt(ilf) = soiltext(sub_index(ib,ilf,1),sub_index(ib,ilf,2))
+             ENDDO
+             !
+             !
+             !   Compute the average bare soil albedo parameters
+             !
+             sgn = zero
+             !
+             DO ilf = 1,fopt
+                !
+                ! 
+                !
+                IF ( (solt(ilf) .LE. nscm) .AND. (solt(ilf) .GT. 0) ) THEN
+                   soilclass(ib,solt(ilf)) = soilclass(ib,solt(ilf)) + sub_area(ib,ilf)
+                   clayfraction(ib) = clayfraction(ib) + textfrac_table(solt(ilf),3) * sub_area(ib,ilf)
+                   sgn = sgn + sub_area(ib,ilf)
+                ELSE
+                   IF (solt(ilf) .GT. nscm) THEN
+                      WRITE(*,*) 'The file contains a soil color class which is incompatible with this program CASE USDA'
+                      CALL ipslerr(3,'slowproc.f90','slowproc_soilt','','')
+                   ENDIF
+                ENDIF
+                !
+             ENDDO
+             !
+             ! Normalize the surface
+             !
+             IF ( sgn .LT. min_sechiba) THEN
+                nbexp = nbexp + 1
+                soilclass(ib,:) = soilclass_default(:)
+                clayfraction(ib) = clayfraction_default
+             ELSE
+                soilclass(ib,:) = soilclass(ib,:)/sgn
+                clayfraction(ib) = clayfraction(ib)/sgn
+             ENDIF
+             !
+          ENDIF
+          !
+       ENDDO
+       !
+    CASE DEFAULT
+       WRITE(*,*) 'A non supported soil type classification has been chosen'
+       CALL ipslerr(3,'slowproc.f90','slowproc_soilt','','')
+    ENDSELECT
+    !
+    WRITE(numout,*) 'Interpolation Done'
+       !
+    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)
+    !
+    DEALLOCATE (soiltext2)
+    DEALLOCATE (solt2)
+    DEALLOCATE (textfrac_table)
+    !
+    DEALLOCATE (resol_lu)
+    !
+    !
+    RETURN
+    !
+  END SUBROUTINE slowproc_soilt
+ 
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_slope
+!!
+!>\BRIEF         Calculate mean slope coef in each  model grid box from the slope map
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::reinf_slope
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE slowproc_slope(nbpt, lalo, neighbours, resolution, contfrac, reinf_slope)
+    !
+    !
+    !
+    !  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 m of each grid-box in X and Y
+    REAL(r_std), INTENT (in)             :: contfrac(nbpt)         !! Fraction of continent in the grid
+    !
+    !  0.2 OUTPUT
+    !
+    REAL(r_std), INTENT(out)    ::  reinf_slope(nbpt)                   ! slope coef 
+    !
+    !  0.3 LOCAL
+    !
+    !
+    REAL(r_std)  :: slope_noreinf                 ! Slope above which runoff is maximum
+    CHARACTER(LEN=80) :: filename
+    CHARACTER(LEN=30) :: callsign
+    INTEGER(i_std)    :: iml, jml, lml, tml, fid, ib, ip, jp, vid
+    INTEGER(i_std)    :: idi, idi_last, nbvmax
+    REAL(r_std)        :: slopecoef, coslat
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: sub_index
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)    :: lat_rel, lon_rel, slopemap
+    REAL(r_std), ALLOCATABLE, DIMENSION(:)      :: lat_lu, lon_lu
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)    :: sub_area
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: resol_lu
+    INTEGER(i_std) :: nix, njx
+    !
+    LOGICAL ::           ok_interpol = .FALSE. ! optionnal return of aggregate_2d
+    !
+    INTEGER                  :: ALLOC_ERR
+!_ ================================================================================================================================
+
+    !
+    !Config Key   = SLOPE_NOREINF
+    !Config Desc  = See slope_noreinf above
+    !Config If    = 
+    !Config Def   = 0.5
+    !Config Help  = The slope above which there is no reinfiltration
+    !Config Units = [-]
+    !
+    slope_noreinf = 0.5
+    !
+    CALL getin_p('SLOPE_NOREINF',slope_noreinf)
+    !
+    !Config Key   = TOPOGRAPHY_FILE
+    !Config Desc  = Name of file from which the topography map is to be read
+    !Config If    = 
+    !Config Def   = cartepente2d_15min.nc
+    !Config Help  = The name of the file to be opened to read the orography
+    !Config         map is to be given here. Usualy SECHIBA runs with a 2'
+    !Config         map which is derived from the NGDC one. 
+    !Config Units = [FILE]
+    !
+    filename = 'cartepente2d_15min.nc'
+    CALL getin_p('TOPOGRAPHY_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_lu(jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lat_lu : ",ALLOC_ERR
+      CALL ipslerr(3,'slowproc.f90','slowproc_slope','','') 
+    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
+      CALL ipslerr(3,'slowproc.f90','slowproc_slope','','')
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(slopemap(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of slopemap : ",ALLOC_ERR
+      CALL ipslerr(3,'slowproc.f90','slowproc_slope','','')
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of resol_lu : ",ALLOC_ERR
+      CALL ipslerr(3,'slowproc.f90','slowproc_slope','','') 
+    ENDIF
+    !
+    WRITE(numout,*) 'Reading the topography 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, 'pente', iml, jml, 0, 0, 1, 1, slopemap)
+       !
+       CALL flinclo(fid)
+    ENDIF
+    CALL bcast(lon_lu)
+    CALL bcast(lat_lu)
+    CALL bcast(slopemap)
+    !
+    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
+      CALL ipslerr(3,'slowproc.f90','slowproc_slope','','')
+    ENDIF
+    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
+      CALL ipslerr(3,'slowproc.f90','slowproc_slope','','')
+    ENDIF
+    !
+    DO ip=1,iml
+       lat_rel(ip,:) = lat_lu(:)
+    ENDDO
+    DO jp=1,jml
+       lon_rel(:,jp) = lon_lu(:)
+    ENDDO
+    !
+    !
+    ! 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
+      CALL ipslerr(3,'slowproc.f90','slowproc_slope','','') 
+    ENDIF
+    !
+    mask(:,:) = zero
+    DO ip=1,iml
+       DO jp=1,jml
+          IF (slopemap(ip,jp) .GT. min_sechiba) THEN
+             mask(ip,jp) = un
+          ENDIF
+          !
+          ! Resolution in longitude
+          !
+          coslat = MAX( COS( lat_rel(ip,jp) * pi/180. ), mincos )     
+          IF ( ip .EQ. 1 ) THEN
+             resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip,jp) ) * pi/180. * R_Earth * coslat
+          ELSEIF ( ip .EQ. iml ) THEN
+             resol_lu(ip,jp,1) = ABS( lon_rel(ip,jp) - lon_rel(ip-1,jp) ) * pi/180. * R_Earth * coslat
+          ELSE
+             resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat
+          ENDIF
+          !
+          ! Resolution in latitude
+          !
+          IF ( jp .EQ. 1 ) THEN
+             resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp) - lat_rel(ip,jp+1) ) * pi/180. * R_Earth
+          ELSEIF ( jp .EQ. jml ) THEN
+             resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp) ) * pi/180. * R_Earth
+          ELSE
+             resol_lu(ip,jp,2) =  ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp+1) )/2. * pi/180. * R_Earth
+          ENDIF
+          !
+       ENDDO
+    ENDDO
+    !
+    !
+    ! The number of maximum vegetation map points in the GCM grid is estimated.
+    ! Some lmargin is taken.
+    !
+    IF (is_root_prc) THEN
+       nix=INT(MAXVAL(resolution_g(:,1))/minval(resol_lu(:,:,1)))+1
+       njx=INT(MAXVAL(resolution_g(:,2))/minval(resol_lu(:,:,2)))+1
+       nbvmax = nix*njx
+    ENDIF
+    CALL bcast(nbvmax)
+    !
+    callsign="Slope map"
+    !
+    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
+       CALL ipslerr(3,'slowproc.f90','slowproc_slope','','')
+    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
+       CALL ipslerr(3,'slowproc.f90','slowproc_slope','','')
+    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
+       CALL ipslerr(3,'slowproc.f90',&
+             'Something went wrong in aggreate_p. Probably nbvmax is too small',&
+             '','')
+    END IF
+    !
+    !
+    DO ib = 1, nbpt
+      !-
+      !- Reinfiltration coefficient due to the slope: Calculation with parameteres maxlope_ro 
+      !-
+      slopecoef = zero
+
+      ! Initialize last index to the highest possible 
+      idi_last=nbvmax
+      DO idi=1, nbvmax
+         ! Leave the do loop if all sub areas are treated, sub_area <= 0
+         IF ( sub_area(ib,idi) <= zero ) THEN
+            ! Set last index to the last one used
+            idi_last=idi-1
+            ! Exit do loop
+            EXIT
+         END IF
+
+         ip = sub_index(ib,idi,1)
+         jp = sub_index(ib,idi,2)
+
+         slopecoef = slopecoef + MIN(slopemap(ip,jp)/slope_noreinf, un) * sub_area(ib,idi)
+      ENDDO
+
+      IF ( idi_last >= 1 ) THEN
+         reinf_slope(ib) = un - slopecoef / SUM(sub_area(ib,1:idi_last)) 
+      ELSE
+         reinf_slope(ib) = slope_default
+      ENDIF
+    ENDDO
+    !
+    !
+    WRITE(numout,*) 'Interpolation Done'
+    !
+    !
+    DEALLOCATE(slopemap)
+    DEALLOCATE(sub_index)
+    DEALLOCATE(sub_area)
+    DEALLOCATE(mask)
+    DEALLOCATE(lon_lu)
+    DEALLOCATE(lat_lu)
+    DEALLOCATE(lon_rel)
+    DEALLOCATE(lat_rel)
+    !
+    !
+    RETURN
+    !
+  END SUBROUTINE slowproc_slope
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: get_vegcorr
+!!
+!>\BRIEF         The "get_vegcorr" routine defines the table of correspondence
+!!               between the 94 Olson vegetation types and the 13 Plant Functional Types known 
+!!               by SECHIBA and STOMATE. Used by slowproc for the old interpolation.
+!!
+!!\DESCRIPTION : get_vegcorr is needed if you use the old_map carteveg5km.nc. \n
+!!               Usually SECHIBA can run with a 5kmx5km map which is derived from the IGBP one. \n
+!!               We assume that we have a classification in 94 types. This is Olson one modified by Nicolas Viovy.\n
+!!               ORCHIDEE has to convert the Olson vegetation types into PFTs for the run (interpolation step).\n
+!!               Each Olson matches to a combination of fractions of one or several PFTs.\n
+!!               This routine uses the same process for the non-biospheric map (not used).\n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::vegcorr, ::nobiocorr.
+!!
+!! REFERENCE(S)	: 
+!! - Olson, J.S., J.A. Watts, and L.J. Allison., 1983. 
+!! "Carbon in Live Vegetation of Major World Ecosystems." 
+!! Report ORNL-5862. Oak Ridge National Laboratory, Oak Ridge, Tennessee. 
+!! - Olson, J.S., J.A. Watts, and L.J. Allison., 1985. 
+!! "Major World Ecosystem Complexes Ranked by Carbon in Live Vegetation: A Database." 
+!! NDP-017. Carbon Dioxide Information Center, Oak Ridge National Laboratory, Oak Ridge, Tennessee.
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE get_vegcorr (nolson,vegcorr,nobiocorr)
+
+    IMPLICIT NONE
+
+    !! 0. Variables and parameters declaration
+    
+    INTEGER(i_std),PARAMETER :: nolson94 = 94                       !! Number of Olson vegetation types (unitless)
+    INTEGER(i_std),PARAMETER :: nvm13 = 13                          !! Number of PFTS of ORCHIDEE (unitless) 
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std),INTENT(in) :: nolson                             !! Number of Olson vegetation types (unitless)
+    
+    !! 0.2 Output variables 
+
+    REAL(r_std),DIMENSION(nolson,nvm),INTENT(out) :: vegcorr        !! Correspondence array between Olson types and PFTS 
+                                                                    !! (0-1, unitless)
+    REAL(r_std),DIMENSION(nolson,nnobio),INTENT(out) :: nobiocorr   !! Correspondence array between non-vegetation types and nobio 
+                                                                    !! types (lake,etc..) (0-1, unitless)
+
+    !! 0.4 Local variable
+    
+    INTEGER(i_std) :: ib                                            !! Indice (unitless)
+    
+ !_ ================================================================================================================================
+
+    !-
+    ! 0. Check consistency
+    !-
+    IF (nolson /= nolson94) THEN
+       WRITE(numout,*) nolson,nolson94
+       CALL ipslerr_p(3,'get_vegcorr', '', '',&
+            &                 'wrong number of OLSON vegetation types.') ! Fatal error
+    ENDIF !(nolson /= nolson94)
+    
+    IF (nvm /= nvm13) THEN
+       WRITE(numout,*) nvm,nvm13
+       CALL ipslerr_p(3,'get_vegcorr', '', '',&
+            &                 'wrong number of SECHIBA vegetation types.') ! Fatal error
+    ENDIF !(nvm /= nvm13)
+
+    ! The carteveg5km cannot be used if the PFTs are not in the standard order
+    DO ib = 1,nvm
+       IF (pft_to_mtc(ib) /= ib ) THEN
+          CALL ipslerr_p(3,'get_vegcorr','You have redefined the order of the 13 PFTS', & 
+               &          'You can not use carteveg5km', 'Use the standard configuration of PFTS' )
+       ENDIF
+    ENDDO
+
+    !-
+    ! 1 set the indices of non-biospheric surface types to 0.
+    !-
+    nobiocorr(:,:) = zero
+    !-
+    ! 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.0, 0.6, 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_p(3,'get_vegcorr', '', '',&
+               &                 'Wrong correspondance for Olson type.') ! Fatal error
+       ENDIF
+       !
+    ENDDO ! Loop over the # Olson type
+
+
+  END SUBROUTINE get_vegcorr
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: get_soilcorr_zobler
+!!
+!>\BRIEF         The "get_soilcorr" routine defines the table of correspondence
+!!               between the Zobler types and the three texture types known by SECHIBA and STOMATE :
+!!               silt, sand and clay. 
+!!
+!! DESCRIPTION : get_soilcorr is needed if you use soils_param.nc .\n
+!!               The data from this file is then interpolated to the grid of the model. \n
+!!               The aim is to get fractions for sand loam and clay in each grid box.\n
+!!               This information is used for soil hydrology and respiration.
+!!
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S) : ::texfrac_table
+!!
+!! REFERENCE(S)	: 
+!! - Zobler L., 1986, A World Soil File for global climate modelling. NASA Technical memorandum 87802. NASA 
+!!   Goddard Institute for Space Studies, New York, U.S.A.
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE get_soilcorr_zobler (nzobler,textfrac_table)
+
+    IMPLICIT NONE
+
+    !! 0. Variables and parameters declaration
+    
+    INTEGER(i_std),PARAMETER :: nbtypes_zobler = 7                    !! Number of Zobler types (unitless)
+
+    !! 0.1  Input variables
+    
+    INTEGER(i_std),INTENT(in) :: nzobler                              !! Size of the array (unitless)
+    
+    !! 0.2 Output variables 
+    
+    REAL(r_std),DIMENSION(nzobler,ntext),INTENT(out) :: textfrac_table !! Table of correspondence (0-1, unitless)
+    
+    !! 0.4 Local variables
+    
+    INTEGER(i_std) :: ib                                              !! Indice (unitless)
+    
+!_ ================================================================================================================================
+
+    !-
+    ! 0. Check consistency
+    !-  
+    IF (nzobler /= nbtypes_zobler) THEN 
+       CALL ipslerr_p(3,'get_soilcorr', 'nzobler /= nbtypes_zobler',&
+          &   'We do not have the correct number of classes', &
+          &                 ' in the code for the file.')  ! Fatal error
+    ENDIF
+
+    !-
+    ! 1. 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 /)
+
+
+    !-
+    ! 2. Check the mapping for the Zobler types which are going into the ORCHIDEE textures classes 
+    !-
+    DO ib=1,nzobler ! Loop over # classes soil
+       
+       IF (ABS(SUM(textfrac_table(ib,:))-1.0) > EPSILON(1.0)) THEN ! The sum of the textural fractions should not exceed 1 !
+          WRITE(numout,*) &
+               &     'Error in the correspondence table', &
+               &     ' sum is not equal to 1 in', ib
+          WRITE(numout,*) textfrac_table(ib,:)
+          CALL ipslerr_p(3,'get_soilcorr', 'SUM(textfrac_table(ib,:)) /= 1.0',&
+               &                 '', 'Error in the correspondence table') ! Fatal error
+       ENDIF
+       
+    ENDDO ! Loop over # classes soil
+
+    
+  END SUBROUTINE get_soilcorr_zobler
+
+!! tzjsoilusda
+!! ================================================================================================================================
+!! SUBROUTINE 	: get_soilcorr_usda
+!!
+!>\BRIEF         The "get_soilcorr_usda" routine defines the table of correspondence
+!!               between the 12 USDA textural classes and their granulometric composition, 
+!!               as % of silt, sand and clay. This is used to further defien clayfraction.
+!!
+!! DESCRIPTION : get_soilcorr is needed if you use soils_param.nc .\n
+!!               The data from this file is then interpolated to the grid of the model. \n
+!!               The aim is to get fractions for sand loam and clay in each grid box.\n
+!!               This information is used for soil hydrology and respiration.
+!!               The default map in this case is derived from Reynolds et al 2000, \n
+!!               at the 1/12deg resolution, with indices that are consistent with the \n
+!!               textures tabulated below
+!!
+!! RECENT CHANGE(S): Created by A. Ducharne on July 02, 2014
+!!
+!! MAIN OUTPUT VARIABLE(S) : ::texfrac_table
+!!
+!! REFERENCE(S)	: 
+!!
+!! FLOWCHART	: None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE get_soilcorr_usda (nusda,textfrac_table)
+
+    IMPLICIT NONE
+
+    !! 0. Variables and parameters declaration
+    
+    !! 0.1  Input variables
+    
+    INTEGER(i_std),INTENT(in) :: nusda                               !! Size of the array (unitless)
+    
+    !! 0.2 Output variables 
+    
+    REAL(r_std),DIMENSION(nusda,ntext),INTENT(out) :: textfrac_table !! Table of correspondence between soil texture class
+                                                                     !! and granulometric composition (0-1, unitless)
+    
+    !! 0.4 Local variables
+
+    INTEGER(i_std),PARAMETER :: nbtypes_usda = 12                    !! Number of USDA texture classes (unitless)
+    INTEGER(i_std) :: n                                              !! Index (unitless)
+    
+!_ ================================================================================================================================
+
+    !-
+    ! 0. Check consistency
+    !-  
+    IF (nusda /= nbtypes_usda) THEN 
+       CALL ipslerr_p(3,'get_soilcorr', 'nusda /= nbtypes_usda',&
+          &   'We do not have the correct number of classes', &
+          &                 ' in the code for the file.')  ! Fatal error
+    ENDIF
+
+    !! Parameters for soil type distribution :
+    !! Sand, Loamy Sand, Sandy Loam, Silt Loam, Silt, Loam, Sandy Clay Loam, Silty Clay Loam, Clay Loam, Sandy Clay, Silty Clay, Clay
+    ! The order comes from constantes_soil.f90
+    ! The corresponding granulometric composition comes from Carsel & Parrish, 1988
+
+    !-
+    ! 1. Textural fractions for : sand, clay
+    !-
+    textfrac_table(1,2:3)  = (/ 0.93, 0.03 /) ! Sand
+    textfrac_table(2,2:3)  = (/ 0.81, 0.06 /) ! Loamy Sand
+    textfrac_table(3,2:3)  = (/ 0.63, 0.11 /) ! Sandy Loam
+    textfrac_table(4,2:3)  = (/ 0.17, 0.19 /) ! Silt Loam
+    textfrac_table(5,2:3)  = (/ 0.06, 0.10 /) ! Silt
+    textfrac_table(6,2:3)  = (/ 0.40, 0.20 /) ! Loam
+    textfrac_table(7,2:3)  = (/ 0.54, 0.27 /) ! Sandy Clay Loam
+    textfrac_table(8,2:3)  = (/ 0.08, 0.33 /) ! Silty Clay Loam
+    textfrac_table(9,2:3)  = (/ 0.30, 0.33 /) ! Clay Loam
+    textfrac_table(10,2:3) = (/ 0.48, 0.41 /) ! Sandy Clay
+    textfrac_table(11,2:3) = (/ 0.06, 0.46 /) ! Silty Clay
+    textfrac_table(12,2:3) = (/ 0.15, 0.55 /) ! Clay
+
+    ! Fraction of silt
+
+    DO n=1,nusda
+       textfrac_table(n,1) = 1. - textfrac_table(n,2) - textfrac_table(n,3)
+    END DO
+       
+  END SUBROUTINE get_soilcorr_usda
+
+!! ================================================================================================================================
+!! FUNCTION 	: tempfunc
+!!
+!>\BRIEF        ! This function interpolates value between ztempmin and ztempmax
+!! used for lai detection. 
+!!
+!! DESCRIPTION   : This subroutine calculates a scalar between 0 and 1 with the following equation :\n
+!!                 \latexonly
+!!                 \input{constantes_veg_tempfunc.tex}
+!!                 \endlatexonly
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : tempfunc_result
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  FUNCTION tempfunc (temp_in) RESULT (tempfunc_result)
+
+
+    !! 0. Variables and parameters declaration
+
+    REAL(r_std),PARAMETER    :: ztempmin=273._r_std   !! Temperature for laimin (K)
+    REAL(r_std),PARAMETER    :: ztempmax=293._r_std   !! Temperature for laimax (K)
+    REAL(r_std)              :: zfacteur              !! Interpolation factor   (K^{-2})
+
+    !! 0.1 Input variables
+
+    REAL(r_std),INTENT(in)   :: temp_in               !! Temperature (K)
+
+    !! 0.2 Result
+
+    REAL(r_std)              :: tempfunc_result       !! (unitless)
+    
+!_ ================================================================================================================================
+
+    !! 1. Define a coefficient
+    zfacteur = un/(ztempmax-ztempmin)**2
+    
+    !! 2. Computes tempfunc
+    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 !(temp_in > ztempmax)
+
+
+  END FUNCTION tempfunc
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : slowproc_checkveget
+!!
+!>\BRIEF         To verify the consistency of the various fractions defined within the grid box after having been
+!!               been updated by STOMATE or the standard procedures.
+!!
+!! DESCRIPTION  : (definitions, functional, design, flags): 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): :: none
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+!
+  SUBROUTINE slowproc_checkveget(nbpt, frac_nobio, veget_max, veget, soiltile)
+    !
+    !
+    !
+    !  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,nnobio), INTENT(in) :: frac_nobio ! Fraction of ice,lakes,cities, ... (unitless)
+    REAL(r_std),DIMENSION (nbpt,nvm), INTENT(in)    :: veget_max  ! Maximum fraction of vegetation type including none biological fraction (unitless) 
+    REAL(r_std),DIMENSION (nbpt,nvm), INTENT(in)    :: veget      ! Vegetation fractions
+    REAL(r_std),DIMENSION (nbpt,nstm), INTENT(in)   :: soiltile   ! Fraction of soil tiles in the gridbox (unitless)
+    !
+    !  0.2 OUTPUT
+    !
+
+    !
+    !  0.3 LOCAL
+    !
+    INTEGER(i_std) :: ji, jn, jv, js
+    REAL(r_std)  :: epsilocal
+    REAL(r_std)  :: totfrac
+    CHARACTER(len=80) :: str1, str2
+    ! Should be using the ibare_sechiba parameter!
+    !INTEGER(i_std), PARAMETER :: ibaresoil=1
+    !
+!_ ================================================================================================================================
+    !
+    !
+    ! There is some margin added as the computing errors might bring us above EPSILON(un)
+    !
+    epsilocal = EPSILON(un)*1000.
+    !
+    ! 1.0 Verify that none of the fractions are smaller than min_vegfrac, without beeing zero.
+    !
+    DO ji=1,nbpt
+       DO jn=1,nnobio
+          IF ( frac_nobio(ji,jn) > epsilocal .AND. frac_nobio(ji,jn) < min_vegfrac ) THEN
+             WRITE(str1,'("Occurs on grid box", I8," and nobio type ",I3 )') ji, jn
+             WRITE(str2,'("The small value obtained is ", E14.4)') frac_nobio(ji,jn)
+             CALL ipslerr_p (3,'slowproc_checkveget', &
+                   "frac_nobio is larger than zero but smaller than min_vegfrac.", str1, str2)
+          ENDIF
+       ENDDO
+       DO jv=1,nvm
+          IF ( veget_max(ji,jv) > epsilocal .AND. veget_max(ji,jv) < min_vegfrac ) THEN
+             WRITE(str1,'("Occurs on grid box", I8," and nobio type ",I3 )') ji, jn
+             WRITE(str2,'("The small value obtained is ", E14.4)') veget_max(ji,jv)
+             CALL ipslerr_p (3,'slowproc_checkveget', &
+                   "veget_max is larger than zero but smaller than min_vegfrac.", str1, str2)
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    ! 2.0 verify that with all the fractions we cover the entire grid box  
+    !
+    DO ji=1,nbpt
+       totfrac = zero
+       DO jn=1,nnobio
+          totfrac = totfrac + frac_nobio(ji,jn)
+       ENDDO
+       DO jv=1,nvm
+          totfrac = totfrac + veget_max(ji,jv)
+       ENDDO
+       IF ( ABS(totfrac - un) > epsilocal) THEN
+             WRITE(str1,'("This occurs on grid box", I8)') ji
+             WRITE(str2,'("The sum over all fraction and error are ", E14.4, E14.4)') totfrac, ABS(totfrac - un)
+             CALL ipslerr_p (3,'slowproc_checkveget', &
+                   "veget_max + frac_nobio is not equal to 1.", str1, str2)
+             WRITE(*,*) "EPSILON =", epsilocal 
+       ENDIF
+    ENDDO
+    !
+    ! 3.0 Verify that veget is smaller or equal to veget_max
+    !
+    DO ji=1,nbpt
+       DO jv=1,nvm
+          IF ( jv == ibare_sechiba ) THEN
+             IF ( ABS(veget(ji,jv) - veget_max(ji,jv)) > epsilocal ) THEN
+                WRITE(str1,'("This occurs on grid box", I8)') ji
+                WRITE(str2,'("The difference is ", E14.4)') veget(ji,jv) - veget_max(ji,jv)
+                CALL ipslerr_p (3,'slowproc_checkveget', &
+                     "veget is not equal to veget_max on bare soil.", str1, str2)
+             ENDIF
+          ELSE
+             IF ( veget(ji,jv) > veget_max(ji,jv) ) THEN
+                WRITE(str1,'("This occurs on grid box", I8)') ji
+                WRITE(str2,'("The values for veget and veget_max :", F8.4, F8.4)') veget(ji,jv), veget_max(ji,jv)
+                CALL ipslerr_p (3,'slowproc_checkveget', &
+                     "veget is greater than veget_max.", str1, str2)
+             ENDIF
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    ! 4.0 Test tot_bare_soil in relation to the other variables
+    !
+    DO ji=1,nbpt
+       totfrac = zero
+       DO jv=1,nvm
+          totfrac = totfrac + (veget_max(ji,jv) - veget(ji,jv))
+       ENDDO
+       ! add the bare soil fraction to totfrac
+       totfrac = totfrac + veget(ji,ibare_sechiba)
+       ! do the test
+       IF ( ABS(totfrac - tot_bare_soil(ji)) > epsilocal ) THEN
+          WRITE(str1,'("This occurs on grid box", I8)') ji
+          WRITE(str2,'("The values for tot_bare_soil, tot frac and error :", F8.4, F8.4, E14.4)') &
+               &  tot_bare_soil(ji), totfrac, ABS(totfrac - tot_bare_soil(ji))
+          CALL ipslerr_p (3,'slowproc_checkveget', &
+               "tot_bare_soil does not correspond to the total bare soil fraction.", str1, str2)
+       ENDIF
+    ENDDO
+    !
+    ! 5.0 Test that soiltile has the right sum
+    !
+    DO ji=1,nbpt
+       totfrac = zero
+       DO js=1,nstm
+          totfrac = totfrac + soiltile(ji,js)
+       ENDDO
+       IF ( ABS(totfrac - un) > epsilocal ) THEN
+          WRITE(str1,'("This occurs on grid box", I8)') ji
+          WRITE(str2,'("The sum of soiltile and error are :", F8.4, E14.4)') soiltile, ABS(totfrac - un)
+          CALL ipslerr_p (3,'slowproc_checkveget', &
+               "soiltile does not sum-up to one.", str1, str2)
+       ENDIF
+    ENDDO
+    !
+  END SUBROUTINE slowproc_checkveget
+    
+
+END MODULE slowproc
Index: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/thermosoil.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/thermosoil.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/thermosoil.f90	(revision 7236)
@@ -0,0 +1,1666 @@
+! =================================================================================================================================
+! MODULE       : thermosoil
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        Calculates the soil temperatures by solving the heat
+!! diffusion equation within the soil
+!!
+!!\n DESCRIPTION : General important informations about the numerical scheme and
+!!                 the soil vertical discretization:\n
+!!               - the soil is divided into "ngrnd" (=7 by default) layers, reaching to as
+!!                 deep as 5.5m down within the soil, with thiscknesses
+!!                 following a geometric series of ration 2.\n
+!!               - "jg" is usually used as the index going from 1 to ngrnd to describe the
+!!                  layers, from top (jg=1) to bottom (jg=ngrnd)\n
+!!               - the thermal numerical scheme is implicit finite differences.\n
+!!                 -- When it is resolved in thermosoil_profile at the present timestep t, the
+!!                 dependancy from the previous timestep (t-1) is hidden in the
+!!                 integration coefficients cgrnd and dgrnd, which are therefore
+!!                 calculated at the very end of thermosoil_main (call to
+!!                 thermosoil_coef) for use in the next timestep.\n
+!!                 -- At timestep t, the system becomes :\n 
+!!
+!!                              T(k+1)=cgrnd(k)+dgrnd(k)*T(k) \n
+!!                                      -- EQ1 -- \n
+!!
+!!                 (the bottom boundary condition has been used to obtained this equation).\n
+!!                 To solve it, the uppermost soil temperature T(1) is required.
+!!                 It is obtained from the surface temperature Ts, which is
+!!                 considered a linear extrapolation of T(1) and T(2)\n
+!!
+!!                           Ts=(1-lambda)*T(1) -lambda*T(2) \n 
+!!                                      -- EQ2--\n
+!!
+!!                 -- caveat 1 : Ts is called 'temp_soil_new' in this routine,
+!!                 don' t act.\n
+!!                 -- caveat 2 : actually, the surface temperature at time t Ts
+!!                 depends on the soil temperature at time t through the
+!!                 ground heat flux. This is again implicitly solved, with Ts(t)
+!!                 expressed as :\n
+!!
+!!                 soilcap*(Ts(t)-Ts(t-1))/dt=soilflux+otherfluxes(Ts(t))\n 
+!!                                      -- EQ3 --\n
+!!
+!!                 and the dependency from the previous timestep is hidden in
+!!                 soilcap and soilflux (apparent surface heat capacity and heat
+!!                 flux respectively). Soilcap and soilflux are therefore
+!!                 calculated at the previsou timestep, at the very end of thermosoil
+!!                 (final call to thermosoil_coef) and stored to be used at the next time step.
+!!                 At timestep t, EQ3 is solved for Ts in enerbil, and Ts
+!!                 is used in thermosoil to get T(1) and solve EQ1.\n
+!!
+!! - lambda is the @tex $\mu$ @endtex of F. Hourdin' s PhD thesis, equation (A28); ie the
+!! coefficient of the linear extrapolation of Ts (surface temperature) from T1 and T2 (ptn(jg=1) and ptn(jg=2)), so that:\n
+!! Ts= (1+lambda)*T(1)-lambda*T(2) --EQ2-- \n
+!! lambda = (zz_coeff(1))/((zz_coef(2)-zz_coef(1))) \n
+!!
+!! - cstgrnd is the attenuation depth of the diurnal temperature signal
+!! (period : one_day) as a result of the heat conduction equation
+!! with no coefficients :
+!!\latexonly
+!!\input{thermosoil_var_init0.tex}
+!!\endlatexonly
+!!  -- EQ4 --\n
+!! This equation results from the change of variables :
+!! z' =z*sqrt(Cp/K) where z' is the new depth (homogeneous
+!! to sqrt(time) ), z the real depth (in m), Cp and K the soil heat
+!! capacity and conductivity respectively.\n
+!!
+!! the attenuation depth of a diurnal thermal signal for EQ4 is therefore homogeneous to sqrt(time) and
+!! equals : \n
+!! cstgrnd = sqrt(oneday/Pi)
+!!
+!! - lskin is the attenuation depth of the diurnal temperature signal
+!! (period : one_day) within the soil for the complete heat conduction equation
+!! (ie : with coefficients)
+!!\latexonly
+!!\input{thermosoil_var_init00.tex}
+!!\endlatexonly
+!! -- EQ5 --  \n
+!! it can be retrieved from cstgrnd using the change of variable  z' =z*sqrt(Cp/K):\n
+!! lskin = sqrt(K/Cp)*cstgrnd =  sqrt(K/Cp)*sqrt(oneday//Pi)\n
+!! 
+!! In thermosoil, the ratio lskin/cstgrnd is frequently used as the
+!! multiplicative factor to go from
+!!'adimensional' depths (like z' ) to real depths (z). z' is not really
+!! adimensional but is reffered to like this in the code.
+!!
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! REFERENCE(S) : None
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE thermosoil
+
+  ! modules used :
+  USE ioipsl
+  USE ioipsl_para
+  USE xios_orchidee
+  USE constantes
+  USE constantes_soil
+  USE sechiba_io
+  USE grid
+
+
+  IMPLICIT NONE
+
+  !private and public routines :
+  PRIVATE
+  PUBLIC :: thermosoil_main, thermosoil_clear, thermosoil_levels
+
+  LOGICAL, SAVE                                   :: l_first_thermosoil=.TRUE.!! does the initialisation of the routine 
+                                                                              !! (true/false)
+!$OMP THREADPRIVATE(l_first_thermosoil)
+  CHARACTER(LEN=80) , SAVE                        :: var_name                 !! To store variables names for the 
+                                                                              !! input-outputs dealt with by IOIPSL
+!$OMP THREADPRIVATE(var_name)
+  REAL(r_std), SAVE                               :: lambda, cstgrnd, lskin   !! See Module description
+!$OMP THREADPRIVATE(lambda, cstgrnd, lskin)
+  REAL(r_std), SAVE                               :: fz1, zalph               !! usefull constants for diverse use
+!$OMP THREADPRIVATE(fz1, zalph)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: ptn                      !! vertically discretized 
+                                                                              !! soil temperatures @tex ($K$) @endtex. 
+!$OMP THREADPRIVATE(ptn)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: zz                       !! depths of the soil thermal numerical nodes. 
+                                                                              !! Caveats: they are not exactly the centers of the
+                                                                              !! thermal layers, see the calculation in 
+                                                                              !! ::thermosoil_var_init  @tex ($m$) @endtex.
+!$OMP THREADPRIVATE(zz)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: zz_coef		      !! depths of the boundaries of the thermal layers,
+                                                                              !! see the calculation in 
+                                                                              !! thermosoil_var_init  @tex ($m$) @endtex.
+!$OMP THREADPRIVATE(zz_coef)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: dz1                      !! numerical constant used in the thermal numerical
+                                                                              !! scheme  @tex ($m^{-1}$) @endtex. ; it corresponds
+                                                                              !! to the coefficient  @tex $d_k$ @endtex of equation
+                                                                              !! (A.12) in F. Hourdin PhD thesis.
+!$OMP THREADPRIVATE(dz1)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: dz2                      !! thicknesses of the thermal layers  @tex ($m$)
+                                                                              !! @endtex; typically: 
+                                                                              !! dz2(jg)=zz_coef(jg+1)-zz_coef(jg); calculated once 
+                                                                              !! and for all in thermosoil_var_init
+!$OMP THREADPRIVATE(dz2)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: z1                       !! constant of the numerical scheme; it is an 
+                                                                              !! intermediate buffer for the calculation of the 
+                                                                              !! integration coefficients cgrnd and dgrnd.
+!$OMP THREADPRIVATE(z1)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: cgrnd                    !! integration coefficient for the numerical scheme,
+                                                                              !! see eq.1
+!$OMP THREADPRIVATE(cgrnd)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: dgrnd                    !! integration coefficient for the numerical scheme,
+                                                                              !! see eq.1
+!$OMP THREADPRIVATE(dgrnd)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: pcapa                    !! volumetric vertically discretized soil heat 
+                                                                              !! capacity  @tex ($J K^{-1} m^{-3}$) @endtex. 
+                                                                              !! It depends on the soil
+                                                                              !! moisture content (wetdiag) and is calculated at 
+                                                                              !! each time step in thermosoil_coef.
+!$OMP THREADPRIVATE(pcapa)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: pkappa                   !! vertically discretized soil thermal conductivity 
+                                                                              !!  @tex ($W K^{-1} m^{-1}$) @endtex. Same as pcapa.
+!$OMP THREADPRIVATE(pkappa)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: zdz1                     !! numerical constant of the numerical scheme; it is
+                                                                              !! an intermediate buffer for the calculation of the 
+                                                                              !! integration coefficients cgrnd and dgrnd 
+                                                                              !!  @tex ($W K^{-1} m^{-1}$) @endtex 
+!$OMP THREADPRIVATE(zdz1)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: zdz2                     !! numerical constant of the numerical scheme; it is 
+                                                                              !! an intermediate buffer for the calculation of the 
+                                                                              !! integration coefficients cgrnd and dgrnd
+                                                                              !!  @tex ($W K^{-1} m^{-1}$) @endtex
+!$OMP THREADPRIVATE(zdz2)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: pcapa_en                 !! heat capacity used for surfheat_incr and 
+                                                                              !! coldcont_incr 
+!$OMP THREADPRIVATE(pcapa_en)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: ptn_beg                  !! vertically discretized temperature at the 
+                                                                              !! beginning of the time step  @tex ($K$) @endtex; 
+                                                                              !! is used in 
+                                                                              !! thermosoil_energy for energy-related diagnostic of
+                                                                              !! the routine.
+!$OMP THREADPRIVATE(ptn_beg)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: temp_sol_beg             !! Surface temperature at the beginning of the 
+                                                                              !! timestep  @tex ($K$) @endtex
+!$OMP THREADPRIVATE(temp_sol_beg)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: surfheat_incr            !! Change in soil heat content during the timestep 
+                                                                              !!  @tex ($J$) @endtex.
+!$OMP THREADPRIVATE(surfheat_incr)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: coldcont_incr            !! Change in snow heat content  @tex ($J$) @endtex.
+!$OMP THREADPRIVATE(coldcont_incr)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: wetdiag                  !! Soil wetness on the thermodynamical levels 
+                                                                              !! (1, ngrnd) (0-1, dimensionless). corresponds to the
+                                                                              !! relative soil humidity to the wilting point when 
+                                                                              !! the 11-layers hydrology (hydrol) is used, see more
+                                                                              !! precisions in thermosoil_humlev.
+!$OMP THREADPRIVATE(wetdiag)
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE   : thermosoil_main
+!!
+!>\BRIEF        Thermosoil_main computes the soil thermal properties and dynamics, ie solves
+!! the heat diffusion equation within the soil. The soil temperature profile is
+!! then interpolated onto the diagnostic axis.
+!!
+!! DESCRIPTION : The resolution of the soil heat diffusion equation 
+!! relies on a numerical finite-difference implicit scheme
+!! fully described in the reference and in the header of the thermosoil module.
+!! - The dependency of the previous timestep hidden in the 
+!! integration coefficients cgrnd and dgrnd (EQ1), calculated in thermosoil_coef, and 
+!! called at the end of the routine to prepare for the next timestep.
+!! - The effective computation of the new soil temperatures is performed in thermosoil_profile. 
+!!
+!! - The calling sequence of thermosoil_main is summarized in the flowchart below.
+!! - Thermosoil_init and thermosoil_var_init initialize the variables from
+!! restart files or with default values; they also set up
+!! the vertical discretization for the numerical scheme.
+!! - thermosoil_coef calculates the coefficients for the numerical scheme for the very first iteration of thermosoil;
+!! after that, thermosoil_coef is called only at the end of the module to calculate the coefficients for the next timestep.
+!! - thermosoil_profile solves the numerical scheme.\n
+!!
+!! - Flags : one unique flag : THERMOSOIL_TPRO (to be set to the desired initial soil in-depth temperature in K; by default 280K)
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): vertically discretized soil temperatures ptn, soil
+!! thermal properties (pcapa, pkappa), apparent surface heat capacity (soilcap)
+!! and heat flux (soilflux) to be used in enerbil at the next timestep to solve
+!! the surface energy balance.
+!!
+!! REFERENCE(S) : 
+!! - Hourdin, F. (1992). Study and numerical simulation of the general circulation of planetary atmospheres,
+!!  Ph.D. thesis, Paris VII University. Remark: the part of F. Hourdin' s PhD thesis relative to the thermal
+!!  integration scheme has been scanned and is provided along with the documentation, with name : 
+!!  Hourdin_1992_PhD_thermal_scheme.pdf
+!!
+!! FLOWCHART    : 
+!! \latexonly
+!! \includegraphics[scale = 1]{thermosoil_flowchart.png}
+!! \endlatexonly
+!! 
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE thermosoil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexgrnd, &
+       & temp_sol_new, snow, soilcap, soilflx, shumdiag, stempdiag, ptnlev1, rest_id, hist_id, hist2_id)
+
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                            :: kjit             !! Time step number (unitless) 
+    INTEGER(i_std), INTENT(in)                            :: kjpindex         !! Domain size (unitless)
+    INTEGER(i_std),INTENT (in)                            :: rest_id,hist_id  !! Restart_ file and history file identifier 
+                                                                              !! (unitless)
+    INTEGER(i_std),INTENT (in)                            :: hist2_id         !! history file 2 identifier (unitless)
+    REAL(r_std), INTENT (in)                              :: dtradia          !! model iteration time step in seconds (s)
+    LOGICAL, INTENT(in)                                   :: ldrestart_read   !! Logical for restart files to be read 
+                                                                              !! (true/false)
+    LOGICAL, INTENT(in)                                   :: ldrestart_write  !! Logical for restart files to be writen 
+                                                                              !! (true/false)
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)      :: index            !! Indeces of the points on the map (unitless)
+    INTEGER(i_std),DIMENSION (kjpindex*ngrnd), INTENT (in):: indexgrnd        !! Indeces of the points on the 3D map (vertical 
+                                                                              !! dimension towards the ground) (unitless)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)         :: temp_sol_new     !! Surface temperature at the present time-step,
+                                                                              !! Ts @tex ($K$) @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)         :: snow             !! Snow mass @tex ($kg$) @endtex.
+                                                                              !! Caveat: when there is snow on the
+                                                                              !! ground, the snow is integrated into the soil for
+                                                                              !! the calculation of the thermal dynamics. It means
+                                                                              !! that the uppermost soil layers can completely or 
+                                                                              !! partially consist in snow. In the second case, zx1
+                                                                              !! and zx2 are the fraction of the soil layer 
+                                                                              !! consisting in snow and 'normal' soil, respectively
+                                                                              !! This is calculated in thermosoil_coef.
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in)    :: shumdiag         !! Relative soil humidity on the diagnostic axis 
+                                                                              !! (0-1, unitless). Caveats: when "hydrol" 
+                                                                              !! (the 11-layers hydrology) 
+                                                                              !! is used, this humidity is 
+                                                                              !! calculated with respect to the wilting point: 
+                                                                              !! shumdiag= (mc-mcw)/(mcs-mcw), with mc : moisture 
+                                                                              !! content; mcs : saturated soil moisture content; 
+                                                                              !! mcw: soil moisture content at the wilting point. 
+                                                                              !! When the 2-layers hydrology "hydrolc" is used, 
+                                                                              !! shumdiag is just a soil wetness index, from 0 to 1
+                                                                              !! but cannot direcly be linked to a soil moisture 
+                                                                              !! content.
+    
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)      :: soilcap          !! apparent surface heat capacity
+                                                                              !! @tex ($J m^{-2} K^{-1}$) @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)      :: soilflx          !! apparent soil heat flux @tex ($W m^{-2}$) @endtex
+                                                                              !! , positive 
+                                                                              !! towards the soil, writen as Qg (ground heat flux) 
+                                                                              !! in the history files, and computed at the end of 
+                                                                              !! thermosoil for the calculation of Ts in enerbil, 
+                                                                              !! see EQ3.
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (inout) :: stempdiag        !! diagnostic temperature profile @tex ($K$) @endtex
+                                                                              !! , eg on the 
+                                                                              !! diagnostic axis (levels:1:nbdl). The soil 
+                                                                              !! temperature is put on this diagnostic axis to be
+                                                                              !! used by other modules (slowproc.f90; routing.f90;
+                                                                              !! hydrol or hydrolc when a frozen soil 
+                                                                              !! parametrization is used..)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)       :: ptnlev1           !! 1st level soil temperature   
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    REAL(r_std),DIMENSION (kjpindex,ngrnd)                :: temp             !! buffer
+    REAL(r_std),DIMENSION (kjpindex,ngrnd-1)              :: temp1            !! buffer
+    REAL(r_std),DIMENSION (kjpindex)                      :: temp2            !! buffer
+    CHARACTER(LEN=80)                                     :: var_name         !! To store variables names for I/O
+
+!_ ================================================================================================================================
+    
+  !! 1. do initialisation
+    
+    IF (l_first_thermosoil) THEN
+
+        IF (long_print) WRITE (numout,*) ' l_first_thermosoil : call thermosoil_init '
+
+        
+        !! 1.1. Allocate and initialize soil temperatures variables
+        !! by reading restart files or using default values. 
+        CALL thermosoil_init (kjit, ldrestart_read, kjpindex, index, rest_id)
+
+       
+        !! 1.2.Computes physical constants and arrays; initializes soil thermal properties; produces the first stempdiag
+        !!  Computes some physical constants and arrays depending on the soil vertical discretization 
+        !! (lskin, cstgrnd, zz, zz_coef, dz1, dz2); get the vertical humidity onto the thermal levels, and 
+        !! initializes soil thermal properties (pkappa, pcapa); produces the first temperature diagnostic stempdiag.
+        CALL thermosoil_var_init (kjpindex, zz, zz_coef, dz1, dz2, pkappa, pcapa, pcapa_en, shumdiag, stempdiag, snow)
+
+        
+        !! 1.3. Computes cgrd, dgrd, soilflx and soilcap coefficients from restart values or initialisation values.
+        CALL thermosoil_coef (kjpindex, dtradia, temp_sol_new, snow, ptn, soilcap, soilflx, zz, dz1, dz2, z1, zdz1,&
+           & zdz2, cgrnd, dgrnd, pcapa, pcapa_en, pkappa)
+        
+        !! 1.4. call to thermosoil_energy, if you wish to perform some checks (?)
+        !!?? the usefulness of this routine seems questionable.
+        CALL thermosoil_energy (kjpindex, temp_sol_new, soilcap, .TRUE.)
+
+        !! 1.5. read restart files for other variables than ptn.
+        !!?? mind the use of ok_var here.
+        !!?? ok_var is a function of sechiba_io_p.f90, documented as follows :
+        !!!! 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
+         !!
+         !! from what we understand, it looks for the chain varname in
+         !!run.def; if absent, returns .FALSE., and the variable named
+         !!'varname' is not searched for in the restart. This looks like a
+         !!trick to read variables in restart files when they are not read
+         !!there by default. For all variables in the following sequence, ok_var
+         !!is by default false, so don' t bother about this.
+         !! this is also logical as those variables have been initialized
+         !!above.
+         !!?? so maybe this part of the code could be deleted to add clarity.
+        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_p('UNITS', '-')
+           CALL ioconf_setatt_p('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_p('UNITS', '-')
+           CALL ioconf_setatt_p('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_p('UNITS', '-')
+           CALL ioconf_setatt_p('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_p('UNITS', '-')
+           CALL ioconf_setatt_p('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_p('UNITS', '-')
+           CALL ioconf_setatt_p('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_p('UNITS', '-')
+           CALL ioconf_setatt_p('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_p('UNITS', '-')
+           CALL ioconf_setatt_p('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_p('UNITS', '-')
+           CALL ioconf_setatt_p('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_p('UNITS', 'K')
+           CALL ioconf_setatt_p('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 !ldrestart_read
+
+        RETURN 
+
+    ENDIF !l_first_thermosoil
+
+    
+  !! 2. Prepares the restart files for the next simulation
+
+    !!?? do all the coefficients (cgrnd, dgrnd...) be put in the restart file
+    !! as they are by default not read there, but calculated in
+    !!thermosoil_var_init from the restart or initial temperature ?
+    !! exceptions are soilcap and soilflx, used in enerbil, and of course ptn.
+    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 !ldrestart_write
+
+  !! 3. Put the soil wetness diagnostic on the levels of the soil temperature
+
+    !!?? this could logically be put just before the last call to
+    !!thermosoil_coef, as the results are used there...
+    CALL thermosoil_humlev(kjpindex, shumdiag, snow)
+
+    
+  !! 4. Effective computation of the soil temperatures profile, using the cgrd and dgrd coefficients from previsou tstep.
+    
+    CALL thermosoil_profile (kjpindex, temp_sol_new, ptn, stempdiag)
+
+  !! 5. Call to thermosoil_energy, still to be clarified..
+
+    CALL thermosoil_energy (kjpindex, temp_sol_new, soilcap, .FALSE.)
+    
+  !! 6. Writing the history files according to the ALMA standards (or not..)
+
+    !in only one file (hist2_id <=0) or in 2 different files (hist2_id >0).
+    CALL xios_orchidee_send_field("ptn",ptn)
+    CALL xios_orchidee_send_field("Qg",soilflx)
+    CALL xios_orchidee_send_field("DelSurfHeat",surfheat_incr)
+    CALL xios_orchidee_send_field("DelColdCont",coldcont_incr)
+
+    IF ( .NOT. almaoutput ) THEN
+      CALL histwrite_p(hist_id, 'ptn', kjit, ptn, kjpindex*ngrnd, indexgrnd)
+    ELSE
+      CALL histwrite_p(hist_id, 'SoilTemp', kjit, ptn, kjpindex*ngrnd, indexgrnd)
+      CALL histwrite_p(hist_id, 'Qg', kjit, soilflx, kjpindex, index)
+      CALL histwrite_p(hist_id, 'DelSurfHeat', kjit, surfheat_incr, kjpindex, index)
+      CALL histwrite_p(hist_id, 'DelColdCont', kjit, coldcont_incr, kjpindex, index)
+    ENDIF
+    IF ( hist2_id > 0 ) THEN
+       IF ( .NOT. almaoutput ) THEN
+          CALL histwrite_p(hist2_id, 'ptn', kjit, ptn, kjpindex*ngrnd, indexgrnd)
+       ELSE
+          CALL histwrite_p(hist2_id, 'SoilTemp', kjit, ptn, kjpindex*ngrnd, indexgrnd)
+          CALL histwrite_p(hist2_id, 'Qg', kjit, soilflx, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'DelSurfHeat', kjit, surfheat_incr, kjpindex, index)
+          CALL histwrite_p(hist2_id, 'DelColdCont', kjit, coldcont_incr, kjpindex, index)
+       ENDIF
+    ENDIF
+    
+  !! 7. A last final call to thermosoil_coef
+ 
+    !! A last final call to thermosoil_coef, which calculates the different
+    !!coefficients (cgrnd, dgrnd, dz1, z1, zdz2, soilcap, soilflx) from this time step to be
+    !!used at the next time step, either in the surface temperature calculation
+    !!(soilcap, soilflx) or in the soil thermal numerical scheme.
+    CALL thermosoil_coef (kjpindex, dtradia, temp_sol_new, snow, ptn, soilcap, soilflx, zz, dz1, dz2, z1, zdz1,&
+           & zdz2, cgrnd, dgrnd, pcapa, pcapa_en, pkappa)
+
+    ptnlev1(:) = ptn(:,1)
+
+    IF (long_print) WRITE (numout,*) ' thermosoil_main done '
+
+  END SUBROUTINE thermosoil_main
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : thermosoil_init
+!!
+!>\BRIEF        Allocates local and global arrays; initializes soil temperatures using either restart files
+!! or a fixed value set by the flag THERMOSOIL_TPRO.
+!!		  
+!! DESCRIPTION  : flag : THERMOSOIL_TPRO (to be set to the desired initial temperature in K; by default 280K).
+!!
+!! RECENT CHANGE(S) : None 
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCE(S) : None 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE thermosoil_init(kjit, ldrestart_read, kjpindex, index, rest_id)
+
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT (in)                         :: kjit               !! Time step number (unitless) 
+    LOGICAL,INTENT (in)                                 :: ldrestart_read     !! Logical for restart file to read (true/false)
+    INTEGER(i_std), INTENT (in)                         :: kjpindex           !! Domain size (unitless)
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)    :: index              !! Indeces of the points on the map (unitless)
+    INTEGER(i_std), INTENT (in)                         :: rest_id            !! Restart file identifier (unitless)
+    
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                     :: ier
+    CHARACTER(LEN=80)                                  :: var_name            !! To store variables names for I/O
+
+!_ ================================================================================================================================
+
+  !! 1. Initialisation
+
+    !! Initialisation has to be done only one time, so the logical
+    !! logical l_first_thermosoil has to be set to .FALSE. now..
+    IF (l_first_thermosoil) THEN 
+        l_first_thermosoil=.FALSE.
+    ELSE 
+        WRITE (numout,*) ' l_first_thermosoil false . we stop '
+        STOP 'thermosoil_init'
+    ENDIF
+
+  !! 2. Arrays allocations
+
+    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
+
+    ALLOCATE (zz(ngrnd),stat=ier)
+    IF (ier /= 0) THEN
+       CALL ipslerr_p(3,'thermosoil_init', 'Error in allocation of zz','','')
+    END IF
+
+    ALLOCATE (zz_coef(ngrnd),stat=ier)
+    IF (ier /= 0) THEN
+       CALL ipslerr_p(3,'thermosoil_init', 'Error in allocation of zz_coef','','')
+    END IF
+
+    ALLOCATE (dz1(ngrnd),stat=ier)
+    IF (ier /= 0) THEN
+       CALL ipslerr_p(3,'thermosoil_init', 'Error in allocation of dz1','','')
+    END IF
+
+    ALLOCATE (dz2(ngrnd),stat=ier)
+    IF (ier /= 0) THEN
+       CALL ipslerr_p(3,'thermosoil_init', 'Error in allocation of dz2','','')
+    END IF
+
+    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
+
+    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
+    
+  !! 3. Reads restart files for soil temperatures only 
+    
+    !! Reads restart files for soil temperatures only. If no restart file is
+    !! found,  the initial soil temperature is by default set to 280K at all depths. The user
+    !! can decide to initialize soil temperatures at an other value, in which case he should set the flag THERMOSOIL_TPRO
+    !! to this specific value in the run.def.
+    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_p('UNITS', 'K')
+        CALL ioconf_setatt_p('LONG_NAME','Soil Temperature profile')
+        CALL restget_p (rest_id, var_name, nbp_glo, ngrnd, 1, kjit, .TRUE., ptn, "gather", nbp_glo, index_g)
+        !
+        !Config Key   = THERMOSOIL_TPRO
+        !Config Desc  = Initial soil temperature profile if not found in restart
+        !Config Def   = 280.
+        !Config If    = OK_SECHIBA
+        !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.
+        !Config Units = Kelvin [K]
+        !
+        CALL setvar_p (ptn, val_exp,'THERMOSOIL_TPRO',280._r_std)
+
+    ENDIF
+
+    IF (long_print) WRITE (numout,*) ' thermosoil_init done '
+
+  END SUBROUTINE thermosoil_init
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : thermosoil_clear
+!!
+!>\BRIEF        Sets the flag l_first_thermosoil to true and desallocates the allocated arrays.
+!! ??!! the call of thermosoil_clear originates from sechiba_clear but the calling sequence and 
+!! its purpose require further investigation.
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S) : None 
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCE(S) : None 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+ 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
+!!
+!>\BRIEF        fz(rk), the function's result, is the "rk"th element of a geometric series 
+!! with first element fz1 and ration zalph.
+!!
+!! DESCRIPTION  : This function is used to calculate the depths of the boudaries of the thermal layers (zz_coef) and 
+!! of the numerical nodes (zz) of the thermal scheme. Formulae to get the adimensional depths are followings :
+!!      zz(jg)      = fz(REAL(jg,r_std) - undemi); \n
+!!      zz_coef(jg) = fz(REAL(jg,r_std))
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! RETURN VALUE : fz(rk)
+!!
+!! REFERENCE(S) : None 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  FUNCTION fz(rk) RESULT (fz_result)
+
+  !! 0. Variables and parameter declaration
+
+    !! 0.1 Input variables
+
+    REAL(r_std), INTENT(in)                        :: rk
+    
+    !! 0.2 Output variables
+
+    REAL(r_std)                                    :: fz_result
+    
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+!_ ================================================================================================================================
+
+    fz_result = fz1 * (zalph ** rk - un) / (zalph - un)
+
+  END FUNCTION fz
+
+
+!! ================================================================================================================================
+!! FUNCTION     : thermosoil_levels
+!!
+!>\BRIEF          Depth of nodes for the thermal layers in meters. 
+!!
+!! DESCRIPTION  : Calculate and return the depth in meters of the nodes of the soil layers. This calculation is the same 
+!!                as done in thermosoil_var_init for zz. See thermosoil_var_init for more details. 
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! RETURN VALUE : Vector of soil depth for the nodes in meters
+!!
+!! REFERENCE(S) : None 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  FUNCTION thermosoil_levels() RESULT (zz_out)
+    
+    !! 0.1 Return variable
+    
+    REAL(r_std), DIMENSION (ngrnd)  :: zz_out      !! Depth of soil layers in meters
+    
+    !! 0.2 Local variables
+    INTEGER(i_std)                  :: jg
+    REAL(r_std)                     :: so_capa
+    REAL(r_std)                     :: so_cond
+    
+!_ ================================================================================================================================
+
+    !! 1. Define some parameters
+    so_capa = (so_capa_dry + so_capa_wet)/deux
+    so_cond = (so_cond_dry + so_cond_wet)/deux
+    
+    cstgrnd=SQRT(one_day / pi)
+    lskin = SQRT(so_cond / so_capa * one_day / pi)
+
+    !! Parameters needed by fz function
+    fz1 = 0.3_r_std * cstgrnd
+    zalph = deux
+
+    !!  2. Get adimentional depth of the numerical nodes
+    DO jg=1,ngrnd
+       zz_out(jg) = fz(REAL(jg,r_std) - undemi)
+    ENDDO
+    
+    !! 3. Convert to meters
+    DO jg=1,ngrnd
+       zz_out(jg) = zz_out(jg) /  cstgrnd * lskin
+    END DO
+
+  END FUNCTION thermosoil_levels
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : thermosoil_var_init
+!!
+!>\BRIEF        Define and initializes the soil thermal parameters
+!!		  
+!! DESCRIPTION	: This routine\n
+!! 1. Defines the parameters ruling the vertical grid of the thermal scheme (fz1, zalpha).\n
+!! 2. Defines the scaling coefficients for adimensional depths (lskin, cstgrnd, see explanation in the 
+!!    variables description of thermosoil_main). \n
+!! 3. Calculates the vertical discretization of the soil (zz, zz_coef, dz2) and the constants used
+!!    in the numerical scheme and which depend only on the discretization (dz1, lambda).\n
+!! 4. Initializes the soil thermal parameters (capacity, conductivity) based on initial soil moisture content.\n
+!! 5. Produces a first temperature diagnostic based on temperature initialization.\n
+!!
+!! The scheme comprizes ngrnd=7 layers by default.
+!! The layer' s boundaries depths (zz_coef) follow a geometric series of ratio zalph=2 and first term fz1.\n
+!! zz_coef(jg)=fz1.(1-zalph^jg)/(1-zalph) \n
+!! The layers' boudaries depths are first calculated 'adimensionally', ie with a
+!! discretization adapted to EQ5. This discretization is chosen for its ability at
+!! reproducing a thermal signal with periods ranging from days to centuries. (see
+!! Hourdin, 1992). Typically, fz1 is chosen as : fz1=0.3*cstgrnd (with cstgrnd the
+!! adimensional attenuation depth). \n
+!! The factor lskin/cstgrnd is then used to go from adimensional depths to
+!! depths in m.\n
+!! zz(real)=lskin/cstgrnd*zz(adimensional)\n
+!! Similarly, the depths of the numerical nodes are first calculated
+!! adimensionally, then the conversion factor is applied.\n
+!! the numerical nodes (zz) are not exactly the layers' centers : their depths are calculated as follows:\n
+!! zz(jg)=fz1.(1-zalph^(jg-1/2))/(1-zalph)\n
+!! The values of zz and zz_coef used in the default thermal discretization are in the following table.
+!! \latexonly
+!! \includegraphics{thermosoil_var_init1.jpg}
+!! \endlatexonly\n
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : None
+!!
+!! REFERENCE(S)	:
+!! - Hourdin, F. (1992). Study and numerical simulation of the general circulation of 
+!! planetary atmospheres, Ph.D. thesis, Paris VII University.
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE thermosoil_var_init(kjpindex, zz, zz_coef, dz1, dz2, pkappa, pcapa, pcapa_en, shumdiag, stempdiag, snow)
+
+  !! 0. Variables and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                               :: kjpindex          !! Domain size (unitless)
+    REAL(r_std), DIMENSION (kjpindex,nbdl), INTENT (in)      :: shumdiag          !! Relative soil humidity on the diagnostic axis 
+                                                                                  !! (unitless), [0,1]. (see description of the 
+                                                                                  !! variables of thermosoil_main for more 
+                                                                                  !! explanations) 
+    REAL(r_std), DIMENSION (kjpindex), INTENT (in)     	     :: snow              !! Snow quantity   
+    
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION (ngrnd), INTENT(out)              :: zz                !! depths of the layers'numerical nodes 
+                                                                                  !! @tex ($m$)@endtex 
+    REAL(r_std), DIMENSION (ngrnd), INTENT(out)              :: zz_coef		  !! depths of the layers'boundaries 
+                                                                                  !! @tex ($m$)@endtex 
+    REAL(r_std), DIMENSION (ngrnd), INTENT(out)              :: dz1               !! numerical constant depending on the vertical
+                                                                                  !! thermal grid only @tex  ($m^{-1}$) @endtex. 
+                                                                                  !! (see description
+                                                                                  !! of the variables of thermosoil_main for more
+                                                                                  !! explanations)
+    REAL(r_std), DIMENSION (ngrnd), INTENT(out)              :: dz2               !! thicknesses of the soil thermal layers 
+                                                                                  !! @tex ($m$) @endtex
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out)     :: pcapa             !! volumetric vertically discretized soil heat 
+                                                                                  !! capacity @tex ($J K^{-1} m^{-3}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out)     :: pcapa_en	  !! volumetric vertically discretized heat 
+                                                                                  !! capacity used in thermosoil_energy
+                                                                                  !! @tex ($J K^{-1} m^{-3}$) @endtex ;
+                                                                                  !! usefulness still to be clarified.
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out)     :: pkappa            !! vertically discretized soil thermal 
+                                                                                  !! conductivity @tex ($W m^{-1} K^{-1}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex,nbdl), INTENT (out)     :: stempdiag         !! Diagnostic temperature profile @tex ($K$)
+                                                                                  !! @endtex
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                           :: ier, ji, jg       !! Index (unitless)
+    REAL(r_std)                                              :: sum               !! Temporary variable
+    REAL(r_std)                                              :: so_capa           !! Average Thermal Conductivity of soils 
+                                                                                  !! @tex $(W.m^{-2}.K^{-1})$ @endtex
+    REAL(r_std)                                              :: so_cond           !! Average Thermal Conductivity of soils 
+                                                                                  !! @tex $(W.m^{-2}.K^{-1})$ @endtex
+
+!_ ================================================================================================================================
+
+  !! 1. Initialization of the parameters of the vertical discretization and of the attenuation depths
+    
+    !! so_capa and so_cond are temporary variables which contain the average values of soil conductivity 
+    !! and soil conductivity and are only needed in thermosoil_var_init to set the vertical layering. 
+    so_capa = (so_capa_dry + so_capa_wet)/deux
+    so_cond = (so_cond_dry + so_cond_wet)/deux
+
+    cstgrnd=SQRT(one_day / pi)
+    lskin = SQRT(so_cond / so_capa * one_day / pi)
+    fz1 = 0.3_r_std * cstgrnd
+    zalph = deux
+    
+  !! 2.  Computing the depth of the thermal levels (numerical nodes) and the layers boundaries
+   
+    !! Computing the depth of the thermal levels (numerical nodes) and 
+    !! the layers boundariesusing the so-called
+    !! adimentional variable z' = z/lskin*cstgrnd (with z in m)
+    
+    !! 2.1 adimensional thicknesses of the layers
+    DO jg=1,ngrnd
+
+    !!?? code simplification hopefully possible here with up-to-date compilers !
+    !!! 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
+    
+    !! 2.2 adimentional depth of the numerical nodes and layers' boudaries
+    DO jg=1,ngrnd
+      zz(jg)      = fz(REAL(jg,r_std) - undemi)
+      zz_coef(jg) = fz(REAL(jg,r_std)-undemi+undemi)
+    ENDDO
+
+    !! 2.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
+
+    !! 2.4 Computing some usefull constants for the numerical scheme
+    DO jg=1,ngrnd-1
+      dz1(jg)  = un / (zz(jg+1) - zz(jg))
+    ENDDO
+    lambda = zz(1) * dz1(1)
+
+    !! 2.5 Get the wetness profile on the thermal vertical grid from the diagnostic axis
+    CALL thermosoil_humlev(kjpindex, shumdiag, snow)
+
+    !! 2.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
+    
+  !! 3. Diagnostics : consistency checks on the vertical grid.
+
+    WRITE (numout,*) 'diagnostic des niveaux dans le sol' !!?? to be changed,
+    WRITE (numout,*) 'niveaux intermediaires et pleins'
+    sum = zero
+    DO jg=1,ngrnd
+      sum = sum + dz2(jg)
+      WRITE (numout,*) zz(jg),sum
+    ENDDO
+
+    
+  !! 4. Compute a first diagnostic temperature profile
+    
+    CALL thermosoil_diaglev(kjpindex, stempdiag)
+
+    IF (long_print) WRITE (numout,*) ' thermosoil_var_init done '
+
+  END SUBROUTINE thermosoil_var_init
+  
+
+!! ================================================================================================================================
+!! SUBROUTINE   : thermosoil_coef
+!!
+!>\BRIEF        Calculate soil thermal properties, integration coefficients, apparent heat flux,
+!! surface heat capacity,  
+!!
+!! DESCRIPTION	: This routine computes : \n
+!!		1. the soil thermal properties. \n 
+!!		2. the integration coefficients of the thermal numerical scheme, cgrnd and dgrnd,
+!!              which depend on the vertical grid and on soil properties, and are used at the next 
+!!              timestep.\n
+!!              3. the soil apparent heat flux and surface heat capacity soilflux
+!!              and soilcap, used by enerbil to compute the surface temperature at the next
+!!              timestep.\n
+!!             -  The soil thermal properties depend on water content (wetdiag) and on the presence 
+!!              of snow : snow is integrated into the soil for the thermal calculations, ie if there 
+!!              is snow on the ground, the first thermal layer(s) consist in snow, depending on the 
+!!              snow-depth. If a layer consists out of snow and soil, wheighed soil properties are 
+!!              calculated\n
+!!             - The coefficients cgrnd and dgrnd are the integration
+!!              coefficients for the thermal scheme \n
+!!                              T(k+1)=cgrnd(k)+dgrnd(k)*T(k) \n
+!!                                      -- EQ1 -- \n
+!!              They correspond respectively to $\beta$ and $\alpha$ from F. Hourdin\'s thesis and 
+!!              their expression can be found in this document (eq A19 and A20)
+!!             - soilcap and soilflux are the apparent surface heat capacity and flux
+!!               used in enerbil at the next timestep to solve the surface
+!!               balance for Ts (EQ3); they correspond to $C_s$ and $F_s$ in F.
+!!               Hourdin\'s PhD thesis and are expressed in eq. A30 and A31. \n
+!!                 soilcap*(Ts(t)-Ts(t-1))/dt=soilflux+otherfluxes(Ts(t)) \n
+!!                                      -- EQ3 --\n
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): cgrnd, dgrnd, pcapa, pkappa, soilcap, soilflx
+!!
+!! REFERENCE(S) :
+!! - Hourdin, F. (1992). Study and numerical simulation of the general circulation of planetary atmospheres,
+!! Ph.D. thesis, Paris VII University. Remark: the part of F. Hourdin's PhD thesis relative to the thermal
+!! integration scheme has been scanned and is provided along with the documentation, with name : 
+!! Hourdin_1992_PhD_thermal_scheme.pdf
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE thermosoil_coef (kjpindex, dtradia, temp_sol_new, snow, ptn, soilcap, soilflx, zz, dz1, dz2, z1, zdz1,&
+           & zdz2, cgrnd, dgrnd, pcapa, pcapa_en, pkappa)
+
+  !! 0. Variables and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                             :: kjpindex     !! Domain size (unitless)
+    REAL(r_std), INTENT (in)                               :: dtradia      !! Time step in seconds @tex ($s$) @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT (in)         :: temp_sol_new !! soil surface temperature @tex ($K$) @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT (in)         :: snow         !! snow mass @tex ($Kg$) @endtex
+    REAL(r_std), DIMENSION (ngrnd), INTENT(in)             :: zz           !! depths of the soil thermal numerical nodes 
+                                                                           !! @tex ($m$) @endtex 
+    REAL(r_std), DIMENSION (ngrnd), INTENT(in)             :: dz1          !! numerical constant depending on the vertical 
+                                                                           !! thermal grid only @tex ($m^{-1}$) @endtex 
+    REAL(r_std), DIMENSION (ngrnd), INTENT(in)             :: dz2          !! thicknesses of the soil thermal layers
+                                                                           !! @tex ($m$) @endtex 
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT (in)   :: ptn          !! vertically discretized soil temperatures  
+                                                                           !! @tex ($K$) @endtex
+    
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION (kjpindex), INTENT (out)        :: soilcap      !! surface heat capacity
+                                                                           !! @tex ($J m^{-2} K^{-1}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex), INTENT (out)        :: soilflx      !! surface heat flux @tex ($W m^{-2}$) @endtex,
+                                                                           !! positive towards the 
+                                                                           !! soil, writen as Qg (ground heat flux) in the history 
+                                                                           !! files.
+    REAL(r_std), DIMENSION (kjpindex), INTENT (out)        :: z1           !! numerical constant @tex ($W m^{-1} K^{-1}$) @endtex
+
+    REAL(r_std), DIMENSION (kjpindex,ngrnd-1), INTENT(out) :: cgrnd        !! matrix coefficient for the computation of soil 
+                                                                           !! temperatures (beta in F. Hourdin thesis)
+    REAL(r_std), DIMENSION (kjpindex,ngrnd-1), INTENT(out) :: dgrnd        !! matrix coefficient for the computation of soil 
+                                                                           !! temperatures (alpha in F. Hourdin thesis)
+    REAL(r_std), DIMENSION (kjpindex,ngrnd-1), INTENT(out) :: zdz1         !! numerical (buffer) constant 
+                                                                           !! @tex ($W m^{-1} K^{-1}$) @endtex
+
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out)   :: zdz2         !! numerical (buffer) constant  
+                                                                           !! @tex ($W m^{-1} K^{-1}$) @endtex
+
+
+    !! 0.3 Modified variable
+
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(inout) :: pcapa        !! volumetric vertically discretized soil heat capacity
+                                                                           !! @tex ($J K^{-1} m^{-3}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(inout) :: pcapa_en     !! volumetric vertically discretized heat capacity used 
+                                                                           !! to calculate surfheat_incr
+                                                                           !! @tex ($J K^{-1} m^{-3}$) @endtex
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(inout) :: pkappa       !! vertically discretized soil thermal conductivity 
+                                                                           !! @tex ($W m^{-1} K^{-1}$) @endtex
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                         :: ji, jg
+    REAL(r_std), DIMENSION(kjpindex)                       :: snow_h       !! snow_h is the snow height @tex ($m$) @endtex 
+    REAL(r_std), DIMENSION(kjpindex)                       :: zx1, zx2     !! zx1 and zx2 are the layer fraction consisting in snow
+                                                                           !! and soil respectively.
+!_ ================================================================================================================================
+
+  !! 1. Computation of the soil thermal properties
+   
+    ! Computation of the soil thermal properties; snow properties are also accounted for
+    DO ji = 1,kjpindex
+      snow_h(ji) = snow(ji) / sn_dens
+
+      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
+
+    !! 2. computation of the coefficients of the numerical integration scheme
+
+    ! cgrnd, dgrnd
+
+    !! 2.1.  some "buffer" values
+    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
+    
+    !! 2.2.  the coefficients ! 
+    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
+
+  !! 3. Computation of the apparent ground heat flux 
+    
+    !! Computation of the apparent ground heat flux (> towards the soil) and
+    !! apparent surface heat capacity, used at the next timestep by enerbil to
+    !! compute the surface temperature.
+    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
+ 
+ 
+!! ================================================================================================================================
+!! SUBROUTINE   : thermosoil_profile
+!!
+!>\BRIEF        In this routine solves the numerical soil thermal scheme, ie calculates the new soil temperature profile; 
+!! This profile is then exported onto the diagnostic axis (call thermosoil_diaglev)
+!!
+!! DESCRIPTION	: The calculation of the new soil temperature profile is based on
+!! the cgrnd and dgrnd values from the previous timestep and the surface temperature Ts aka temp_sol_new. (see detailed
+!! explanation in the header of the thermosoil module or in the reference).\n
+!!                              T(k+1)=cgrnd(k)+dgrnd(k)*T(k)\n
+!!                                      -- EQ1 --\n
+!!                           Ts=(1-lambda)*T(1) -lambda*T(2)\n 
+!!                                      -- EQ2--\n
+!!
+!! RECENT CHANGE(S) : None
+!! 
+!! MAIN OUTPUT VARIABLE(S): ptn (soil temperature profile on the thermal axis), 
+!!                          stempdiag (soil temperature profile on the diagnostic axis)
+!!
+!! REFERENCE(S) :
+!! - Hourdin, F. (1992). Study and numerical simulation of the general circulation of planetary atmospheres,
+!! Ph.D. thesis, Paris VII University. Remark: the part of F. Hourdin's PhD thesis relative to the thermal
+!! integration scheme has been scanned and is provided along with the documentation, with name : 
+!! Hourdin_1992_PhD_thermal_scheme.pdf
+!!
+!! FLOWCHART    : None 
+!! \n 
+!_ ================================================================================================================================
+
+ SUBROUTINE thermosoil_profile (kjpindex, temp_sol_new, ptn, stempdiag)
+
+  !! 0. Variables and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                               :: kjpindex       !! Domain size (unitless)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_sol_new   !! Surface temperature at the present time-step 
+                                                                               !! @tex ($K$) @endtex
+    
+    !! 0.2 Output variables
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out)      :: stempdiag      !! diagnostic temperature profile 
+                                                                               !! @tex ($K$) @endtex
+
+    !! 0.3 Modified variables
+
+    REAL(r_std),DIMENSION (kjpindex,ngrnd), INTENT (inout)   :: ptn            !! vertically discretized soil temperatures 
+                                                                               !! @tex ($K$) @endtex
+
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                           :: ji, jg
+!_ ================================================================================================================================
+    
+  !! 1. Computes the soil temperatures ptn.
+
+    !! 1.1. ptn(jg=1) using EQ1 and EQ2
+    DO ji = 1,kjpindex
+      ptn(ji,1) = (lambda * cgrnd(ji,1) + temp_sol_new(ji)) / (lambda * (un - dgrnd(ji,1)) + un)
+    ENDDO
+
+    !! 1.2. ptn(jg=2:ngrnd) using EQ1.
+    DO jg = 1,ngrnd-1
+      DO ji = 1,kjpindex
+        ptn(ji,jg+1) = cgrnd(ji,jg) + dgrnd(ji,jg) * ptn(ji,jg)
+      ENDDO
+    ENDDO
+
+  !! 2. Put the soil temperatures onto the diagnostic axis 
+  
+    !! Put the soil temperatures onto the diagnostic axis for convenient
+    !! use in other routines (stomate..)
+    CALL thermosoil_diaglev(kjpindex, stempdiag)
+
+    IF (long_print) WRITE (numout,*) ' thermosoil_profile done '
+
+  END SUBROUTINE thermosoil_profile
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : thermosoil_diaglev
+!!
+!>\BRIEF        Interpolation of the soil in-depth temperatures onto the diagnostic profile.
+!!
+!! DESCRIPTION  : This is a very easy linear interpolation, with intfact(jd, jg) the fraction
+!! the thermal layer jg comprised within the diagnostic layer jd. The depths of
+!! the diagnostic levels are diaglev(1:nbdl), computed in slowproc.f90.
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): stempdiag (soil temperature profile on the diagnostic axis)
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None 
+!! \n 
+!_ ================================================================================================================================
+
+  SUBROUTINE thermosoil_diaglev(kjpindex, stempdiag)
+    
+  !! 0. Variables and parameter declaration
+
+    !! 0.1 Input variables
+ 
+    INTEGER(i_std), INTENT(in)                          :: kjpindex       !! Domain size (unitless)
+   
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out) :: stempdiag      !! Diagnostoc soil temperature profile @tex ($K$) @endtex
+    
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                      :: ji, jd, jg
+    REAL(r_std)                                         :: lev_diag, prev_diag, lev_prog, prev_prog
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:)      :: intfact
+!$OMP THREADPRIVATE(intfact)
+    LOGICAL, PARAMETER                                  :: check=.FALSE.
+!_ ================================================================================================================================
+    
+  !! 1. Computes intfact(jd, jg)
+
+    !! Computes intfact(jd, jg), the fraction
+    !! the thermal layer jg comprised within the diagnostic layer jd.
+    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
+                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
+
+ !! 2. does the interpolation
+
+    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
+  
+
+!! ================================================================================================================================
+!! SUBROUTINE   : thermosoil_humlev
+!!
+!>\BRIEF        Interpolates the diagnostic soil humidity profile shumdiag(nbdl, diagnostic axis) onto 
+!!              the thermal axis, which gives wetdiag(ngrnd, thermal axis).
+!!
+!! DESCRIPTION  : Same as in thermosoil_diaglev : This is a very easy linear interpolation, with intfactw(jd, jg) the fraction
+!! the thermal layer jd comprised within the diagnostic layer jg. 
+!!?? I would think wise to change the indeces here, to keep jD for Diagnostic
+!!?? and jG for Ground thermal levels...
+!! 
+!! The depths of the diagnostic levels are diaglev(1:nbdl), computed in slowproc.f90.
+!! Recall that when the 11-layer hydrology is used,
+!! wetdiag and shumdiag are with reference to the moisture content (mc)
+!! at the wilting point mcw : wetdiag=(mc-mcw)/(mcs-mcw).
+!! with mcs the saturated soil moisture content.
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): wetdiag (soil soil humidity profile on the thermal axis)
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None 
+!! \n 
+!_ ================================================================================================================================
+  SUBROUTINE thermosoil_humlev(kjpindex, shumdiag, snow)
+  
+  !! 0. Variables and parameter declaration
+
+    !! 0.1 Input variables
+ 
+    INTEGER(i_std), INTENT(in)                            :: kjpindex    !! Domain size (unitless)
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in)    :: shumdiag    !! Relative soil humidity on the diagnostic axis. 
+                                                                         !! (0-1, unitless). Caveats : when "hydrol" (the 11-layers
+                                                                         !! hydrology) is used, this humidity is calculated with 
+                                                                         !! respect to the wilting point : 
+                                                                         !! shumdiag= (mc-mcw)/(mcs-mcw), with mc : moisture 
+                                                                         !! content; mcs : saturated soil moisture content; mcw: 
+                                                                         !! soil moisture content at the wilting point. when the 2-layers
+                                                                         !! hydrology "hydrolc" is used, shumdiag is just
+                                                                         !! a diagnostic humidity index, with no real physical 
+                                                                         !! meaning.
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)         :: snow 
+    
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                       :: ji, jd, jg
+    REAL(r_std)                                          :: lev_diag, prev_diag, lev_prog, prev_prog
+    REAL(r_std), DIMENSION(ngrnd,nbdl)                   :: intfactw     !! fraction of each diagnostic layer (jd) comprized within
+                                                                         !! a given thermal layer (jg)(0-1, unitless) 
+    REAL(r_std), DIMENSION(kjpindex)               :: snow_h
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+!_ ================================================================================================================================
+    
+  !! 1. computes intfactw(jd,jg), the fraction of each diagnostic layer (jg) comprized within a given thermal layer (jd)
+    IF ( check ) &
+         WRITE(numout,*) 'thermosoil_humlev --' 
+
+    ! Snow height
+    snow_h(:)=snow(:)/sn_dens
+    !
+    wetdiag(:,:) = zero
+    DO ji=1,kjpindex
+       prev_diag = zero
+       DO jd = 1, ngrnd
+          lev_diag = prev_diag + dz2(jd)
+          prev_prog = snow_h(ji)
+          DO jg = 1, nbdl
+             IF ( jg == nbdl .AND. diaglev(jg)+snow_h(ji) < lev_diag ) THEN
+                lev_prog = lev_diag+snow_h(ji)
+             ELSE
+                lev_prog = diaglev(jg)+snow_h(ji)
+             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
+
+       DO jg = 1, nbdl
+          DO jd = 1, ngrnd
+             wetdiag(ji,jd) = wetdiag(ji,jd) + shumdiag(ji,jg)*intfactw(jd,jg)
+          ENDDO
+       ENDDO
+       !
+       IF ( check ) THEN
+          DO jd = 1, ngrnd
+             WRITE(numout,*) ji,jd, '-', intfactw(jd,1:nbdl),'-sum-', SUM(intfactw(jd,1:nbdl))
+          ENDDO
+       ENDIF
+    ENDDO
+    IF ( check ) &
+         WRITE(numout,*) 'thermosoil_humlev --' 
+
+  END SUBROUTINE thermosoil_humlev
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : thermosoil_energy
+!!
+!>\BRIEF         Energy check-up.
+!!
+!! DESCRIPTION  : I didn\'t comment this routine since at do not understand its use, please
+!! ask initial designers (Jan ? Nathalie ?).
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : ??
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None 
+!! \n 
+!_ ================================================================================================================================
+
+  SUBROUTINE thermosoil_energy(kjpindex, temp_sol_new, soilcap, first_call)
+  
+   !! 0. Variables and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                     :: kjpindex     !! Domain size (unitless)
+    LOGICAL, INTENT (in)                           :: first_call   !! First call (true/false)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)  :: temp_sol_new !! Surface temperature at the present time-step, Ts 
+                                                                   !! @tex ($K$) @endtex
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)  :: soilcap      !! Apparent surface heat capacity 
+                                                                   !! @tex ($J m^{-2} K^{-1}$) @endtex, 
+                                                                   !! see eq. A29 of F. Hourdin\'s PhD thesis.
+    
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+    
+    !! 0.4 Local variables
+    
+    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: branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/watchout.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/watchout.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_sechiba/watchout.f90	(revision 7236)
@@ -0,0 +1,2426 @@
+! =================================================================================================================================
+! MODULE       : watchout
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         
+!!
+!!\n DESCRIPTION:  
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	:
+!!
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/trunk/ORCHIDEE/src_driver/readdim2.f90 $
+!! $Date: 2012-11-16 14:53:18 +0100 (ven. 16 nov. 2012) $
+!! $Revision: 1060 $
+
+!! \n
+!_ ================================================================================================================================
+
+MODULE watchout
+
+  USE defprec
+  USE mod_orchidee_para 
+  USE constantes
+  USE netcdf
+
+  PRIVATE
+  PUBLIC :: watchout_init, watchout_write_p, watchout_close
+!watchout_write ??
+
+  LOGICAL,SAVE,PUBLIC             :: ok_watchout = .FALSE.
+!$OMP THREADPRIVATE(ok_watchout)
+  REAL, SAVE,PUBLIC               :: dt_watch = zero
+!$OMP THREADPRIVATE(dt_watch)
+  INTEGER, SAVE,PUBLIC            :: last_action_watch = 0, &
+       & last_check_watch = 0
+!$OMP THREADPRIVATE(last_action_watch, last_check_watch)
+  CHARACTER(LEN=80),SAVE, PUBLIC   :: watchout_file
+!$OMP THREADPRIVATE(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
+!$OMP THREADPRIVATE(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
+!$OMP THREADPRIVATE(watchfid, zlevid, soldownid, rainfid)
+!$OMP THREADPRIVATE(snowfid, lwradid, psolid, tairid) 
+!$OMP THREADPRIVATE( eairid, qairid, uid, vid) 
+!$OMP THREADPRIVATE(solnetid, petAcoefid, peqAcoefid, petBcoefid) 
+!$OMP THREADPRIVATE(peqBcoefid, cdragid, ccanopyid) 
+  INTEGER(i_std),SAVE      :: watchoffset
+!$OMP THREADPRIVATE(watchoffset) 
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_zlev
+!$OMP THREADPRIVATE(sum_zlev) 
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_u, sum_v
+!$OMP THREADPRIVATE(sum_u, sum_v)
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_qair
+!$OMP THREADPRIVATE(sum_qair) 
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_temp_air
+!$OMP THREADPRIVATE(sum_temp_air) 
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_epot_air
+!$OMP THREADPRIVATE(sum_epot_air) 
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_ccanopy
+!$OMP THREADPRIVATE(sum_ccanopy) 
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_cdrag
+!$OMP THREADPRIVATE(sum_cdrag) 
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_petAcoef, sum_peqAcoef, sum_petBcoef, sum_peqBcoef
+!$OMP THREADPRIVATE(sum_petAcoef, sum_peqAcoef) 
+!$OMP THREADPRIVATE(sum_petBcoef, sum_peqBcoef)
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_rain, sum_snow
+!$OMP THREADPRIVATE(sum_rain, sum_snow)
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_lwdown
+!$OMP THREADPRIVATE(sum_lwdown)
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_swnet
+!$OMP THREADPRIVATE(sum_swnet)
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_swdown
+!$OMP THREADPRIVATE(sum_swdown)
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_pb
+!$OMP THREADPRIVATE(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), SAVE, PUBLIC :: dt_split_watch
+!$OMP THREADPRIVATE(dt_split_watch) 
+  !! mean julian time for each time step
+  REAL(r_std), SAVE, PUBLIC :: julian_watch
+!$OMP THREADPRIVATE(julian_watch)
+CONTAINS 
+
+!! ================================================================================================================================
+!! SUBROUTINE   : watchout_init
+!!
+!>\BRIEF         
+!!
+!! DESCRIPTION  : 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.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!! - 
+!!
+!! FLOWCHART    : 
+!_ ================================================================================================================================
+  
+  SUBROUTINE watchout_init(iim, jjm, kjpindex, igmax, date0, itau, dt, kindex, lon, lat, lev0)
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                   :: iim, jjm, igmax, kjpindex
+    REAL(r_std), INTENT(in)                      :: date0, dt
+    INTEGER(i_std), INTENT(in)                   :: itau
+    INTEGER(i_std), DIMENSION(igmax), INTENT(in) :: kindex 
+    REAL(r_std), DIMENSION(iim,jjm), INTENT(in)  :: lon, lat
+    REAL(r_std), INTENT(in)                      :: lev0
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                               :: iret, nlonid1, nlatid1, nlevid1, fid, nlandid1, tdimid1
+    INTEGER(i_std), DIMENSION(3)                 :: dims
+    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, DIMENSION(:,:)     :: tmpdata
+    CHARACTER(LEN=3), DIMENSION(12)              :: cal
+    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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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
+!!
+!>\BRIEF         
+!!
+!! DESCRIPTION  :
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!! - 
+!!
+!! FLOWCHART    : 
+!_ ================================================================================================================================
+
+  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
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                   :: igmax
+    INTEGER(i_std), INTENT(in)                   :: itau
+    REAL(r_std), INTENT(in)                      :: dt
+
+    !! 0.3 Modified variables
+    
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: levels
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: soldown
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: rain
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: snow
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: lwdown
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: psurf
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: solnet
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: petAcoef
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: peqAcoef
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: petBcoef
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: peqBcoef
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: cdrag
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: ccanopy
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: temp
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: eair
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: qair
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: u, v
+
+    !! 0.4 Local variables
+
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: levels_g
+!$OMP THREADPRIVATE(levels_g)
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: soldown_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: rain_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: snow_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lwdown_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: psurf_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: solnet_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: petAcoef_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: peqAcoef_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: petBcoef_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: peqBcoef_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: cdrag_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: temp_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: eair_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: qair_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: u_g, v_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: ccanopy_g
+!$OMP THREADPRIVATE(soldown_g, rain_g, snow_g, lwdown_g)
+!$OMP THREADPRIVATE(psurf_g,solnet_g, petAcoef_g, peqAcoef_g)
+!$OMP THREADPRIVATE( petBcoef_g, peqBcoef_g, cdrag_g,temp_g)
+!$OMP THREADPRIVATE(eair_g, qair_g, u_g, v_g, ccanopy_g)
+    !
+    LOGICAL, SAVE                                :: is_first_time=.TRUE.
+!$OMP THREADPRIVATE(is_first_time)
+    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
+!!
+!>\BRIEF          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 !
+!!
+!! DESCRIPTION  :
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!! - 
+!!
+!! FLOWCHART    : 
+!_ ================================================================================================================================
+
+  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
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                :: igmax
+    INTEGER(i_std), INTENT(in)                :: itau
+    REAL(r_std), INTENT(in)                   :: dt
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: levels
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: soldown
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: rain
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: snow
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: lwdown
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: psurf
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: solnet
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: petAcoef
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: peqAcoef
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: petBcoef
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: peqBcoef
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: cdrag
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: ccanopy
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: temp 
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: eair
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: qair
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: u, v 
+
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                            :: iret
+    INTEGER(i_std), DIMENSION(3)              :: corner, edges
+    REAL(r_std)                               :: timestp
+    LOGICAL                                   :: check = .FALSE.
+    REAL(r_std), ALLOCATABLE, DIMENSION(:)    :: 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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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_p (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
+!!
+!>\BRIEF         Close the watch files  
+!!
+!! DESCRIPTION  :
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!! - 
+!!
+!! FLOWCHART    : 
+!_ ================================================================================================================================
+
+  SUBROUTINE watchout_close()
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.4 Local  variables
+
+    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_p (3,'watchout_close','Could not close the file : ', &
+            &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+    !
+  END SUBROUTINE watchout_close
+
+END MODULE watchout
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/AA_make
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/AA_make	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/AA_make	(revision 7236)
@@ -0,0 +1,269 @@
+#-
+#- $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_data.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_mark_kill.f90         \
+        sapiens_kill.f90              \
+	stomate_growth_res_lim.f90    \
+	stomate_growth_fun_all.f90    \
+        sapiens_forestry.f90          \
+        sapiens_agriculture.f90       \
+        stomate_stand_structure.f90   \
+        stomate_io.f90                \
+        stomate_litter.f90            \
+        stomate_phenology.f90         \
+	stomate_prescribe.f90         \
+        stomate_season.f90            \
+        stomate_soilcarbon.f90        \
+        stomate_turnover.f90          \
+        stomate_vmax.f90              \
+        stomate_assimtemp.f90         \
+        sapiens_lcchange.f90          \
+        stomate_kill.f90              \
+        sapiens_product_use.f90	      \
+        stomate_lpj.f90               \
+        stomate_resp.f90              \
+        stomate_laieff.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
+	$(A_C) $(ORCHIDEE_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)(pft_parameters.o)  \
+  $(PARAM_LIB)(structures.o)      \
+  $(MODEL_LIB)(stomate_io.o)      \
+  $(MODEL_LIB)(stomate_lpj.o)
+
+$(MODEL_LIB)(stomate_data.o): \
+  $(PARAM_LIB)(pft_parameters.o)	\
+  $(PARAM_LIB)(constantes.o)  
+
+$(MODEL_LIB)(lpj_constraints.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(lpj_cover.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(lpj_crown.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(lpj_establish.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(lpj_fire.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(lpj_gap.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(lpj_kill.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(lpj_light.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(lpj_pftinout.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(stomate_mark_kill.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(sapiens_kill.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(stomate_kill.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(stomate_growth_res_lim.o): \
+  $(PARAM_LIB)(pft_parameters.o)	\
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(stomate_growth_fun_all.o): \
+  $(PARAM_LIB)(pft_parameters.o)	\
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(stomate_io.o): \
+  $(MODEL_LIB)(stomate_data.o) \
+  $(PARALLEL_LIB)(mod_orchidee_para.o)
+
+$(MODEL_LIB)(stomate_litter.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(stomate_phenology.o): \
+  $(MODEL_LIB)(stomate_data.o) \
+  $(MODEL_LIB)(sapiens_agriculture.o)
+
+$(MODEL_LIB)(stomate_prescribe.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(stomate_resp.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(stomate_laieff.o):  \
+  $(PARAM_LIB)(pft_parameters.o) \
+  $(PARAM_LIB)(structures.o)  \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(stomate_season.o):  \
+  $(PARAM_LIB)(pft_parameters.o) \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(stomate_soilcarbon.o): \
+  $(MODEL_LIB)(stomate_data.o)      \
+  $(ORGLOB_LIB)(grid.o)             \
+  $(ORGLOB_LIB)(solar.o)
+
+$(MODEL_LIB)(stomate_turnover.o): \
+  $(MODEL_LIB)(stomate_data.o) \
+  $(MODEL_LIB)(sapiens_agriculture.o)
+
+$(MODEL_LIB)(stomate_vmax.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(stomate_assimtemp.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(sapiens_lcchange.o):  \
+  $(MODEL_LIB)(stomate_data.o)     \
+  $(MODEL_LIB)(stomate_prescribe.o)         
+
+$(MODEL_LIB)(sapiens_agriculture.o): \
+  $(MODEL_LIB)(stomate_data.o)       \
+  $(PARAM_LIB)(pft_parameters.o)     \
+  $(PARAM_LIB)(constantes.o)
+
+$(MODEL_LIB)(sapiens_product_use.o): \
+  $(PARAM_LIB)(pft_parameters.o)     \
+  $(MODEL_LIB)(stomate_data.o)       \
+  $(PARAM_LIB)(constantes.o)   
+
+$(MODEL_LIB)(sapiens_forestry.o): \
+  $(MODEL_LIB)(stomate_data.o)    \
+  $(PARAM_LIB)(pft_parameters.o)  \
+  $(PARAM_LIB)(constantes.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_stand_structure.o)   \
+  $(MODEL_LIB)(stomate_mark_kill.o)         \
+  $(MODEL_LIB)(stomate_kill.o)              \
+  $(MODEL_LIB)(sapiens_kill.o)              \
+  $(MODEL_LIB)(sapiens_forestry.o)          \
+  $(MODEL_LIB)(stomate_growth_res_lim.o)    \
+  $(MODEL_LIB)(stomate_growth_fun_all.o)    \
+  $(MODEL_LIB)(sapiens_lcchange.o)          \
+  $(MODEL_LIB)(stomate_data.o)              \
+  $(MODEL_LIB)(stomate_litter.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_laieff.o)            \
+  $(MODEL_LIB)(sapiens_agriculture.o)       \
+  $(MODEL_LIB)(sapiens_product_use.o)       \
+  $(PARAM_LIB)(structures.o)                \
+  $(PARAM_LIB)(function_library.o)
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/AA_make.ldef
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/AA_make.ldef	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/AA_make.ldef	(revision 7236)
@@ -0,0 +1,19 @@
+#-
+#- $Id$
+#-
+#---------------------------------------------------------------------
+#- Creation des elements relatifs a STOMATE
+#---------------------------------------------------------------------
+SHELL = /bin/sh
+#---------------------------------------------------------------------
+LIBDIR = ../../../lib
+BINDIR = ../../../bin
+MODDIR = $(LIBDIR)
+#---------------------------------------------------------------------
+ORCHIDEE_LIB = $(LIBDIR)/liborchidee.a
+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: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_constraints.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_constraints.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_constraints.f90	(revision 7236)
@@ -0,0 +1,250 @@
+! =================================================================================================================================
+! MODULE       : lpj_constraints
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+!              This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Groups the subroutines that: (1) initialize all variables in 
+!! lpj_constraints and (2) check the temperature threshold to decide for each PFT 
+!! if it can adapt to and regenerate under prevailing climate conditions**1
+!! 
+!!\n RECENT CHANGE(S) : None
+!!
+!! REFERENCE(S) :
+!! - Sitch, S., B. Smith, et al. (2003), Evaluation of ecosystem dynamics,
+!!   plant geography and terrestrial carbon cycling in the LPJ dynamic 
+!!   global vegetation model, Global Change Biology, 9, 161-185.\n
+!! - Smith, B., I. C. Prentice, et al. (2001), Representation of vegetation
+!!   dynamics in the modelling of terrestrial ecosystems: comparing two
+!!   contrasting approaches within European climate space,
+!!   Global Ecology and Biogeography, 10, 621-637.\n
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE lpj_constraints
+
+  ! modules used:
+  USE xios_orchidee
+  USE ioipsl_para
+  USE stomate_data
+  USE constantes
+  USE pft_parameters
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC constraints,constraints_clear
+
+  LOGICAL, SAVE                           :: firstcall = .TRUE.      !! first call
+!$OMP THREADPRIVATE(firstcall)
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE   : constraints_clear
+!!
+!>\BRIEF        Set the flag ::firstcall to .TRUE. and as such activate section 
+!!              1.1 of the subroutine constraints (see subroutine constraints).
+!!
+!_ ================================================================================================================================
+
+  SUBROUTINE constraints_clear
+    firstcall = .TRUE. 
+  END SUBROUTINE constraints_clear
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : constraints
+!!
+!>\BRIEF        Determine whether each PFT can adapt to and regenerate under the prevailing climate
+!! conditions. Climate conditions are characterised by different threshold values for air temperature.
+!!
+!! DESCRIPTION : PFTs are adapted to the climate conditions if the daily air temperature does not drop below 
+!! the treshold values ::tcm_crit. Some PFT's do not have a ::tcm_crit treshold. Seasonal trees die if leafage 
+!! does not show a clear seasonality. (i.e. if the start of the growing season is never detected)
+!! 
+!! If the monthly temperature is below ::tcm_crit i.e. the critical temperature of the coldest month, the 
+!! PFT will be able to regenerate. If minimum temperatures do not drop below ::tcm_crit, its regenerative 
+!! capacity decreases with time. Hence, plants that need vernalization die after a few years if they don't
+!! vernalize (even if they would not loose their leaves).
+!!
+!! The treshold values ::t_min_crit, the critical temperature of the coldest month is defined in 
+!! stomate_constants.f90'. However, ::regenerate_min, the critical temperature to support regeneration is 
+!! calculated in this routine from parameters of which none depenent on the PFT. The value for 
+!! ::large_value is defined as 1.E33 in stomata_constraints
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : ::adapted (0-1, unitless) and ::regenerate (0-1, unitless)
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART : 
+!! \latexonly 
+!!     \includegraphics[scale=0.3]{lpj_constraints_flowchart.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+  
+    SUBROUTINE constraints (npts, dt, &
+       t2m_month, t2m_min_daily, when_growthinit, &
+       adapted, regenerate)
+    
+    !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variable
+
+    INTEGER(i_std), INTENT(in)                      :: npts            !! Domain size (unitless)
+    REAL(r_std), INTENT(in)                         :: dt              !! Time step   (days)
+    REAL(r_std), DIMENSION(npts), INTENT(in)        :: t2m_month       !! "Monthly" 2-meter temperature by defualt 
+                                                                       !! monthly spans 20 days a (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)        :: t2m_min_daily   !! Daily minimum 2-meter temperature (K)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)    :: when_growthinit !! Days since beginning of growing season (days)
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+  
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout) :: adapted         !! Winter too cold? (0 to 1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout) :: regenerate      !! Winter sufficiently cold? (0 to 1, unitless)
+
+    !! 0.4 Local variables
+
+    REAL(r_std)                                     :: tau_adapt       !! Memory length for adaption (days)
+    REAL(r_std)                                     :: tau_regenerate  !! Memory length for regeneration (days)
+    REAL(r_std)                                     :: regenerate_min  !! Critical value of "regenerate" below which plant 
+                                                                       !! dies (unitless)
+    INTEGER(i_std)                                  :: j               !! Index
+!_ ================================================================================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering constraints' ! diagnostic level in implimentation
+
+  !! 1. Initializations
+
+    tau_adapt = one_year
+    tau_regenerate = one_year
+
+    !! 1.1 Print parameter settings
+    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 Calculate critical value for "regenerate"
+    !      Critical value for "regenerate", below this value, the last vernalization
+    !      happened too far in the past, The PFT is can not regenerate under the 
+    !      prevailing climate conditions.
+    regenerate_min = exp ( - too_long * one_year / tau_regenerate )
+
+  !! 2. Calculate ::adapted and ::regenerate
+
+    DO j = 2,nvm ! Loop over # PFTs
+
+       !! 2.1 PFT mask for natural or agriculture vegetations
+       IF ( natural(j) .OR. agriculture ) THEN
+
+          !! 2.1.1 Climate criteria
+ 
+          !! 2.1.1.1 There is no critical temperature for the PFT 
+          !          Frost restistant PFT do not have a critical temperature for growth
+          IF ( tmin_crit(j) .EQ. undef ) THEN
+             
+             adapted(:,j) = un 
+
+          !! 2.1.1.2 Frost occured in frost sensitive PFTs
+          !          For example, tropical plants will die if frost, below the treshold, occured
+          ELSE
+
+             WHERE ( t2m_min_daily(:) .LT. tmin_crit(j) )
+                adapted(:,j) = zero
+             ENDWHERE
+
+             ! The PFT does not disappear after a single cold shock. The PFT has a memory
+             ! and if the cold shock do not happen too often, it will get forgotten.
+             ! No reference found for this approach
+             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.
+          !        Seasonal trees die if leafage does not show a clear seasonality
+          !        (i.e. if the start of the growing season is never detected).
+          IF ( is_tree(j) .AND. ( pheno_model(j) .NE. 'none' ) ) THEN
+
+             WHERE ( when_growthinit(:,j) .GT. too_long*one_year .AND. when_growthinit(:,j).LT. large_value)
+                adapted(:,j) = zero
+             ENDWHERE
+
+          ENDIF
+
+          !! 2.1.3 Test if PFT is regenerative
+
+          !! 2.1.3.1 Check PFT vernalization. 
+          !          If sufficiently cold, PFT will be able to regenerate for some time.
+          !          Several PFTs (ex: evergreen) don't need vernalization 
+          IF ( tcm_crit(j) .EQ. undef ) THEN
+
+             regenerate(:,j) = un
+
+          !! 2.1.3.2 PFT needs vernalization
+          ELSE
+
+             WHERE ( t2m_month(:) .LE. tcm_crit(j) )
+                regenerate(:,j) = un
+             ENDWHERE
+
+             ! Limited memory: after some time, the winter is forgotten and the PFT can no longer
+             ! produce seeds, hence, with time ::regenerate approaches 0
+             regenerate(:,j) = regenerate(:,j) * (tau_regenerate-dt)/tau_regenerate
+
+          ENDIF
+
+          !! 2.1.4 Plants that need vernalization die
+          !        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
+
+       !! 2.1 PFT except natual and agriculture vegetation
+       !      Should be developed if needed 
+       ELSE
+
+          adapted(:,j) = zero
+
+          regenerate(:,j) = zero
+
+       ENDIF ! PFT of natural or agriculture
+
+    ENDDO ! Loop over # PFTs
+
+  !! 3. Write history files
+    CALL xios_orchidee_send_field("ADAPTATION",adapted)
+    CALL xios_orchidee_send_field("REGENERATION",regenerate)
+
+    CALL histwrite_p (hist_id_stomate, 'ADAPTATION', itime, &
+         adapted, npts*nvm, horipft_index)
+    CALL histwrite_p (hist_id_stomate, 'REGENERATION', itime, &
+         regenerate, npts*nvm, horipft_index)
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving constraints'
+
+  END SUBROUTINE constraints
+
+END MODULE lpj_constraints
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_cover.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_cover.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_cover.f90	(revision 7236)
@@ -0,0 +1,255 @@
+! =================================================================================================================================
+! MODULE       : lpj_cover
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+!                This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        Recalculate vegetation cover and LAI
+!!
+!!\n DESCRIPTION : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! REFERENCE(S) : 
+!!        Sitch, S., B. Smith, et al. (2003), Evaluation of ecosystem dynamics,
+!!        plant geography and terrestrial carbon cycling in the LPJ dynamic 
+!!        global vegetation model, Global Change Biology, 9, 161-185.\n
+!!        Smith, B., I. C. Prentice, et al. (2001), Representation of vegetation
+!!        dynamics in the modelling of terrestrial ecosystems: comparing two
+!!        contrasting approaches within European climate space,
+!!        Global Ecology and Biogeography, 10, 621-637.\n
+!!
+!! SVN :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE lpj_cover
+
+  ! modules used:
+
+  USE ioipsl_para
+  USE stomate_data
+  USE pft_parameters
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC cover
+
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE     : lpj_cover
+!!
+!>\BRIEF          Recalculate vegetation cover and LAI
+!!
+!!\n DESCRIPTION : Veget_max is first renewed here according to newly calculated foliage biomass in this calculation step 
+!! Then, litter, soil carbon, and biomass are also recalcuted with taking into account the changes in Veget_max (i.e. delta_veg)
+!! Grid-scale fpc (foliage projected coverage) is calculated to obtain the shadede ground area by leaf's light capture
+!! Finally, grid-scale fpc is adjusted not to exceed 1.0
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : ::lai (leaf area index, @tex $(m^2 m^{-2})$ @endtex), 
+!! :: veget (fractional vegetation cover, unitless)
+!!
+!! REFERENCE(S)   : None
+!! 
+!! FLOWCHART :
+!! \latexonly 
+!!     \includegraphics[scale=0.5]{lpj_cover_flowchart.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE cover (npts, cn_ind, ind, biomass, &
+       veget_max, veget_max_old, lai, litter, carbon, turnover_daily, bm_to_litter, &
+       lignin_struc, lignin_wood)
+
+!! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                                  :: npts             !! Domain size (unitless)  
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                :: cn_ind           !! Crown area 
+                                                                                    !! @tex $(m^2)$ @endtex per individual
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                :: ind              !! Number of individuals 
+                                                                                    !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                :: veget_max_old    !! "Maximal" coverage fraction of a PFT (LAI-> 
+                                                                                    !! infinity) on ground at beginning of time 
+
+    !! 0.2 Output variables
+
+
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)             :: lai                 !! Leaf area index OF AN INDIVIDUAL PLANT 
+                                                                                       !! @tex $(m^2 m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements), INTENT(inout) :: litter    !! Metabolic and structural litter, above and 
+                                                                                       !! below ground @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,ncarb,nvm), INTENT(inout)             :: carbon        !! Carbon pool: active, slow, or passive 
+                                                                                       !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(inout) :: biomass        !! Biomass @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                  :: veget_max      !! "Maximal" coverage fraction of a PFT (LAI->
+                                                                                       !! infinity) on ground (unitless)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(inout) :: turnover_daily !! Turnover rates (gC m^{-2} day^{-1})
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(inout) :: bm_to_litter   !! Conversion of biomass to litter 
+                                                                                       !! @tex $(gC m^{-2} day^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(inout)            :: lignin_struc   !! ratio Lignine/Carbon in structural litter,
+                                                                                       !! above and below ground
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(inout)            :: lignin_wood    !! ratio Lignine/Carbon in woody litter,
+                                                                                       !! above and below ground
+  
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                              :: i,j,k,m          !! Index (unitless)
+    REAL(r_std), DIMENSION(npts,nlitt,nlevs,nelements)          :: dilu_lit         !! Litter dilution @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,ncarb)                          :: dilu_soil_carbon !! Soil Carbondilution 
+                                                                                    !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nlevs)                          :: dilu_lf_struc    !! fraction of structural litter that is lignin
+                                                                                    !! (0-1,unitless)
+    REAL(r_std), DIMENSION(npts,nlevs)                          :: dilu_lf_wood     !! fraction of woody litter that is lignin
+                                                                                    !! (0-1,unitless)
+    REAL(r_std), DIMENSION(nvm)                                 :: delta_veg        !! Conversion factors (unitless)
+    REAL(r_std), DIMENSION(nvm)                                 :: reduct           !! Conversion factors (unitless)
+    REAL(r_std)                                                 :: delta_veg_sum    !! Conversion factors (unitless)
+    REAL(r_std)                                                 :: diff             !! Conversion factors (unitless)
+    REAL(r_std)                                                 :: sr               !! Conversion factors (unitless)
+    REAL(r_std), DIMENSION(npts)                                :: frac_nat         !! Conversion factors (unitless)
+    REAL(r_std), DIMENSION(npts)                                :: sum_vegettree    !! Conversion factors (unitless)
+    REAL(r_std), DIMENSION(npts)                                :: sum_vegetgrass   !! Conversion factors (unitless) 
+    REAL(r_std), DIMENSION(npts)                                :: sum_veget_natveg !! Conversion factors (unitless)
+
+!_ ================================================================================================================================
+
+ !! 1. If the vegetation is dynamic, calculate new maximum vegetation cover for natural plants
+
+       !! 1.1  Calculate initial values of vegetation cover
+       frac_nat(:) = un
+       sum_veget_natveg(:) = zero
+       veget_max(:,ibare_sechiba) = un
+
+       DO j = 2,nvm ! loop over PFTs
+
+          IF ( natural(j) ) THEN
+	     
+             ! Summation of individual tree crown area to get total foliar projected coverage
+             veget_max(:,j) = ind(:,j) * cn_ind(:,j)
+             sum_veget_natveg(:) = sum_veget_natveg(:) + veget_max(:,j)
+
+          ELSE
+             
+             !fraction occupied by agriculture needs to be substracted for the DGVM
+             !this is used below to constrain veget for natural vegetation, see below
+             frac_nat(:) = frac_nat(:) - veget_max(:,j)
+
+          ENDIF
+
+       ENDDO ! loop over PFTs
+
+       DO i = 1, npts ! loop over grid points
+	  
+          ! Recalculation of vegetation projected coverage when ::frac_nat was below ::sum_veget_natveg
+          ! It means that non-natural vegetation will recover ::veget_max as natural vegetation
+          IF (sum_veget_natveg(i) .GT. frac_nat(i) .AND. frac_nat(i) .GT. min_stomate) THEN
+
+             DO j = 2,nvm ! loop over PFTs
+                IF( natural(j) ) THEN
+                   veget_max(i,j) =  veget_max(i,j) * frac_nat(i) / sum_veget_natveg(i)
+                ENDIF
+             ENDDO ! loop over PFTs
+
+          ENDIF
+       ENDDO ! loop over grid points
+	
+       ! Renew veget_max of bare soil as 0 to difference of veget_max (ibare_sechiba) 
+       ! to current veget_max
+       DO j = 2,nvm ! loop over PFTs
+          veget_max(:,ibare_sechiba) = veget_max(:,ibare_sechiba) - veget_max(:,j)
+       ENDDO ! loop over PFTs
+       veget_max(:,ibare_sechiba) = MAX( veget_max(:,ibare_sechiba), zero )
+
+       !! 1.2 Calculate carbon fluxes between PFTs to maintain mass balance
+       !      Recalculate the litter and soil carbon with taking into accout the change in 
+       !      veget_max (delta_veg)
+       DO i = 1, npts ! loop over grid points
+          
+          ! calculate the change in veget_max between previous time step and current time step
+          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
+          dilu_lf_struc(i,:) = zero
+          dilu_lf_wood(i,:) = zero
+
+          DO j=1, nvm ! loop over PFTs
+             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
+                dilu_lf_struc(i,:) = dilu_lf_struc(i,:) + & 
+                     delta_veg(j) * lignin_struc(i,j,:) * litter(i,istructural,j,:,icarbon)/ delta_veg_sum
+                dilu_lf_wood(i,:) = dilu_lf_wood(i,:) + &
+                     delta_veg(j) * lignin_wood(i,j,:)*litter(i,iwoody,j,:,icarbon)  / delta_veg_sum
+             ENDIF
+          ENDDO ! loop over PFTs
+
+          DO j = 1,nvm ! loop over PFTs
+             IF ( delta_veg(j) > min_stomate) THEN
+
+                ! Dilution of reservoirs
+                ! Recalculate the litter and soil carbon with taking into accout the change in 
+                ! veget_max (delta_veg)
+
+                ! Lignin fraction of structural litter
+                lignin_struc(i,j,:)=(lignin_struc(i,j,:) * veget_max_old(i,j)* litter(i,istructural,j,:,icarbon) + & 
+                     dilu_lf_struc(i,:) * delta_veg(j)) / veget_max(i,j) 
+
+                ! Lignin fraction of woody litter
+                lignin_wood(i,j,:)=(lignin_wood(i,j,:) * veget_max_old(i,j)* litter(i,iwoody,j,:,icarbon) + & 
+                     dilu_lf_wood(i,:) * delta_veg(j)) / veget_max(i,j)
+
+                 ! Litter
+                litter(i,:,j,:,:)=(litter(i,:,j,:,:) * veget_max_old(i,j) + dilu_lit(i,:,:,:) * delta_veg(j)) / veget_max(i,j)
+
+                WHERE ( litter(i,istructural,j,:,icarbon) > min_stomate )
+                   lignin_struc(i,j,:) = lignin_struc(i,j,:)/litter(i,istructural,j,:,icarbon)
+                ELSEWHERE
+                   lignin_struc(i,j,:) = LC(ileaf)
+                ENDWHERE
+
+                WHERE ( litter(i,iwoody,j,:,icarbon) > min_stomate )
+                   lignin_struc(i,j,:) = lignin_struc(i,j,:)/litter(i,iwoody,j,:,icarbon)
+                ELSEWHERE
+                   lignin_struc(i,j,:) = LC(iheartabove)
+                ENDWHERE
+
+
+               ! 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
+
+             IF((j.GE.2).AND.(veget_max_old(i,j).GT.min_stomate).AND.(veget_max(i,j).GT.min_stomate)) THEN
+
+                ! Correct biomass densities (i.e. also litter fall) to conserve mass 
+                ! since it's defined on veget_max
+                biomass(i,j,:,:) = biomass(i,j,:,:) * veget_max_old(i,j) / veget_max(i,j)
+                turnover_daily(i,j,:,:) = turnover_daily(i,j,:,:) * veget_max_old(i,j) / veget_max(i,j)
+                bm_to_litter(i,j,:,:) = bm_to_litter(i,j,:,:) * veget_max_old(i,j) / veget_max(i,j)
+
+             ENDIF
+
+          ENDDO ! loop over PFTs
+       ENDDO ! loop over grid points
+
+  END SUBROUTINE cover
+
+END MODULE lpj_cover
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_crown.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_crown.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_crown.f90	(revision 7236)
@@ -0,0 +1,220 @@
+! =================================================================================================================================
+! MODULE       : lpj_crown
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+!                This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Calculate individual crown area from stem mass
+!!
+!! \n DESCRIPTION : Calculating crown area of individual tree by diameter and tree height
+!!
+!! REFERENCE(S) :
+!! - Smith, B., I. C. Prentice, et al. (2001), Representation of vegetation
+!!  dynamics in the modelling of terrestrial ecosystems: comparing two
+!!  contrasting approaches within European climate space,
+!!  Global Ecology and Biogeography, 10, 621-637.
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE lpj_crown
+
+  USE ioipsl_para
+  USE stomate_data
+  USE constantes
+  USE pft_parameters
+  
+  IMPLICIT NONE
+  
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC crown_diagnostic
+  
+CONTAINS
+  
+  
+!! ================================================================================================================================
+!! SUBROUTINE    : crown_diagnostic
+!!
+!>\BRIEF         Calculate individual crown area from stem mass
+!!
+!! DESCRIPTION   : Calculating crown area of individual tree by diameter and tree height
+!! which are also calculated internally within this program from stem mass and allometory.
+!! Calculations for diameter, height and crown area originate from eqns 1, 2, and 3 in 
+!! Appendix B, Smith et al. (2001) following Huang et al. 1992 and Zeide 1993.
+!! \latexonly
+!!  \input{lpj_crown1.tex}
+!!  \input{lpj_crown2.tex}
+!!  \input{lpj_crown3.tex}
+!! \endlatexonly
+!! \n
+!! where \f$k_{allom1}(=100.)\f$, \f$k_{allom2}(=40.)\f$, \f$k_{allom3}(=0.85)\f$ and \f$k_{rp}(=1.6)\f$ are 
+!! constants, \f$WD\f$ is wood density (\f$=2 \times 10^5\f$ gC m\f$^3\f$) and \f$CA_{max}\f$ is maximum 
+!! crown area (\f$=27.3\f$ m\f$^2\f$).
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : ::cn_ind (crown area per individual, @tex $m^2 $ @endtex) and ::height (m)
+!!
+!! REFERENCE(S)   :
+!! - Huang, S., Titus, S.J. and Wiens, D.P. (1992) Comparison of nonlinear heightâdiameter functions for major 
+!! Alberta tree species. Canadian Journal of Forest Research, 22, 1297â1304.\n
+!! - Zeide, B. (1993) Primary unit of the tree crown. Ecology, 74, 1598â1602.\n
+!! - Smith, B., I. C. Prentice, et al. (2001), Representation of vegetation dynamics in the modelling of 
+!! terrestrial ecosystems: comparing two contrasting approaches within European climate space,
+!! Global Ecology and Biogeography, 10, 621-637.\n
+!! 
+!! FLOWCHART : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE crown_diagnostic (npts, PFTpresent, ind, biomass, &
+       woodmass_ind, veget_max, cn_ind, height, &
+       forest_managed)
+
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std),INTENT(in)                         :: npts              !! Domain size (unitless) 
+    LOGICAL,DIMENSION(npts,nvm),INTENT(in)            :: PFTpresent        !! Is pft there (unitless)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)        :: ind               !! [DISPENSABLE] Density of individuals 
+                                                                           !! @tex $(m^{-2})$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,nparts,nelements),INTENT(in) :: biomass !! [DISPENSABLE] Biomass @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)        :: woodmass_ind      !! Woodmass of the individual, needed to calculate 
+                                                                           !! crownarea in lpj_crown (gC)
+    INTEGER(i_std), DIMENSION (npts,nvm), INTENT(in)  :: forest_managed    !! forest management flag
+
+    !! 0.2 Output variables
+  
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out)       :: cn_ind            !! Crown area per individual @tex $(m^{2})$ @endtex    
+
+    !! 0.3 Modified variables
+
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(inout)     :: veget_max        !! [DISPENSABLE] "Maximal" coverage fraction of a PFT 
+                                                                          !! infinity) on ground (unitless)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(inout)     :: height           !! Height of vegetation (m)           
+
+    !! 0.4 Local variables
+	
+!   REAL(r_std),DIMENSION(npts)                       :: woodmass        !! Wood mass of an individual (gC)
+    INTEGER(i_std)                                    :: j               !! Index
+    REAL(r_std),DIMENSION(npts)                       :: dia             !! Stem diameter (m)
+    REAL(r_std),DIMENSION(nvm)                        :: height_presc_12 !! [DISPENSABLE] Prescribed height of each pfts (m)
+
+!_ ================================================================================================================================
+    
+  !! 1. Initializations
+    
+    !! 1.1 Check if DGVM is activated
+    IF (.NOT.control%ok_dgvm .AND. control%ok_constant_mortality) THEN
+       STOP 'crown: not to be called with static vegetation.'
+    ENDIF
+    
+    !! 1.2 Initialize output to zero
+    cn_ind(:,:) = zero
+    
+  !! 2. Calculate (or prescribe) crown area
+    
+    DO j = 2,nvm ! loop over PFTs
+
+       IF (is_tree(j)) THEN
+          
+          !! 2.1 Trees
+          IF (natural(j)) THEN
+
+             !! 2.1.1 Natural trees
+             !WHERE (PFTpresent(:,j) .AND.ind(:,j).GT.min_stomate)
+             WHERE (PFTpresent(:,j) .AND. woodmass_ind(:,j) .GT. min_stomate)
+
+                !! 2.1.1.1 Calculate individual wood mass**2
+
+                !! SZ note that woodmass_ind needs to be defined on the individual, hence
+                !! biomass*veget_max/ind, not as stated here, correction MERGE 
+                !!         woodmass(:) = &
+                !! &         (biomass(:,j,isapabove,icarbon) + biomass(:,j,isapbelow,icarbon) &
+                !! &         +biomass(:,j,iheartabove,icarbon) + biomass(:,j,iheartbelow,icarbon))/ind(:,j)
+          
+                !! 2.1.1.2 Stem diameter from pipe model
+                !          Stem diameter (pipe model) is calculated by allometory (eqn 1, Appdx B, Smith et al. (2001))
+                !!!$          dia(:) = (woodmass(:)/(pipe_density*pi/4.*pipe_tune2)) &
+                dia(:) = (woodmass_ind(:,j)/(pipe_density(j)*pi/4.*pipe_tune2(j))) &
+                 &       **(1./(2.+pipe_tune3(j)))
+
+                !! 2.1.1.3 Individual tree height from pipe model
+                !          Individual tree height (eqn 2, Appdx B, Smith et al. (2001))
+                WHERE ( forest_managed(:,j) == 0 )
+
+                   height(:,j) = pipe_tune2(j)*(dia(:)**pipe_tune3(j))
+
+                ENDWHERE
+
+!!$                WHERE (height(:,j) > height_presc_12(j))
+!!$                   dia(:) = (height_presc_12(j)/pipe_tune2)**(1./pipe_tune3)
+!!$                   WHERE (forest_managed(:,j)>0)
+!!$                      height(:,j) = height_presc_12(j)
+!!$                   ENDWHERE
+!!$                ENDWHERE
+
+                !!!$SZ: The constraint on height has nothing to do with LPJ (for that purpose there's dia_max
+                !!!$ cannot see why this is necessary - it also blurrs the output, hence I leave it commented
+                !!!$ WHERE (height(:,j) > height_presc_12(j))
+                !!!$    dia(:) = (height_presc_12(j)/pipe_tune2)**(1./pipe_tune3)
+                !!!$    WHERE ( forest_managed(:,j) == 0 )
+                !!!$            height(:,j) = height_presc_12(j)
+                !!!$    END WHERE
+                !!!$ ENDWHERE
+
+
+                
+
+                !! 2.1.1.4 Crown area of individual tree  
+                !          Calculate crown area, truncate crown area for trunks with large diameters 
+                ! crown area cannot exceed a certain value, prescribed through maxdia 
+                ! (eqn 3, Appdx B, Smith et al. (2001))
+                cn_ind(:,j) = pipe_tune1*MIN(dia(:),maxdia(j))**pipe_tune_exp_coeff
+
+             ENDWHERE
+          ELSE
+
+             !! 2.1.2 Agricultural tree
+             !        To be developped if needed
+             STOP 'crown: cannot treat agricultural trees.'
+          ENDIF
+       ELSE
+          
+       !! 2.2 Grasses
+          
+          WHERE (PFTpresent(:,j))
+
+             !! 2.2.1 Crown area of grass
+             !        An "individual" is 1 m^2 of grass
+             cn_ind(:,j) = un
+
+          ENDWHERE
+       ENDIF
+       
+       !! 2.3 Recalculate vegetation cover 
+       
+       !!!$SZ: since now all state variables are defined on veget_max it is very
+       !!!$ dangerous to change this several times in stomate_lpj, as then GPP, turnover and allocated 
+       !!!$ biomass are not defined on the same space! Hence, veget_max is now kept constant
+       !!!$ and updated at the end of stomate_lpj in lpj_cover.f90
+       !!!$ Eventually, this routine should only be called once at the beginning and the end of stomate_lpj
+       !!!$ or prefereably cn_ind made a saved state variable!
+       !!!$ IF (natural(j).AND.control%ok_dgvm) THEN
+       !!!$   veget_max(:,j) = ind(:,j) * cn_ind(:,j)
+       !!!$ ENDIF
+
+    ENDDO ! loop over PFTs
+
+  END SUBROUTINE crown_diagnostic
+
+END MODULE lpj_crown
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_establish.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_establish.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_establish.f90	(revision 7236)
@@ -0,0 +1,748 @@
+! =================================================================================================================================
+! MODULE       : lpj_establish
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        Establish pft's
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	: 
+!! - Sitch, S., B. Smith, et al. (2003), Evaluation of ecosystem dynamics,
+!!        plant geography and terrestrial carbon cycling in the LPJ dynamic 
+!!        global vegetation model, Global Change Biology, 9, 161-185.\n
+!! - Haxeltine, A. and I. C. Prentice (1996), BIOME3: An equilibrium
+!!        terrestrial biosphere model based on ecophysiological constraints, 
+!!        resource availability, and competition among plant functional types,
+!!        Global Biogeochemical Cycles, 10(4), 693-709.\n
+!! - Smith, B., I. C. Prentice, et al. (2001), Representation of vegetation
+!!        dynamics in the modelling of terrestrial ecosystems: comparing two
+!!        contrasting approaches within European climate space,
+!!        Global Ecology and Biogeography, 10, 621-637.\n
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE lpj_establish
+
+  ! modules used:
+  USE xios_orchidee
+  USE ioipsl_para
+  USE stomate_data
+  USE constantes
+  USE function_library
+
+  IMPLICIT NONE
+
+  ! private & public routines
+  PRIVATE
+  PUBLIC establish_clear, establish_diagnostic
+
+  LOGICAL, SAVE                          :: firstcall = .TRUE.           !! first call
+!$OMP THREADPRIVATE(firstcall)
+CONTAINS
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : fire_clear 
+!!
+!>\BRIEF       Set the firstcall flag to .TRUE. and activate initialization
+!_ ================================================================================================================================
+
+  SUBROUTINE establish_clear
+    firstcall = .TRUE.
+  END SUBROUTINE establish_clear
+
+
+! =================================================================================================================================
+! SUBROUTINE   : establish_diagnostic 
+!
+!>\BRIEF       Calculate sstablishment of new woody PFT and herbaceous PFTs
+!!
+!! DESCRIPTION : Establishments of new woody and herbaceous PFT are simulated. 
+!! Maximum establishment rate (0.12) declines due to competition for light (space).
+!! There are two establishment estimates: one for the for DGVM and one for the 
+!! static cases.\n
+!! In the case of DGVM, competitive process of establishment for the area of 
+!! available space is represented using more detailed description compared with static 
+!! one. Biomass and distribution of plant age are updated on the basis of changes 
+!! in number of individuals. Finally excess sapwood of is converted to heartwood.
+!!
+!! \latexonly
+!! \input{equation_lpj_establish.tex}
+!! \endlatexonly
+!! \n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)    :
+!! Smith, B., I. C. Prentice, et al. (2001), Representation of vegetation
+!!    dynamics in the modelling of terrestrial ecosystems: comparing two
+!!    contrasting approaches within European climate space,
+!!    Global Ecology and Biogeography, 10, 621-637.
+!!
+!! FLOWCHART       : 
+!! \latexonly
+!! \includegraphics[scale = 0.7]{establish.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+ 
+  SUBROUTINE establish_diagnostic (npts, dt, PFTpresent, regenerate, &
+       neighbours, resolution, need_adjacent, herbivores, &
+       precip_annual, gdd0, lm_lastyearmax, &
+       cn_ind, lai, avail_tree, avail_grass,  npp_longterm, &
+       leaf_age, leaf_frac, &
+       ind, biomass, age, everywhere, co2_to_bm,veget_max, woodmass_ind)
+ 
+    !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+    
+    INTEGER(i_std), INTENT(in)                                :: npts            !! Domain size - number of pixels (dimensionless)    
+    REAL(r_std), INTENT(in)                                   :: dt              !! Time step of vegetation dynamics for stomate 
+                                                                                 !! (days)            
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                  :: PFTpresent      !! Is pft there (unitless)    
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: regenerate      !! Winter sufficiently cold (unitless)   
+    INTEGER(i_std), DIMENSION(npts,8), INTENT(in)             :: neighbours      !! indices of the 8 neighbours of each grid point 
+                                                                                 !! (unitless);  
+                                                                                 !! [1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW]  
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)                :: resolution      !! resolution at each grid point (m); 1=E-W, 2=N-S     
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                  :: need_adjacent   !! in order for this PFT to be introduced, does it
+                                                                                 !! have to be present in an adjacent grid box?  
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: herbivores      !! time constant of probability of a leaf to 
+                                                                                 !! be eaten by a herbivore (days)     
+    REAL(r_std), DIMENSION(npts), INTENT(in)                  :: precip_annual   !! annual precipitation (mm year^{-1}) 
+    REAL(r_std), DIMENSION(npts), INTENT(in)                  :: gdd0            !! growing degree days (degree C)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: lm_lastyearmax  !! last year's maximum leaf mass for each PFT 
+                                                                                 !! (gC m^{-2 })
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: cn_ind          !! crown area of individuals (m^2)        
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: lai             !! leaf area index OF an individual plant 
+                                                                                 !! (m^2 m^{-2})           
+    REAL(r_std), DIMENSION(npts), INTENT(in)                  :: avail_tree      !! space availability for trees (unitless)     
+    REAL(r_std), DIMENSION(npts), INTENT(in)                  :: avail_grass     !! space availability for grasses (unitless)  
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: npp_longterm    !! longterm NPP, for each PFT (gC m^{-2})   
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: veget_max       !! "maximal" coverage fraction of a PFT 
+                                                                                 !! (LAI -> infinity) on ground (unitless)
+    !! 0.2 Output variables
+    
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout) :: leaf_age        !! leaf age (days)     
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout) :: leaf_frac       !! fraction of leaves in leaf age class (unitless)    
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: ind             !! Number of individuals (individuals m^{-2})          
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(inout):: biomass   !! biomass (gC m^{-2 })     
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: age             !! mean age (years)       
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: everywhere      !! is the PFT everywhere in the grid box or very 
+                                                                                 !! localized (unitless)    
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: co2_to_bm       !! biomass up take for establishment i.e. 
+                                                                                 !! pseudo-photosynthesis (gC m^{-2} day^{-1}) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: woodmass_ind    !! woodmass of the individual, needed to calculate
+                                                                                 !! crownarea in lpj_crownarea (gC m^{-2 })  
+
+    !! 0.4 Local variables
+
+    REAL(r_std)                                               :: tau_eatup       !! time during which a sapling can be entirely 
+                                                                                 !! eaten by herbivores (days) 
+    REAL(r_std), DIMENSION(npts,nvm)                          :: fpc_nat         !! new fpc, foliage projective cover: fractional
+                                                                                 !! coverage (unitless)       
+    REAL(r_std), DIMENSION(npts)                              :: estab_rate_max_climate_tree  !! maximum tree establishment rate, 
+                                                                                              !! based on climate only (unitless)  
+    REAL(r_std), DIMENSION(npts)                              :: estab_rate_max_climate_grass !! maximum grass establishment rate,
+                                                                                              !! based on climate only (unitless)
+    REAL(r_std), DIMENSION(npts)                              :: estab_rate_max_tree          !! maximum tree establishment rate, 
+                                                                                              !! based on climate and fpc 
+                                                                                              !! (unitless) 
+    REAL(r_std), DIMENSION(npts)                              :: estab_rate_max_grass         !! maximum grass establishment rate,
+                                                                                              !! based on climate and fpc 
+                                                                                              !! (unitless) 
+    REAL(r_std), DIMENSION(npts)                              :: sumfpc          !! total natural fpc (unitless)
+    REAL(r_std), DIMENSION(npts)                              :: fracnat         !! total fraction occupied by natural 
+                                                                                 !! vegetation (unitless)  
+    REAL(r_std), DIMENSION(npts)                              :: sumfpc_wood     !! total woody fpc (unitless)    
+    REAL(r_std), DIMENSION(npts)                              :: spacefight_tree !! for trees, measures the total concurrence for
+                                                                                 !! available space (unitless)      
+    REAL(r_std), DIMENSION(npts)                              :: spacefight_grass!! for grasses, measures the total concurrence 
+                                                                                 !! for available space (unitless)
+    REAL(r_std), DIMENSION(npts,nvm)                          :: d_ind           !! change in number of individuals per time step 
+                                                                                 !! (individuals m^{-2} day{-1})         
+    REAL(r_std), DIMENSION(npts)                              :: bm_new          !! biomass increase (gC m^{-2 })        
+    REAL(r_std), DIMENSION(npts)                              :: dia             !! stem diameter (m)    
+    REAL(r_std), DIMENSION(npts)                              :: b1              !! temporary variable           
+    REAL(r_std), DIMENSION(npts)                              :: woodmass        !! woodmass of an individual (gC m^{-2})  
+    REAL(r_std), DIMENSION(npts)                              :: leaf_mass_young !! carbon mass in youngest leaf age class 
+                                                                                 !! (gC m^{-2})
+    REAL(r_std), DIMENSION(npts)                              :: factor          !! reduction factor for establishment if many 
+                                                                                 !! trees or grasses are present (unitless)  
+    REAL(r_std), DIMENSION(npts)                              :: total_bm_c      !! Total carbon mass for all pools (gC m^{-2})    
+    REAL(r_std), DIMENSION(npts,nelements)                    :: total_bm_sapl   !! Total sappling biomass for all pools 
+                                                                                 !! (gC m^{-2})  
+    INTEGER(i_std)                                            :: nfrontx         !! from how many sides is the grid box invaded
+                                                                                 !! (unitless?)   
+    INTEGER(i_std)                                            :: nfronty         !! from how many sides is the grid box invaded
+                                                                                 !! (unitless?)   
+   !LOGICAL, DIMENSION(npts)                                  :: many_new        !! daily establishment rate is large compared to 
+                                                                                 !! present number of individuals
+    REAL(r_std), DIMENSION(npts)                              :: vn              !! flow due to new individuals veget_max after 
+                                                                                 !! establishment, to get a proper estimate of 
+                                                                                 !! carbon and nitrogen 
+    REAL(r_std), DIMENSION(npts)                              :: lai_ind         !! lai on each PFT surface (m^2 m^{-2})   
+    INTEGER(i_std)                                            :: i,j,k,m         !! indices (unitless)       
+!_ ================================================================================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering establish'
+
+  !! 1. messages and initialization
+
+    ! Assumption: time durasion that sapling is completely eaten by hervioures is a half year?   
+    ! No reference
+    tau_eatup = one_year/2.
+
+    !! 1.1 First call only
+    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
+
+    IF (control%ok_dgvm) THEN
+       fracnat(:) = un
+
+       !! 2.1 Only natural part of the grid cell
+       do j = 2,nvm ! Loop over # PFTs
+          
+          IF ( .NOT. natural(j) ) THEN
+             fracnat(:) = fracnat(:) - veget_max(:,j)
+          ENDIF
+       ENDDO ! Loop over # PFTs
+       
+       sumfpc(:) = zero
+
+       !! 2.2 Total natural fpc on grid
+       !      The overall fractional coverage of a PFT in a grid is calculated here.
+       !      FPC is related to mean individual leaf area index by the Lambert-Beer law.
+       !      See Eq. (1) in tex file.\n
+       DO j = 2,nvm ! Loop over # PFTs
+          IF ( natural(j) ) THEN
+             WHERE(fracnat(:).GT.min_stomate)
+                WHERE (lai(:,j) == val_exp) 
+                   fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:)
+                ELSEWHERE
+                   fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:) & 
+                        * ( un - exp( - lm_lastyearmax(:,j) * sla(j) * ext_coeff(j) ) )
+                ENDWHERE
+             ENDWHERE
+
+             WHERE ( PFTpresent(:,j) )
+                sumfpc(:) = sumfpc(:) + fpc_nat(:,j)
+             ENDWHERE
+          ELSE
+
+             fpc_nat(:,j) = zero
+
+          ENDIF
+
+       ENDDO ! Loop over # PFTs
+       
+       !! 2.3 Total woody fpc on grid and number of regenerative tree pfts
+       !      Total woody FPC increases by adding new FPC.
+       !      Under the condition that temperature in last winter is higher than a threshold, 
+       !      woody plants is exposed in higher competitive environment.
+       sumfpc_wood(:) = zero
+       spacefight_tree(:) = zero
+
+       DO j = 2,nvm ! Loop over # PFTs
+
+          IF ( is_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 ! Loop over # PFTs
+
+       !! 2.4 Total number of natural grasses on grid\n
+       !     Grass increment equals 'everywhere'\n
+       spacefight_grass(:) = zero
+
+       DO j = 2,nvm ! Loop over # PFTs
+
+          IF ( .NOT. is_tree(j) .AND. natural(j) ) THEN
+
+             ! Count a PFT fully only if it is present on a grid.
+             WHERE ( PFTpresent(:,j) )
+                spacefight_grass(:) = spacefight_grass(:) + everywhere(:,j)
+             ENDWHERE
+
+          ENDIF
+
+       ENDDO ! Loop over # PFTs
+
+       !! 2.5 Maximum establishment rate, based on climate only\n
+       WHERE ( ( precip_annual(:) .GE. precip_crit ) .AND. ( gdd0(:) .GE. gdd_crit_estab ) )
+
+          estab_rate_max_climate_tree(:) = estab_max_tree ! 'estab_max_*'; see 'stomate_constants.f90'
+          estab_rate_max_climate_grass(:) = estab_max_grass
+
+       ELSEWHERE
+
+          estab_rate_max_climate_tree(:) = zero
+          estab_rate_max_climate_grass(:) = zero
+
+       ENDWHERE
+
+       !! 2.6 Reduce maximum tree establishment rate if many trees are 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(:) = 1. - 15. * ( sumfpc_wood(:) - (fpc_crit-.075))
+       !      factor(:) = MAX( 0.25_r_std, MIN( 1._r_std, factor(:)))
+       !      SZ modified according to Smith et al. 2001
+       !      See Eq. (2) in header
+       factor(:)=(un - exp(- establish_scal_fact * (un - sumfpc_wood(:))))*(un - sumfpc_wood(:))
+       estab_rate_max_tree(:) = estab_rate_max_climate_tree(:) * factor(:)
+
+       !! 2.7 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(:) = 1. - 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(:)
+       !      SZ modified to true LPJ formulation, grasses are only allowed in the
+       !      fpc fraction not occupied by trees..., 080806
+       !      estab_rate_max_grass(:)=MAX(0.98-sumfpc(:),zero)
+       !      See Eq. (3) in header
+       estab_rate_max_grass(:) = MAX(MIN(estab_rate_max_climate_grass(:), max_tree_coverage - sumfpc(:)),zero)
+
+       !! 2.8 Longterm grass NPP for competition between C4 and C3 grasses
+       !      to avoid equal veget_max, the idea is that more reestablishment
+       !      is possible for the more productive PFT
+       factor(:) = min_stomate
+       DO j = 2,nvm ! Loop over # PFTs
+          IF ( natural(j) .AND. .NOT.is_tree(j)) & 
+               factor(:) = factor(:) + npp_longterm(:,j) * &
+               lm_lastyearmax(:,j) * sla(j)
+       ENDDO ! Loop over # PFTs
+
+       !! 2.9 Establish natural PFTs
+       d_ind(:,:) = zero
+
+       DO j = 2,nvm ! Loop over # PFTs
+
+          IF ( natural(j) ) THEN ! only for natural PFTs
+
+             !! 2.9.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 ! Loop over # pixels - domain size
+
+                   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 expanded (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).
+                         ! What is this equation? No reference.
+                         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), un )
+
+                   ENDIF
+
+                ENDDO ! Loop over # pixels - domain size
+
+             ENDIF ! treat expansion?
+
+             !! 2.9.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).
+
+             !! 2.9.2.1 present and regenerative trees
+             IF ( is_tree(j) ) THEN
+
+                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
+
+             !! 2.9.2.2 present and regenerative grasses
+             ELSE
+
+                WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit )  & 
+                     .AND.factor(:).GT.min_stomate .AND. spacefight_grass(:).GT. min_stomate) 
+                   
+                   d_ind(:,j) = estab_rate_max_grass(:)*everywhere(:,j)/spacefight_grass(:) * &
+                        MAX(min_stomate,npp_longterm(:,j)*lm_lastyearmax(:,j)*sla(j)/factor(:)) * fracnat(:) * dt/one_year
+                   
+                ENDWHERE
+                
+             ENDIF  ! tree/grass
+             
+          ENDIF ! if natural
+       ENDDO  ! Loop over # PFTs
+       
+  !! 3. Lpj establishment in static case 
+
+    !     Lpj establishment in static case, SZ 080806, account for real LPJ dynamics in
+    !     prescribed vegetation, i.e. population dynamics within a given area of the grid cell.
+    ELSE 
+
+       d_ind(:,:) = zero
+
+       DO j = 2,nvm ! Loop over # PFTs
+
+          WHERE(ind(:,j)*cn_ind(:,j).GT.min_stomate)
+             lai_ind(:) = sla(j) * lm_lastyearmax(:,j)/(ind(:,j)*cn_ind(:,j))
+          ELSEWHERE
+             lai_ind(:) = zero
+          ENDWHERE
+
+          !! 3.1 For natural woody PFTs
+          IF ( natural(j) .AND. is_tree(j)) THEN 
+
+             ! See Eq. (4) in tex file.            
+             fpc_nat(:,j) =  MIN(un, cn_ind(:,j) * ind(:,j) * & 
+                  MAX( ( un - exp( - ext_coeff(j) * lai_ind(:) ) ), min_cover ) )
+
+
+             WHERE (veget_max(:,j).GT.min_stomate.AND.ind(:,j).LE.2.)
+
+                !! 3.1.1 Only establish into growing stands 
+                !        Only establish into growing stands, ind can become very
+                !        large in the static mode because LAI is very low in poor 
+                !        growing conditions, favouring continuous establishment. 
+                !        To avoid this a maximum IND is set. BLARPP: This should be
+                !        replaced by a better stand density criteria.
+                factor(:)=(un - exp(-establish_scal_fact * (un - fpc_nat(:,j))))*(un - fpc_nat(:,j))
+
+                estab_rate_max_tree(:) = estab_max_tree * factor(:) 
+
+                !! 3.1.2 do establishment for natural PFTs\n
+                d_ind(:,j) = MAX( zero, estab_rate_max_tree(:) * dt/one_year)
+
+             ENDWHERE
+
+             !SZ: quickfix: to simulate even aged stand, uncomment the following lines...
+             !where (ind(:,j) .LE. min_stomate)
+             !d_ind(:,j) = 0.1 !MAX( 0.0, estab_rate_max_tree(:) * dt/one_year)
+             WHERE (veget_max(:,j).GT.min_stomate .AND. ind(:,j).EQ.zero)
+                d_ind(:,j) = ind_0_estab
+             ENDWHERE
+
+          !! 3.2 For natural grass PFTs
+          ELSEIF ( natural(j) .AND. .NOT.is_tree(j)) THEN 
+
+             WHERE (veget_max(:,j).GT.min_stomate)
+
+                fpc_nat(:,j) =  cn_ind(:,j) * ind(:,j) * & 
+                     MAX( ( un - exp( - ext_coeff(j) * lai_ind(:) ) ), min_cover )
+
+                d_ind(:,j) = MAX(zero , (un - fpc_nat(:,j)) * dt/one_year )
+
+             ENDWHERE
+
+             WHERE (veget_max(:,j).GT.min_stomate .AND. ind(:,j).EQ. zero)
+                d_ind(:,j) = ind_0_estab 
+             ENDWHERE
+
+          ENDIF
+
+       ENDDO ! Loop over # PFTs
+
+    ENDIF ! DGVM OR NOT
+
+  !! 4. Biomass calculation
+
+    DO j = 2,nvm ! Loop over # PFTs
+
+       IF ( natural(j) ) THEN ! only for natural PFTs
+
+          !! 4.1 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 ( control%ok_herbivory ) THEN
+
+             d_ind(:,j) = d_ind(:,j) * EXP( - tau_eatup/herbivores(:,j) )
+
+          ENDIF
+
+          !! 4.2 Total biomass.
+          !      Add biomass only if d_ind, over one year, is of the order of ind.
+          !      save old leaf mass to calculate leaf age
+          leaf_mass_young(:) = leaf_frac(:,j,1) * biomass(:,j,ileaf,icarbon)
+
+          ! total biomass of existing PFT to limit biomass added from establishment
+          total_bm_c(:) = zero
+
+          DO k = 1, nparts
+             total_bm_c(:) = total_bm_c(:) + biomass(:,j,k,icarbon)
+          ENDDO
+          IF(control%ok_dgvm) THEN
+             vn(:) = veget_max(:,j)
+          ELSE
+             vn(:) = un
+          ENDIF
+
+          total_bm_sapl(:,:)=zero
+          DO k = 1, nparts
+             WHERE(d_ind(:,j).GT.min_stomate.AND.vn(:).GT.min_stomate)
+
+                total_bm_sapl(:,icarbon) = total_bm_sapl(:,icarbon) + & 
+                     bm_sapl_old(j,k,icarbon) * d_ind(:,j) / vn(:)
+                
+             ENDWHERE
+          ENDDO
+
+          !! 4.3 Woodmass calculation
+
+          !! 4.3.1 with DGVM
+          IF(control%ok_dgvm) THEN
+
+             ! SZ calculate new woodmass_ind and veget_max after establishment (needed for correct scaling!)
+             ! essential correction for MERGE!
+             IF (is_tree(j)) THEN
+                DO i = 1,npts ! Loop over # pixels - domain size
+                   IF((d_ind(i,j)+ind(i,j)).GT.min_stomate) THEN
+
+                      IF((total_bm_c(i).LE.min_stomate) .OR. (veget_max(i,j) .LE. min_stomate)) THEN
+
+                        ! new wood mass of PFT
+                         woodmass_ind(i,j) = &
+                              (((biomass(i,j,isapabove,icarbon) + biomass(i,j,isapbelow,icarbon) &
+                              + biomass(i,j,iheartabove,icarbon) + biomass(i,j,iheartbelow,icarbon))*veget_max(i,j)) &
+                              + ((bm_sapl_old(j,isapabove,icarbon)) + (bm_sapl_old(j,isapbelow,icarbon)) &
+                              + (bm_sapl_old(j,iheartabove,icarbon)) &
+                              + (bm_sapl_old(j,iheartbelow,icarbon)))*d_ind(i,j))/(ind(i,j) + d_ind(i,j))
+
+                      ELSE
+ 
+                         ! new biomass is added to the labile pool, hence there is no change 
+                         ! in CA associated with establishment
+                         woodmass_ind(i,j) = &
+                              & (biomass(i,j,isapabove,icarbon) + biomass(i,j,isapbelow,icarbon) &
+                              & +biomass(i,j,iheartabove,icarbon) + biomass(i,j,iheartbelow,icarbon))*veget_max(i,j) &
+                              & /(ind(i,j) + d_ind(i,j))
+
+                      ENDIF
+
+                      ! new diameter of PFT
+                      dia(i) = (woodmass_ind(i,j)/(pipe_density(j)*pi/4.*pipe_tune2(j))) &
+                           &                **(1./(2.+pipe_tune3(j)))
+                      vn(i) = (ind(i,j) + d_ind(i,j))*pipe_tune1(j)*MIN(dia(i),maxdia(j))**pipe_tune_exp_coeff(j)
+
+                   ENDIF
+                ENDDO ! Loop over # pixels - domain size
+             ELSE ! for grasses, cnd=1, so the above calculation cancels
+                vn(:) = ind(:,j) + d_ind(:,j)
+             ENDIF
+
+          !! 4.3.2 without DGVM (static)\n
+          ELSE 
+             DO i=1,npts ! Loop over # pixels - domain size
+                IF(is_tree(j).AND.(d_ind(i,j)+ind(i,j)).GT.min_stomate) THEN
+                   IF(total_bm_c(i).LE.min_stomate) THEN
+
+                      ! new wood mass of PFT
+                      woodmass_ind(i,j) = &
+                           & (((biomass(i,j,isapabove,icarbon) + biomass(i,j,isapbelow,icarbon) &
+                           & + biomass(i,j,iheartabove,icarbon) + biomass(i,j,iheartbelow,icarbon))) &
+                           & + ((bm_sapl_old(j,isapabove,icarbon)) + &
+                           (bm_sapl_old(j,isapbelow,icarbon)) &
+                           & + (bm_sapl_old(j,iheartabove,icarbon)) + &
+                           (bm_sapl_old(j,iheartbelow,icarbon)))*d_ind(i,j))/(ind(i,j)+d_ind(i,j))
+
+                   ELSE
+ 
+                      ! new biomass is added to the labile pool, hence there is no change 
+                      ! in CA associated with establishment
+                      woodmass_ind(i,j) = &
+                           & (biomass(i,j,isapabove,icarbon) + biomass(i,j,isapbelow,icarbon) &
+                           & + biomass(i,j,iheartabove,icarbon) + biomass(i,j,iheartbelow,icarbon)) &
+                           & /(ind(i,j) + d_ind(i,j))
+
+                   ENDIF
+                ENDIF
+             ENDDO ! Loop over # pixels - domain size
+
+             vn(:) = un ! cannot change in static!, and veget_max implicit in d_ind
+
+          ENDIF
+
+          !! 4.4 total biomass of PFT added by establishment defined over veget_max ...
+          total_bm_sapl(:,:) = zero
+          DO k = 1, nparts ! Loop over # litter tissues (nparts=8); see 'stomate_constants.f90'
+             WHERE(d_ind(:,j).GT.min_stomate.AND.total_bm_c(:).GT.min_stomate.AND.vn(:).GT.min_stomate)
+
+                total_bm_sapl(:,icarbon) = total_bm_sapl(:,icarbon) + & 
+                     (bm_sapl_old(j,k,icarbon)) * d_ind(:,j) / vn(:)
+             ENDWHERE
+          ENDDO ! Loop over # litter tissues
+
+          !! 4.5 Update biomass at each component
+          DO k = 1, nparts ! Loop over # litter tissues
+
+             bm_new(:) = zero
+
+             ! first ever establishment, C flows
+             WHERE( d_ind(:,j).GT.min_stomate .AND. &
+                  total_bm_c(:).LE.min_stomate .AND. &
+                  vn(:).GT.min_stomate)
+                ! WHERE ( many_new(:) )
+
+                !bm_new(:) = d_ind(:,j) * bm_sapl(j,k) / veget_max (:,j)
+                bm_new(:) = d_ind(:,j) * (bm_sapl_old(j,k,icarbon)) / vn(:)
+
+                biomass(:,j,k,icarbon) = biomass(:,j,k,icarbon) + bm_new(:)
+
+                co2_to_bm(:,j) = co2_to_bm(:,j) + bm_new(:) / dt
+
+             ENDWHERE
+
+             ! establishment into existing population, C flows
+             WHERE(d_ind(:,j).GT.min_stomate.AND.total_bm_c(:).GT.min_stomate)
+
+                bm_new(:) = total_bm_sapl(:,icarbon) * biomass(:,j,k,icarbon) / total_bm_c(:)
+
+                biomass(:,j,k,icarbon) = biomass(:,j,k,icarbon) + bm_new(:)
+                co2_to_bm(:,j) = co2_to_bm(:,j) + bm_new(:) / dt
+
+             ENDWHERE
+          ENDDO ! Loop over # litter tissues
+
+          
+          !! 4.6 Decrease leaf age in youngest class if new leaf biomass is higher than old one.
+          WHERE ( d_ind(:,j) * bm_sapl_old(j,ileaf,icarbon) .GT. min_stomate )
+ 
+             ! reset leaf ages. Should do a real calculation like in the npp routine, 
+             ! but this case is rare and not worth messing around.
+             ! SZ 080806, added real calculation now, because otherwise leaf_age/leaf_frac
+             ! are not initialised for the calculation of vmax, and hence no growth at all.
+             ! logic follows that of stomate_npp.f90, just that it's been adjusted for the code here
+             leaf_age(:,j,1) = leaf_age(:,j,1) * leaf_mass_young(:) / &
+                  ( leaf_mass_young(:) + d_ind(:,j) * bm_sapl_old(j,ileaf,icarbon) )
+
+          ENDWHERE
+
+          leaf_mass_young(:) = leaf_mass_young(:) + d_ind(:,j) * bm_sapl_old(j,ileaf,icarbon)
+
+          !! 4.7 Youngest class: new mass in youngest class divided by total new mass
+          WHERE ( biomass(:,j,ileaf,icarbon) .GT. min_stomate )
+             ! new age class fractions (fraction in youngest class increases)
+             leaf_frac(:,j,1) = leaf_mass_young(:) / biomass(:,j,ileaf,icarbon)
+
+          ENDWHERE
+
+          !! 4.8 Other classes: old mass in leaf age class divided by new mass
+          DO m = 2, nleafages
+
+             WHERE ( biomass(:,j,ileaf,icarbon) .GT. min_stomate )
+
+                leaf_frac(:,j,m) = leaf_frac(:,j,m) * & 
+                     ( biomass(:,j,ileaf,icarbon) + d_ind(:,j) * &
+                     bm_sapl_old(j,ileaf,icarbon) ) /  biomass(:,j,ileaf,icarbon)
+
+             ENDWHERE
+
+          ENDDO
+
+          !! 4.9 Update age and number of individuals
+          WHERE ( d_ind(:,j) .GT. min_stomate )
+
+             age(:,j) = age(:,j) * ind(:,j) / ( ind(:,j) + d_ind(:,j) )
+
+             ind(:,j) = ind(:,j) + d_ind(:,j)
+
+          ENDWHERE
+
+          !! 4.10 Convert excess sapwood to heartwood
+          !!      No longer done : supressed by S. Zaehle given that the LPJ logic of carbon allocation was 
+          !!      contradictory to SLAVE allocation. See CVS tag 1_5 for initial formulation. 
+
+
+       ENDIF ! natural
+
+    ENDDO ! Loop over # PFTs
+
+  !! 5. history
+
+    d_ind = d_ind / dt
+
+    CALL xios_orchidee_send_field("IND_ESTAB",d_ind)
+    CALL xios_orchidee_send_field("ESTABTREE",estab_rate_max_tree)
+    CALL xios_orchidee_send_field("ESTABGRASS",estab_rate_max_grass)
+
+    CALL histwrite_p (hist_id_stomate, 'IND_ESTAB', itime, d_ind, npts*nvm, horipft_index)
+    CALL histwrite_p (hist_id_stomate, 'ESTABTREE', itime, estab_rate_max_tree, npts, hori_index)
+    CALL histwrite_p (hist_id_stomate, 'ESTABGRASS', itime, estab_rate_max_grass, npts, hori_index)
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving establish'
+
+  END SUBROUTINE establish_diagnostic
+
+END MODULE lpj_establish
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_fire.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_fire.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_fire.f90	(revision 7236)
@@ -0,0 +1,662 @@
+! =================================================================================================================================
+! MODULE        : lpj_fire
+!
+! CONTACT	: orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      	: IPSL (2006). This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         Calculates the probability of fire and its effects on the carbon cycle
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! SVN           :
+!! $HeadURL$ 
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE lpj_fire
+
+  ! modules used:
+  USE xios_orchidee
+  USE stomate_data
+  USE ioipsl_para 
+  USE pft_parameters
+  USE constantes
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC fire,fire_clear
+
+  LOGICAL, SAVE                   :: firstcall = .TRUE.        !! first call 
+!$OMP THREADPRIVATE(firstcall)
+
+CONTAINS
+
+
+!! ================================================================================================================================
+!!  SUBROUTINE   : fire_clear 
+!!
+!>\BRIEF        Set the firstcall flag to .TRUE. and activate initialization
+!! 
+!_ ================================================================================================================================
+
+  SUBROUTINE fire_clear
+    firstcall = .TRUE.
+  END SUBROUTINE fire_clear
+
+
+!! ================================================================================================================================
+!! SUBROUTINE     : fire 
+!!
+!>\BRIEF          Calculate fire index and fraction of area burned by comparing 
+!! daily litter moisture with prescribed moisture of fire inhibition. If daily 
+!! moisture is below the precribed threshold, allow fire disturbance and 
+!! calculate CO_2 emissions from fire. The main algorithm follows Thonicke et al. 
+!! (2001)
+!!
+!! DESCRIPTION	: Fire occurs when the three basic prerequisites are met: 
+!! sufficient fuel on the ground, relatively dry fuel (fuel moisture lower than 
+!! the moisture of extinction), and presence of ignition sources.  The flag 
+!! ::disable_fire is used to use this fire module or not. While here in the module the 
+!! ignition source is not explicitely represented. It's assumed 
+!! that the ignition source is always available, i.e., if a sufficient amount 
+!! of dead fuel exists with a moisture content below the moisture of fire 
+!! inhibition, then both live and dead fuel will start to burn.\n
+!!
+!! The module completes the following tasks:
+!! 1. Calculates daily fire index, long term fire index and available ground 
+!! litter for burning.\n
+!! \latexonly
+!! \input{lpj_fire_1.tex}  
+!! \endlatexonly
+!! Where, m is the daily litter moisture, m_e is the moisture of extinction, p(m) 
+!! is probability of fire (i.e. the daily fire index).\n
+!! 
+!! \latexonly
+!! \input{lpj_fire_2.tex}  
+!! \endlatexonly
+!! Where, s is the long term fire index and A(s) is the annual fire fraction.\n
+!! 2. Calculates annual fire fraction, then transform to daily fraction in the 
+!! same time step of stomate.\n
+!! 3. Ground litter and grass live biomass (in growing season and except root and carbon 
+!! reserve pool) are  burned at full fire fraction.\n
+!! 4. Fire fraction for tree PFT are compromised by prescribed fire resistence.
+!! Tree live biomass are consumed using this compromised fire fraction and consumption
+!! fraction for different biomass parts. In the case of activation of dynamic 
+!! vegetation, tree individual density is updated after fire. \n 
+!! 5. For all types of fuel (either ground litter or live biomass) that are 
+!! burned, there is a certain fraction of âresidueâ that are not completely 
+!! burned. From this part of residue, there is further certain fraction that 
+!! goes to black carbon pool (very inert carbon pool that is part of geological
+!! carbon cycle), and the remaining part is transferred to (in case of biomass) or
+!! remains (in case of ground litter) as litter.\n
+!! 6. Update the biomass, litter or dead leaves pool after burning.
+!! 7. If the flag SPINUP_ANALYTIC is set to true, the matrix A is updated following
+!! Lardy (2011).
+!! 
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::co2_fire or the carbon emitted into the atmosphere 
+!! by fire, including both living and dead biomass (gC m^{-2} dtslow^{-1})$ @endtex
+!!
+!! REFERENCES    :
+!! - Thonicke K., Venevsky S., Sitch S., and Cramer W. (2001) The role of fire 
+!! disturbance for global vegetation dynamics: coupling fire into a Dynamic 
+!! Global Vegetation Model, Global Ecology & Biogeography, 10, 661-677.
+!! - Kuhlbusch et al. JGR 101, 23651-23665, 1996
+!! - Kuhlbusch & Crutzen, GBC 9, 491-501, 1995
+!! - Lardy, R, et al., A new method to determine soil organic carbon equilibrium,
+!! Environmental Modelling & Software (2011), doi:10.1016|j.envsoft.2011.05.016
+!!
+!! FLOWCHART     : None
+!! \n 
+!_ ================================================================================================================================
+  
+  SUBROUTINE fire (npts, dt, litterpart, &
+       litterhum_daily, t2m_daily, lignin_struc, lignin_wood, veget_max, &
+       fireindex, firelitter, biomass, ind, &
+       litter, dead_leaves, bm_to_litter, black_carbon, &
+       co2_fire, MatrixA)
+
+  !! 0. Variable and parameter declarations
+
+    !! 0.1 Input variables
+   
+    INTEGER(i_std), INTENT(in)                                   :: npts                !! Domain size - number of pixels 
+                                                                                        !! (unitless)   
+    REAL(r_std), INTENT(in)                                      :: dt                  !! Time step of the simulations for stomate 
+                                                                                        !! (days)   
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(in)           :: litterpart          !! [DISPENSABLE] Fraction of litter above 
+                                                                                        !! the ground belonging to different PFTs 
+                                                                                        !! ?? this variable is used but might be 
+                                                                                        !! redundant (with value of always 1) ?? 
+                                                                                        !! To check but probably litterpart to be 
+                                                                                        !! removed. Probably a residual from 
+                                                                                        !! nat/agri before merge   
+    REAL(r_std), DIMENSION(npts), INTENT(in)                     :: litterhum_daily     !! Daily litter moisture (unitless, 0-1)   
+    REAL(r_std), DIMENSION(npts), INTENT(in)                     :: t2m_daily           !! Daily 2 meter temperature (K)   
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(in)           :: lignin_struc        !! Ratio Lignin/Carbon in structural above 
+                                                                                        !! and below ground litter 
+                                                                                        !! @tex $(gC gC^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(in)           :: lignin_wood         !! Ratio Lignine/Carbon in woody litter for above and
+                                                                                        !! and below ground litter 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                 :: veget_max           !! Maximum fraction of vegetation type including 
+                                                                                        !! non-biological fraction (0-1, unitless) 
+
+    !! 0.2 Output variables
+    
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                :: co2_fire            !! Carbon emitted into the atmosphere by 
+                                                                                        !! fire, including both living and dead 
+                                                                                        !! biomass 
+                                                                                        !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+    !! 0.3 Modified variables
+    
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)              :: fireindex           !! Probability of fire; in the code means 
+                                                                                        !! long term fire index (unitless, 0-1)   
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)              :: firelitter          !! Total natural litter 
+                                                                                        !! available for burning above the ground 
+                                                                                        !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(inout)  :: biomass        !! Biomass @tex $(gC m^{-2})$ @endtex
+    REAl(r_std), DIMENSION(npts,nvm), INTENT(inout)                   :: ind            !! Density of individuals 
+                                                                                        !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements), INTENT(inout) :: litter     !! Metabolic and structural litter, above
+                                                                                        !! and below ground 
+                                                                                        !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(inout)        :: dead_leaves         !! Dead leaves on ground, per PFT, 
+                                                                                        !! metabolic and structural 
+                                                                                        !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(inout):: bm_to_litter     !! Biomass entering the litter pool 
+                                                                                        !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts), INTENT(inout)                  :: black_carbon        !! Black carbon on the ground 
+                                                                                        !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nbpools,nbpools), INTENT(inout) :: MatrixA          !! Matrix containing the fluxes between the carbon pools
+                                                                                        !! here, it is called only if disable_fire = n
+                                                                                        !! once a day 
+                                                                                        !! @tex $(gC.m^2.day^{-1})$ @endtex
+   
+
+    !! 0.4 Local variables
+
+    REAL(r_std), DIMENSION(npts)                                  :: fire_disturb       !! Actual fire disturbance fraction 
+                                                                                        !! after consideration of inherent fire 
+                                                                                        !! resistance of different PFTs 
+                                                                                        !! (unitless, 0-1)  
+    REAL(r_std), DIMENSION(npts,nvm)                              :: firedeath          !! In case of activation of dynamic 
+                                                                                        !! vegetation, the daily fraction of 
+                                                                                        !! burned individuals (unitless, 0-1)  
+    REAL(r_std), DIMENSION(npts)                                  :: moistlimit         !! Moisture for fire inhibition per PFT                                                                                         !! 
+                                                                                        !! (unitless, 0-1) ; temporary variable 
+                                                                                        !! for each PFT in the loop over #PFT ? 
+                                                                                        !! it's not fire inhibition, it's 
+                                                                                        !! "moisture of extinction" by the original
+                                                                                        !! reference paper, and a more "fire 
+                                                                                        !! professional name" it's better to change
+                                                                                        !! the name of moistlimit 
+    REAL(r_std), DIMENSION(npts)                                  :: litter_above       !! Total aboveground litter per PFT                                                                                         !! 
+                                                                                        !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                              :: fireindex_daily    !! Daily fire index (unitless, 0-1) 
+    REAL(r_std), DIMENSION(npts, nvm)                             :: firefrac           !! Daily fire burning fraction on ground 
+                                                                                        !! (unitless, 0-1) 
+    REAL(r_std), DIMENSION(npts)                                  :: struc_residual     !! Fraction of structural litter not burned
+                                                                                        !! (thus residual), depending on strutural 
+                                                                                        !! litter lignin content  (unitless, 0-1) 
+    REAL(r_std), DIMENSION(npts)                                  :: residue            !! Fuel (either biomass or litter) not 
+                                                                                        !! burned  @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts)                                  :: bcfrac             !! Fraction of residue transformed into 
+                                                                                        !! black carbon (unitless, 0-1) 
+    REAL(r_std), DIMENSION(npts)                                  :: x                  !! Intermediate variable
+    REAL(r_std), DIMENSION(npts)                                  :: aff                !! Annual fire fraction (unitless, 0-1) 
+    INTEGER(i_std)                                                :: j,k,m              !! Indeces
+!_ ================================================================================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering fire'
+
+ !! 1. Initialization
+
+    IF ( firstcall ) THEN
+
+       !! 1.1 Fraction to CO_2
+       !      What fraction of the plant biomass compartment, if burned, is transformed 
+       !      into CO_2 released to the atmosphere?
+       !??! the fraction for heartabove seems too big, it's not clear if this value is correct. 
+
+       !! 1.2 print control 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.
+
+    ENDIF
+
+    !! 1.4 Initialize output
+    co2_fire(:,:) = zero
+    firedeath(:,:) = zero
+    fireindex_daily(:,:) = zero
+    firefrac(:,:) = zero
+
+ !! 2. Determine fire probability
+ 
+    ! Calculate probability that crops are not burned for the moment
+    ! Calculate long-term aboveground litter
+ 
+    ! a long loop over PFT
+    DO j = 2,nvm !loop over #PFT
+
+       !! 2.1 Total above ground litter
+       !      Total litter above the ground for the PFT under consideration
+       litter_above(:) = litter(:,imetabolic,j,iabove,icarbon) + &
+            litter(:,istructural,j,iabove,icarbon)
+
+
+       !! 2.2 Calculate the PFT litter amount weighted by moisture 
+       ! If litter moisture is higher than moisture of extinction, fire is not possible.
+       moistlimit(:) = zero
+
+       WHERE ( (t2m_daily(:) .GT. ZeroCelsius) .AND. (litter_above(:) .GT. min_stomate) )
+       !?? the calculation here is redundant? as the part before flam(j) is 1?
+       !?? see first comment.. litterpart to be removed ?
+          moistlimit(:) = &
+               ( litterpart(:,j,imetabolic)*litter(:,imetabolic,j,iabove,icarbon) + &
+               litterpart(:,j,istructural)*litter(:,istructural,j,iabove,icarbon)  ) / &
+               litter_above(:) * flam(j)
+
+       ENDWHERE
+
+       !! 2.3 Calculate daily fire index 
+       !      Calculate daily fire index
+       !      \latexonly
+       !        \input{lpj_fire_1.tex}  
+       !      \endlatexonly
+       !      Where, m is the daily litter moisture, m_e is the moisture of extinction, p(m) 
+       !      is probability of fire (i.e. the daily fire index).\n
+       WHERE ( moistlimit(:) .GT. min_stomate )
+          x(:) = litterhum_daily(:)/moistlimit(:)
+          fireindex_daily(:,j) = EXP( - pi * x(:) * x(:) )
+       ELSEWHERE
+          fireindex_daily(:,j) = zero
+       ENDWHERE
+
+       !! 2.4 Calculate long-term fire index 
+       !      Calculate long-term fire index which is the mean probability of fire
+       fireindex(:,j) = ((tau_fire - dt) * fireindex(:,j) + (dt) * fireindex_daily(:,j)) / tau_fire
+
+       !! 2.5 Calculate long term aboveground litter that are available for burning
+       firelitter(:,j) = &
+            ( ( tau_fire-dt ) * firelitter(:,j) + dt * litter_above(:) ) / tau_fire
+
+  !! 3. Calculate fire fraction from litter and fireindex
+
+       !! 3.1 Fire fraction from long term fire index for natural PFTs
+       !  Transform the annual fire fraction to daily fraction. This is done by assuming that
+       !  each day the fire fraction is the same. 
+       aff(:) = firefrac_func (npts, fireindex(:,j))
+
+       ! annual_fire_fraction = 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.
+       ! the variable 'un' is 1
+       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 = zero
+       
+       !! 3.2 For agricultural ground, no fire is burned for the moment
+       IF ( .NOT. natural(j)) firefrac(:,j) = zero
+       
+  !! 4. Determine fire impact
+
+       ! Calculate fire disturbance fraction for each PFT, and fire emissions due 
+       ! to grasses.
+   
+       !! 4.1 Tree and grass live biomass 
+       ! Tree live biomass is not burned in fire. 
+       ! However, in the dynamic vegetation module, tree individual density 
+       ! will be updated after fire. The fraction of tree individuals that are 
+       ! supposed to die in fire is the fire fraction multiplied by the tree PFT fire 
+       ! resistance which reflect survivorship of different tree PFTs during fire.  
+       IF ( is_tree(j) ) THEN
+
+          !! 4.1.1 Disturban,ce factor for trees 
+          !        Trees are disturbed over the whole year. A resistance factor is  
+          !        used to reflect survivorship of different tree PFTs during fire. 
+          fire_disturb(:) = ( un - resist(j) ) * firefrac(:,j)
+
+       ELSE
+
+          !! 4.1.2 Disturbance factor for grasses 
+          !        Grass is not disturbed outside the growing season thus grass biomass 
+          !        is only burned during the growing season.
+          WHERE ( biomass(:,j,ileaf,icarbon) .GT. min_stomate )
+
+             fire_disturb(:) = ( un - resist(j) ) * firefrac(:,j)
+
+          ELSEWHERE
+
+             fire_disturb(:) = zero
+
+          ENDWHERE
+
+       ENDIF
+
+       !! 4.2 Burn live biomass
+       !      The burned part goes to either the atmposhere, or litter, or blackcarbon pool. 
+       DO k = 1, nparts
+
+          ! for tree PFT, all biomass compartments are burned.
+          ! for grass biomass compartments, all are burned except root and carbon reserve
+          ! IF concerning PFT is tree; OR (the PFT is grass, but not root or carbon reserve biomass); then it's burned.
+          IF ( .NOT. ( ( .NOT. is_tree(j) ) .AND. ( ( k.EQ.iroot ) .OR. ( k.EQ.icarbres ) ) ) ) THEN
+
+             !! 4.2.1 Fraction to the atmosphere.
+             co2_fire(:,j) =  co2_fire(:,j)+ biomass(:,j,k,icarbon) * fire_disturb(:) * co2frac(k) / dt
+
+             !! 4.2.2 Determine the residue
+             !        Residual is expressed in gC/m^2
+             residue(:) = biomass(:,j,k,icarbon) * fire_disturb(:) * ( un - co2frac(k) )
+
+             !! 4.2.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).
+             !             IF ( co2frac(k) .GT. min_stomate ) THEN
+             IF ( co2frac(k) .GT. zero ) THEN
+                bcfrac(:) = bcfrac_coeff(1) / ( bcfrac_coeff(2) ** ( bcfrac_coeff(3) - 100.*co2frac(k) ) + un )
+             ELSE
+                bcfrac(:) = zero
+             ENDIF
+
+             !! 4.2.2.2 Add fraction of the residue to the black carbon "reservoir"
+             black_carbon(:) = &
+                  black_carbon(:) + bcfrac(:) * residue(:)* veget_max(:,j)
+
+             !! 4.2.2.3 The rest (largest part) of the residue becomes litter.
+             bm_to_litter(:,j,k,icarbon) = bm_to_litter(:,j,k,icarbon) + residue(:) * ( 1 - bcfrac(:) )
+          ENDIF  ! not for grass roots
+
+       ENDDO
+
+      
+       !! 4.3 Update biomass pool after burning
+       
+       !! 4.3.1 Decrease biomass amount except for grass roots and carbon reserve.
+       DO m = 1, nelements ! Loop over # elements
+          
+          DO k = 1, nparts
+
+             ! **2
+             IF ( .NOT. ( ( .NOT. is_tree(j) ) .AND. ( ( k.EQ.iroot ) .OR. ( k.EQ.icarbres) ) ) ) THEN
+                
+                biomass(:,j,k,m) = ( un - fire_disturb(:) ) * biomass(:,j,k,m)
+                
+             ENDIF
+
+          ENDDO
+          
+       END DO ! End Loop over # elements
+
+
+       !! 4.3.2 If vegetation is dynamic, then decrease the density of tree individuals.
+       IF ( (control%ok_dgvm .OR. .NOT.control%ok_constant_mortality) .AND. is_tree(j) ) THEN
+
+          firedeath(:,j) = fire_disturb(:) / dt
+          ind(:,j) = ( un - fire_disturb(:) ) * ind(:,j)
+
+       ENDIF
+
+    ENDDO      ! loop over #PFT
+
+  !! 5. Burn litter
+
+    !   All litter (either forest or grass) is burned throughout the whole year
+    !   Metabolic litter is totally burned. Burning fraction of structural litter is related 
+    !   with its lignin content. The burned part either goes to the atmosphere, or to the 
+    !   black carbon pool, or remains in litter as unburned residue.
+    DO j = 2,nvm  !loop over #PFT
+
+       !! 5.1 Burn exposed metabolic litter
+       !      Exposed metabolic litter burns completely and goes directly into the atmosphere as CO2.
+
+       !! 5.1.1 CO2 flux from litter burning
+       !        Flux expressed in gC m^{-2}dtslow^{-1}
+       co2_fire(:,j) = co2_fire(:,j) + litter(:,imetabolic,j,iabove,icarbon) * &
+            firefrac(:,j) / dt
+
+       !! 5.1.2 Decrease metabolic litter
+       DO m = 1,nelements
+          litter(:,imetabolic,j,iabove,m) = litter(:,imetabolic,j,iabove,m) * &
+               ( un - firefrac(:,j) )
+       END DO
+    
+       !! 5.2 Burning exposed structural litter 
+       !      The fraction that goes to the atmosphere is related to its lignin content. The remaining unburned 
+       !      residues go to either black carbon pool, or remain as litter.
+
+       !! 5.2.1 Incomplete burning of exposed structural litter  
+       !        Fraction of structural litter that does not burn completly. This fraction depends on lignin 
+       !        content (lignin_struc).
+       struc_residual(:) = fire_resist_lignin * lignin_struc(:,j,iabove)
+
+       !! 5.2.2 CO2 flux from litter burning 
+       !  Flux expressed in gC m^{-2}dtslow^{-1}
+       co2_fire(:,j) = co2_fire(:,j) + &
+            litter(:,istructural,j,iabove,icarbon) * firefrac(:,j) * &
+            ( un - struc_residual(:) )/ dt
+
+       !! 5.2.3 Determine residue 
+       !        The residue is litter that undergoes fire, but is not transformed into CO2
+       residue(:) = litter(:,istructural,j,iabove,icarbon) * 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(:) = bcfrac_coeff(1)/ ( bcfrac_coeff(2) ** ( bcfrac_coeff(3) - 100.*(un - struc_residual(:)) ) + un )
+
+       !! 5.2.5 Add this fraction of the residue to the black carbon "reservoir"
+       !        In gC m^{-2}
+       black_carbon(:) = &
+            black_carbon(:) + bcfrac(:) * residue(:)* veget_max(:,j)
+ 
+       !! 5.2.6 TResidue remaining litter
+       !        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,icarbon) = &
+            litter(:,istructural,j,iabove,icarbon) * ( un - firefrac(:,j) ) + &
+            residue(:) * ( un - bcfrac(:) )
+
+
+       !! 5.3 Burning exposed woody litter is not totally transformed into CO2.
+       
+       !! 5.3.1 Fraction of exposed woody litter that does not
+       !       burn totally should depend on lignin content (lignin_wood). 
+       
+       struc_residual(:) =  fire_resist_lignin * lignin_wood(:,j,iabove)
+       
+       !! 5.3.2 CO2 flux, in gC/(m**2 of total ground)/day.
+       
+       co2_fire(:,j) = co2_fire(:,j) + &
+            litter(:,iwoody,j,iabove,icarbon) * firefrac(:,j) * &
+            ( 1. - struc_residual(:) )/ dt
+
+       !! 5.3.3 determine residue (litter that undergoes fire, but is not transformed
+       !       into CO2)
+
+       residue(:) = litter(:,iwoody,j,iabove,icarbon) * firefrac(:,j) * struc_residual(:)
+
+       !! 5.3.4 determine fraction of black carbon in the residue.
+       !       depends on volatilized fraction of carbon
+      
+       bcfrac(:) = bcfrac_coeff(1)/ ( bcfrac_coeff(2) ** ( bcfrac_coeff(3) - & 
+                  100.*(un - struc_residual(:)) ) + un )
+       
+       !! 5.3.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(:) * veget_max(:,j)
+
+       !! 5.3.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(:,iwoody,j,iabove,icarbon) = &
+            litter(:,iwoody,j,iabove,icarbon) * ( 1. - firefrac(:,j) ) + &
+            residue(:) * ( 1. - bcfrac(:) )
+
+
+       !! 5.4 Update matrix A for analytical spin-up (only if SPINUP_ANALYTIC is activated)
+
+       IF (spinup_analytic) THEN
+          
+          ! litter structural above
+          MatrixA(:,j,istructural_above,istructural_above) =  MatrixA(:,j,istructural_above,istructural_above) - firefrac(:,j) &
+                                                                +  firefrac(:,j)* struc_residual(:)*( 1. - bcfrac(:)) 
+          
+          ! litter_metabolic above
+          MatrixA(:,j,imetabolic_above,imetabolic_above) = MatrixA(:,j,imetabolic_above,imetabolic_above) - firefrac(:,j)
+
+          ! litter woody above
+          MatrixA(:,j,iwoody_above,iwoody_above) =  MatrixA(:,j,iwoody_above,iwoody_above) - firefrac(:,j) &
+                                                              +  firefrac(:,j)* struc_residual(:)*( 1. - bcfrac(:)) 
+
+          !DS! This is the exact formulation. The above is a simplified formulation :
+          !
+          !          MatrixA(:,j,istructural_above,istructural_above) =  MatrixA(:,j,istructural_above,istructural_above)*(1. - firefrac(:,j) + &
+          !                                                             firefrac(:,j)* struc_residual(:)*( 1. - bcfrac(:)))
+          !
+          !          MatrixA(:,j,imetabolic_above,imetabolic_above) = MatrixA(:,j,imetabolic_above,imetabolic_above)*(1 - firefrac(:,j))
+          !
+          !          MatrixA(:,j,iwoody_above,iwoody_above) =  MatrixA(:,j,iwoody_above,iwoody_above)*(1. - firefrac(:,j) + &
+          !                                                             firefrac(:,j)* struc_residual(:)*( 1. - bcfrac(:)))
+          
+       ENDIF !(spinup_analytic)
+
+    ENDDO  !  loop over #PFT
+   
+   !! 5.5 Update exposed dead leaves (leaf litter) on the ground
+   !      Dead leaves are supposed to burn completely in fire 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. write out history variables
+
+    ! output in 1/dtslow
+    firefrac(:,:) = firefrac(:,:) / dt
+
+    CALL xios_orchidee_send_field("FIREFRAC",firefrac(:,:))
+    CALL xios_orchidee_send_field("FIREDEATH",firedeath(:,:))
+
+    CALL histwrite_p (hist_id_stomate, 'FIREFRAC', itime, &
+         firefrac(:,:), npts*nvm, horipft_index)
+    CALL histwrite_p (hist_id_stomate, 'FIREDEATH', itime, &
+         firedeath(:,:), npts*nvm, horipft_index)
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving fire'
+
+  END SUBROUTINE fire
+
+
+!! ================================================================================================================================
+!! FUNCTION     : firefrac_func
+!!
+!>\BRIEF        Calculate the annual fire fraction using long term fire index
+!! 
+!! DESCRIPTION	: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : annual fire fraction (::firefrac_result)
+!!
+!! REFERENCES   :
+!! - Thonicke K., Venevsky S., Sitch S., and Cramer W. (2001) The role of fire 
+!! disturbance for global vegetation dynamics: coupling fire into a Dynamic 
+!! Global Vegetation Model, Global Ecology & Biogeography, 10, 661-677.\n
+!!
+!! FLOWCHART    : None
+!! \n 
+!_ ================================================================================================================================
+   
+  FUNCTION firefrac_func (npts, x) RESULT (firefrac_result)
+
+!! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                 :: npts             !! Domain size (unitless)
+    REAL(r_std), DIMENSION(npts), INTENT(in)   :: x                !! fire index (unitless, 0-1)
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(npts)               :: firefrac_result  !! fire fraction (unitless, 0-1)
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std), DIMENSION(npts)               :: xm1              !! intermediate variable
+!_ ================================================================================================================================
+
+!! 1. Function
+
+    xm1(:) = x(:) - 1.
+
+    ! this equation is from Thonicke et al. (2001) equation (9), it use the fire index as input to calculate annual fire fraction.
+    ! but with different parameters with the source literature.
+    !! \latexonly
+    !! \input{lpj_fire_2.tex}  
+    !! \endlatexonly
+    !! Where, s is the long term fire index and A(s) is the annual fire fraction.\n
+    !??! here we use a different parameter with K. Thonicke et al. (2001)
+    !??! it's not clear if these parameters are correct.
+    firefrac_result(:) = &
+         &     x(:) * EXP( xm1(:) / ( -firefrac_coeff(4)*xm1(:)*xm1(:)*xm1(:) + &
+         &     firefrac_coeff(3)*xm1(:)*xm1(:) + &
+         &     firefrac_coeff(2)*xm1(:) +  &      
+         &     firefrac_coeff(1) ) )
+
+  END FUNCTION firefrac_func
+
+END MODULE lpj_fire
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_gap.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_gap.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_gap.f90	(revision 7236)
@@ -0,0 +1,327 @@
+! =================================================================================================================================
+! MODULE       : lpj_gap
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Simulate mortality of individuals and update biomass, litter and 
+!! stand density of the PFT
+!!
+!!\n DESCRIPTION : Simulate mortality of individuals and update biomass, litter and 
+!! stand density of the PFT. This module differs from lpj_kill.f90 in that this 
+!! module kills individuals within a PFT and lpj_kill.f90 removes a PFT from a 
+!! gridbox
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S) : 
+!! - Sitch, S., B. Smith, et al. (2003), Evaluation of ecosystem dynamics,
+!!         plant geography and terrestrial carbon cycling in the LPJ dynamic 
+!!         global vegetation model, Global Change Biology, 9, 161-185.\n
+!! - Waring, R. H. (1983). "Estimating forest growth and efficiency in relation 
+!!         to canopy leaf area." Advances in Ecological Research 13: 327-354.\n
+!! 
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE lpj_gap
+
+  ! modules used:
+  USE xios_orchidee
+  USE stomate_data
+  USE pft_parameters
+  USE ioipsl_para 
+  USE constantes
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC gap_diagnostic
+  
+  ! Variable declaration 
+
+  LOGICAL, SAVE             :: firstcall = .TRUE.                !! first call flag
+!$OMP THREADPRIVATE(firstcall)
+
+CONTAINS
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : gap_diagnostic
+!!
+!>\BRIEF        Simulate tree and grass mortality, transfer dead biomass to litter and update stand density
+!!
+!! DESCRIPTION  : Calculate mortality of trees and grasses, transfer the dead biomass to litter pool,
+!! and update biomass pool and number of individuals. To get tree mortality, it's possible to choose either a 
+!! constant mortality rate; or to calculate the tree mortality rate based on it's growth efficiency, which is 
+!! defined as this year's net biomass increment per leaf area.\n
+!!
+!! When using growth efficiency mortality, first calculate the net biomass increment for the last year, then 
+!! calculate the growth efficiency and finally calculate the growth efficiency mortality.\n
+!!
+!! Eqation to calculate growth efficiency:
+!! \latexonly 
+!!     \input{gap1.tex}
+!! \endlatexonly
+!! Where $greff$ is growth efficiency, $\Delta$ is net biomass increment, 
+!! $C_{leaf} is last year's leaf biomass, and $SLA$ the specific leaf area. 
+!! 
+!!
+!! Eqation to calculate growth efficiency mortality:
+!! \latexonly 
+!!     \input{gap2.tex}
+!! \endlatexonly
+!! Where $mort_{greff}$ is the growth efficiency mortality, $greff$ is growth  
+!! efficiency, $k_{mort1}$ is asymptotic maximum mortality rate.
+!! 
+!! The name for variable ::availability is not well chosen. Actually the meaning of the variable is mortailty 
+!! rate derived from growth efficiency related mortality. ?? Suggestion: change the name "availability" to 
+!! "mortgref", which means "mortality caused by ".\n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::biomass; biomass, ::ind density of individuals, ::bm_to_litter biomass transfer 
+!! to litter and ::mortality mortality (fraction of trees that is dying per time step)
+!!
+!! REFERENCE(S)   :
+!! - Sitch, S., B. Smith, et al. (2003), Evaluation of ecosystem dynamics,
+!!         plant geography and terrestrial carbon cycling in the LPJ dynamic 
+!!         global vegetation model, Global Change Biology, 9, 161-185.
+!! - Waring, R. H. (1983). "Estimating forest growth and efficiency in relation 
+!!         to canopy leaf area." Advances in Ecological Research 13: 327-354.
+!!
+!! FLOWCHART    : None
+!!\n
+!_ ================================================================================================================================
+  
+  SUBROUTINE gap_diagnostic (npts, dt, npp_longterm, turnover_longterm, lm_lastyearmax, &
+       PFTpresent, biomass, ind, bm_to_litter, mortality, &
+       forest_managed)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables 
+    INTEGER(i_std), INTENT(in)                              :: npts                    !! Domain size (-)
+    REAL(r_std), INTENT(in)                                 :: dt                      !! Time step (days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: npp_longterm            !! "Long term" (default 3-year) net primary
+                                                                                       !! productivity  
+                                                                                       !! @tex $(gC m^{-2} year^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(in) :: turnover_longterm !! "Long term" (default 3-year) turnover  
+                                                                                       !! rate @tex $(gC m^{-2} year^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: lm_lastyearmax          !! Last year's maximum leaf mass, for each 
+                                                                                       !! PFT @tex $(gC m^{-2})$ @endtex
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                :: PFTpresent              !! Is the pft present in the pixel
+    INTEGER(i_std), DIMENSION (npts,nvm), INTENT(in)        :: forest_managed          !! forest management flag
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(npts,nvm),INTENT(out)            :: mortality               !! Mortality (fraction of trees that is 
+                                                                                       !! dying per time step)
+
+    !! 0.3 Modified variables   
+    
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(inout)  :: biomass       !! Biomass @tex $(gC m^{-2}) $@endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                   :: ind           !! Number of individuals 
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(inout)  :: bm_to_litter  !! Biomass transfer to litter 
+                                                                                       !! @tex $(gC m^{-2})$ @endtex  
+
+    !! 0.4 Local variables
+
+    REAL(r_std), DIMENSION(npts)                            :: delta_biomass           !! Net biomass increase for the previous 
+                                                                                       !! year @tex $(gC m^{-2} year^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts)                            :: dmortality              !! Dead biomass caused by mortality 
+                                                                                       !! @tex $(gC m^{-2}) $@endtex
+    REAL(r_std), DIMENSION(npts)                            :: vigour                  !! Growth efficiency, an indicator of tree 
+                                                                                       !! vitality, used to calculate mortality
+    REAL(r_std), DIMENSION(npts)                            :: availability            !! Mortality rate derived by growth 
+                                                                                       !! efficiency @tex $(year^{-1})$ @endtex 
+    INTEGER(i_std)                                          :: j,k,m,i                 !! Indices
+
+!_ ================================================================================================================================
+
+    IF ( firstcall ) THEN
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering gap',control%ok_constant_mortality
+
+    mortality(:,:) = zero
+
+    DO j = 2,nvm  ! loop over #PFT
+
+       !! 1. Tree mortality
+
+       IF ( is_tree(j) ) THEN 
+
+          DO  i = 1,npts ! loop over land_points
+
+             IF ( forest_managed(i,j) == 0 ) THEN
+
+                !! 1.1 Use growth efficiency or constant mortality?
+                IF ( .NOT.  control%ok_constant_mortality  ) THEN
+
+                   !! 1.1.1 Estimate net biomass increment
+                   !  To calculate growth efficiency mortality, first estimate net biomass increment by 
+                   !  subtracting turnover from last year's NPP.
+                   IF ( PFTpresent(i,j) .AND. ( lm_lastyearmax(i,j) .GT. min_stomate ) ) THEN
+
+                      ! note that npp_longterm is now actually longterm growth efficiency (NPP/LAI)
+                      ! to be fair to deciduous trees calculate net biomass increment
+                      delta_biomass(i) = MAX( npp_longterm(i,j) - ( turnover_longterm(i,j,ileaf,icarbon) + &
+                           turnover_longterm(i,j,iroot,icarbon) + turnover_longterm(i,j,ifruit,icarbon) + & 
+                           turnover_longterm(i,j,isapabove,icarbon) + turnover_longterm(i,j,isapbelow,icarbon) ), zero)
+
+                      !! 1.1.2 Calculate growth efficiency 
+                      !  Calculate growth efficiency by dividing net biomass increment by last year's 
+                      !  maximum LAI. (corresponding actually to the maximum LAI of the previous year)
+                      vigour(i) = delta_biomass(i) / (lm_lastyearmax(i,j)*sla(j))
+
+                   ELSE
+
+                      vigour(i) = zero
+
+                   END IF ! PFTpresent(i,j) .AND. ( lm_lastyearmax(i,j) .GT. min_stomate)
+
+                   !! 1.1.3 Calculate growth efficiency mortality rate
+                   IF ( PFTpresent(i,j) ) THEN
+
+                      availability(i) = availability_fact / ( un + ref_greff * vigour(i) )
+
+                      ! Scale mortality by timesteps per year
+                      mortality(i,j) = MAX(min_avail, availability(i))  * dt/one_year  
+
+                   END IF ! PFTpresent(i,j)
+
+                ELSE  ! .NOT. control%ok_constant_mortality
+
+                   !! 1.2 Use constant mortality 
+                   !  constant mortality accounts for the residence time of each tree PFT
+                   IF ( PFTpresent(i,j) ) THEN
+
+                      mortality(i,j) = dt/(residence_time(j)*one_year)
+
+                   END IF ! PFTpresent(i,j)
+
+                ENDIF ! .NOT.  control%ok_constant_mortality
+
+                !! 1.3 Mortality in DGVM
+                !  If the long term NPP is zero, all trees are killed
+                !  +++CHECK+++
+                !  This is this only applied in the DGVM maybe in order to make 
+                !  the DGVM respond faster and thus make the vegetation dynamics 
+                !  more dynamic? The link with lpj_kill.f90 is still not clear 
+                !  and should be checked by who is working on the DGVM. 
+                IF ( control%ok_dgvm ) THEN
+
+                   IF ( PFTpresent(i,j) .AND. ( npp_longterm(i,j) .LE. min_stomate ) ) THEN
+
+                      mortality(i,j) = un
+
+                   END IF ! PFTpresent(i,j) .AND. ( npp_longterm(i,j) .LE. min_stomate
+
+                ENDIF
+                !  +++++++++++
+
+                !! 1.4 Update biomass and litter pools 
+                !  Update biomass and litter pool after dying and transfer recently died biomass to litter
+                DO m = 1,nelements
+
+                   DO k = 1, nparts
+
+                      IF ( PFTpresent(i,j) ) THEN
+
+                         dmortality(i) =  mortality(i,j) * biomass(i,j,k,m)
+                         bm_to_litter(i,j,k,m) = bm_to_litter(i,j,k,m) + dmortality(i)
+                         biomass(i,j,k,m) = biomass(i,j,k,m) - dmortality(i)
+
+                      END IF ! PFTpresent(i,j) 
+
+                   ENDDO !nparts
+
+                END DO !nelements
+
+                !! 1.5 In case of dynamic vegetation, update tree individual density
+                IF ( control%ok_dgvm .OR. .NOT.control%ok_constant_mortality) THEN
+
+                   IF ( PFTpresent(i,j) ) THEN
+
+                      ind(i,j) = ind(i,j) * ( un - mortality(i,j) )
+
+                   END IF ! PFTpresent(i,j)
+
+                ENDIF !( control%ok_dgvm .OR. .NOT.control%ok_constant_mortality)
+
+             END IF ! (forest_managed(i,j) == 0)
+
+          END DO ! loop over land points
+
+
+       !! 2. Grasses mortality
+       ELSE 
+
+          ! For grasses, if last year's NPP is very small (less than 10 gCm^{-2}year{-1})
+          ! the grasses completely die
+          IF ( .NOT.control%ok_dgvm .AND. .NOT.control%ok_constant_mortality) THEN
+
+             DO  i = 1,npts ! loop over land_points
+
+                IF ( PFTpresent(i,j) .AND. &
+                     ( npp_longterm(i,j) .LE. npp_longterm_init ) ) THEN
+
+                   mortality = zero
+
+                END IF
+
+                ! Update biomass and litter pools
+                DO m = 1,nelements
+
+                   DO k = 1, nparts
+
+                      IF ( PFTpresent(i,j) ) THEN
+
+                         dmortality(i) =  mortality(i,j) * biomass(i,j,k,m)
+                         bm_to_litter(i,j,k,m) = bm_to_litter(i,j,k,m) + dmortality(i)
+                         biomass(i,j,k,m) = biomass(i,j,k,m) - dmortality(i)
+
+                      END IF ! PFTpresent(i,j)
+
+                   ENDDO ! nparts
+
+                END DO !nelements
+
+             END DO ! loop over land points
+
+          ENDIF ! .NOT.control%ok_dgvm .AND. .NOT.control%ok_constant_mortality
+
+       ENDIF   !IF ( is_tree(j) )
+
+    ENDDO      !loop over pfts
+
+
+    !! 3. Write to history files
+       
+    ! output in fraction of trees that dies/day.
+    mortality(:,:) = mortality(:,:) / dt
+    
+    CALL xios_orchidee_send_field("MORTALITY",mortality)
+
+    CALL histwrite_p (hist_id_stomate, 'MORTALITY', itime, &
+         mortality, npts*nvm, horipft_index)
+    
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving gap'
+       
+  END SUBROUTINE gap_diagnostic
+
+
+END MODULE lpj_gap
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_kill.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_kill.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_kill.f90	(revision 7236)
@@ -0,0 +1,266 @@
+! =================================================================================================================================
+! MODULE       : lpj_kill
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         Kills natural PFTs with low biomass and low number of individuals. 
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	:
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+
+MODULE lpj_kill
+
+  ! modules used:
+
+  USE ioipsl_para
+  USE stomate_data
+  USE pft_parameters
+  USE constantes
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC kill_diagnostic
+
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE  : kill_diagnostic
+!!
+!>\BRIEF       Kills natural pfts that have low biomass or low number of individuals, 
+!! returns biomass to litter pools,  and resets biomass to zero.  
+!!
+!! DESCRIPTION : Kills natural PFTS. The PFT vegetation characteristics are
+!! reinitialized. Kill is either done in DGVM mode or in non-DGVM mode
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): senescence, PFTpresent, cn_ind, ind, RIP_time, age, when_growthinit, 
+!! everywhere,beget, veget_max, npp_longterm, biomass, bm_to_litter, leaf_age, leaf_frac
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE kill_diagnostic (npts, whichroutine, lm_lastyearmax, &
+       ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
+       age, leaf_age, leaf_frac, npp_longterm, &
+       when_growthinit, everywhere, veget_max, bm_to_litter)
+
+ !! 0. Variable and parameter description
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                                :: npts            !! Domain size (unitless)
+    CHARACTER(LEN=10), INTENT(in)                             :: whichroutine    !! Message (unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: lm_lastyearmax  !! Last year's maximum leaf mass, for each PFT 
+                                                                                 !! @tex $(gC.m^{-2})$ @endtex
+
+    !! 0.2 Output variables
+
+
+    !! 0.3 Modified variables
+
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)               :: senescence      !! Is the plant senescent? (only for deciduous 
+                                                                                 !! trees - carbohydrate reserve) (true/false)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)               :: PFTpresent      !! Is pft there (true/false)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: cn_ind          !! Crown area of individuals 
+                                                                                 !! @tex $(m^2)$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: ind             !! Number of individuals 
+                                                                                 !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: RIP_time        !! How much time ago was the PFT eliminated for
+                                                                                 !! the last time (y)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: age             !! Mean age (years)  
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: when_growthinit !! How many days ago was the beginning of the 
+                                                                                 !! growing season (days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: everywhere      !! Is the PFT everywhere in the grid box or very
+                                                                                 !! localized (after its introduction)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: veget_max       !! "Maximal" coverage fraction of a PFT (LAI -> 
+                                                                                 !! infinity) on ground (unitless;0-1)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: npp_longterm    !! "Long term" (default = 3-year) net primary 
+                                                                                 !! productivity 
+                                                                                 !! @tex $(gC.m^{-2} year^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout) :: leaf_age        !! Leaf age (days)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout) :: leaf_frac       !! Fraction of leaves in leaf age class 
+                                                                                 !! (unitless;0-1)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                                INTENT(inout) :: biomass         !! Biomass @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                                INTENT(inout) :: bm_to_litter    !! Conversion of biomass to litter 
+                                                                                 !! @tex $(gC.m^{-2} day^{-1})$ @endtex
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                            :: j,m             !! Indices       (unitless)
+    LOGICAL, DIMENSION(npts)                                  :: was_killed      !! Bookkeeping   (true/false)
+
+!_ ================================================================================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering kill'
+
+ !! 1. Kill PFTs
+
+    ! Kill 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 processor
+    DO j = 2,nvm ! loop plant functional types
+
+       was_killed(:) = .FALSE.
+
+       IF ( natural(j) ) THEN
+
+          !! 1.1 Kill natural PFTs when DGVM is activated
+          IF ( control%ok_dgvm ) THEN
+             WHERE ( PFTpresent(:,j) .AND. &
+                  ( ( ind(:,j) .LT. min_stomate ) .OR. &
+                  ( lm_lastyearmax(:,j) .LT. min_stomate ) ) )
+             
+                was_killed(:) = .TRUE.
+             
+             ENDWHERE
+          
+          ELSE
+
+             !! 1.2 Kill natural PFTs when running STOMATE without DGVM
+
+             !! 1.2.1 Kill PFTs
+             WHERE ( PFTpresent(:,j) .AND. & 
+                  (biomass(:,j,icarbres,icarbon) .LE.zero .OR. & 
+                  biomass(:,j,iroot,icarbon).LT.-min_stomate .OR. biomass(:,j,ileaf,icarbon).LT.-min_stomate ).AND. & 
+                  ind(:,j).GT. zero)
+
+                was_killed(:) = .TRUE.
+
+             ENDWHERE
+
+             !! 1.2.2 Overwrite long-term NPP for grasses
+             IF(.NOT.is_tree(j).AND..NOT.control%ok_constant_mortality)THEN
+                WHERE ( was_killed(:) )
+
+                   npp_longterm(:,j) = 500.
+
+                ENDWHERE
+             ENDIF
+
+          ENDIF ! control%ok_dgvm
+
+          !! 1.3 Bookkeeping for PFTs that were killed
+          !      For PFTs that were killed, return biomass pools to litter 
+          !      and update biomass pools to zero
+          IF ( ANY( was_killed(:) ) ) THEN
+          
+             DO m = 1,nelements
+
+                WHERE ( was_killed(:) )
+
+                   bm_to_litter(:,j,ileaf,m) = bm_to_litter(:,j,ileaf,m) + biomass(:,j,ileaf,m)
+                   bm_to_litter(:,j,isapabove,m) = bm_to_litter(:,j,isapabove,m) + biomass(:,j,isapabove,m)
+                   bm_to_litter(:,j,isapbelow,m) = bm_to_litter(:,j,isapbelow,m) + biomass(:,j,isapbelow,m)
+                   bm_to_litter(:,j,iheartabove,m) = bm_to_litter(:,j,iheartabove,m) + &
+                                                     biomass(:,j,iheartabove,m)
+                   bm_to_litter(:,j,iheartbelow,m) = bm_to_litter(:,j,iheartbelow,m) + &
+                                                     biomass(:,j,iheartbelow,m)
+                   bm_to_litter(:,j,iroot,m) = bm_to_litter(:,j,iroot,m) + biomass(:,j,iroot,m)
+                   bm_to_litter(:,j,ifruit,m) = bm_to_litter(:,j,ifruit,m) + biomass(:,j,ifruit,m)
+                   bm_to_litter(:,j,icarbres,m) = bm_to_litter(:,j,icarbres,m) + biomass(:,j,icarbres,m)
+                   
+                   biomass(:,j,ileaf,m) = zero
+                   biomass(:,j,isapabove,m) = zero
+                   biomass(:,j,isapbelow,m) = zero
+                   biomass(:,j,iheartabove,m) = zero
+                   biomass(:,j,iheartbelow,m) = zero
+                   biomass(:,j,iroot,m) = zero
+                   biomass(:,j,ifruit,m) = zero
+                   biomass(:,j,icarbres,m) = zero
+
+                ENDWHERE   ! was_killed
+
+             END DO
+
+            !! 1.4 Update veget_max in DGVM
+            !      Update veget_max in DGVM for killed PFTs and reset RIP_time
+            IF (control%ok_dgvm) THEN
+
+                WHERE ( was_killed(:) )
+                   PFTpresent(:,j) = .FALSE.
+
+                   veget_max(:,j) = zero
+                   
+                   RIP_time(:,j) = zero
+
+                ENDWHERE  ! was_killed
+
+            ENDIF ! control%ok_dgvm
+
+            !! 1.5 Reinitialize vegetation characteristics in DGVM and STOMATE
+            !      Reinitialize number of individuals, crown area and age
+            WHERE ( was_killed(:) )
+
+                ind(:,j) = zero
+
+                cn_ind(:,j) = zero
+
+                senescence(:,j) = .FALSE.
+
+                age(:,j) = zero
+
+                ! SZ: why undef ??? this causes a delay in reestablishment
+                !when_growthinit(:,j) = undef
+                when_growthinit(:,j) = large_value 
+
+                everywhere(:,j) = zero
+
+!                veget(:,j) = zero
+!MM Ã  imposer ?!
+!                lai(:,j) = zero
+
+             ENDWHERE   ! was_killed
+
+             !! 1.6 Update leaf ages
+             DO m = 1, nleafages
+
+                WHERE ( was_killed(:) )
+
+                   leaf_age(:,j,m) = zero 
+                   leaf_frac(:,j,m) = zero 
+
+                ENDWHERE ! was_killed
+
+             ENDDO
+
+             !! 1.7 Print sub routine messages
+             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_diagnostic
+
+END MODULE lpj_kill
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_light.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_light.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_light.f90	(revision 7236)
@@ -0,0 +1,672 @@
+! =================================================================================================================================
+! MODULE       : lpj_light
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+!                This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Light competition within a PFT
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	:
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE lpj_light
+
+  ! modules used:
+  USE xios_orchidee
+  USE ioipsl_para
+  USE constantes
+  USE stomate_data
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC light, light_clear
+
+  LOGICAL, SAVE                                            :: firstcall = .TRUE.             !! first call
+!$OMP THREADPRIVATE(firstcall)
+
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE   : light_clear
+!!
+!>\BRIEF          Activation
+!!
+!_ ================================================================================================================================
+
+  SUBROUTINE light_clear
+    firstcall=.TRUE.
+  END SUBROUTINE light_clear
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: light
+!!
+!>\BRIEF         Light competition within a PFT
+!!
+!! DESCRIPTION  : This module kills PFTs based on light competition
+!! 
+!! Here, fpc ("foilage projected cover") 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 too strong cutbacks.\n
+!!
+!! fpc is now always calculated from lm_lastyearmax*sla, since the aim of this DGVM is 
+!! to represent community ecology effects; seasonal variations in establishment related to phenology
+!! may be relevant, but beyond the scope of a 1st generation DGVM.\n
+!!
+!! If agriculture is present, fpc can never reach 1.0 since natural veget_max < 1.0. To
+!! correct for this, ::ind must be recalculated to correspond to the natural density.
+!! since ::ind is expressed in m^{-2} grid cell, this can be achieved by dividing individual 
+!! density by the agricultural fraction.\n
+!!
+!! The flow in the routine is different for ::control%ok_dgvm. When ::control%ok_dgvm is true
+!! the following processes are considered:
+!!
+!! 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.\n
+!!
+!! When ::control%ok_dgvm is false then light competition is calculated for the static case if the mortality is not 
+!! assumed to be constant. The following processes are considered: XXX
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ind, biomass, veget_lastlight, bm_to_litter, mortality
+!!
+!! REFERENCES   : 
+!! - Sitch, S., B. Smith, et al. (2003), Evaluation of ecosystem dynamics,
+!! plant geography and terrestrial carbon cycling in the LPJ dynamic 
+!! global vegetation model, Global Change Biology, 9, 161-185.\n
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE light (npts, dt, &
+       veget_max, fpc_max, PFTpresent, cn_ind, lai, maxfpc_lastyear, &
+       lm_lastyearmax, ind, biomass, veget_lastlight, bm_to_litter, mortality)
+
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                             :: npts                     !! Domain size (unitless)      
+    REAL(r_std), INTENT(in)                                :: dt                       !! Time step (days)      
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent               !! TRUE if pft is present (true/false)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: cn_ind                   !! Crown area of individuals 
+                                                                                       !! @tex $(m^2)$ @endtex  
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: lai                      !! Leaf area index OF AN INDIVIDUAL PLANT 
+                                                                                       !! @tex $(m^2 m^{-2})$ @endtex   
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: maxfpc_lastyear          !! Last year's maximum fpc for each natural 
+                                                                                       !! PFT(unitless)  
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: lm_lastyearmax           !! Last year's maximum leafmass for each 
+                                                                                       !! natural PFT 
+                                                                                       !! @tex $(gC m^2 s^{-1})$ @endtex   
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: veget_max                !! Last year's maximum fpc for each natural 
+                                                                                       !! PFT (unitless;0-1)   
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: fpc_max                  !! Last year's maximum fpc for each natural 
+                                                                                       !! PFT (unitless)    
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+   
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: ind                      !! Number of individuals 
+                                                                                       !! @tex $(m^{-2})$ @endtex    
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(inout) :: biomass        !! Biomass @tex $(gCm^{-2})$ @endtex    
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: veget_lastlight          !! Vegetation cover after last light 
+                                                                                       !! competition (unitless;0-1)     
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(inout) :: bm_to_litter   !! Biomass transfer to litter per timestep
+                                                                                       !! @tex $(gCm^{-2})$ @endtex    
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: mortality                !! Fraction of individuals that died this 
+                                                                                       !! time step per dt (unitless;0-1)   
+
+    !! 0.4 Local variables
+
+    LOGICAL, PARAMETER                                     :: annual_increase = .TRUE. !! For diagnosis of fpc increase, compare 
+                                                                                       !! today's fpc to last year's  Maximum (T)
+                                                                                       !! or to fpc of last time step (F) 
+    INTEGER(i_std)                                         :: i,j,k,m                  !! Index (unitless)    
+    REAL(r_std), DIMENSION(npts)                           :: sumfpc                   !! Total natural fpc, sum of all the PFTs
+                                                                                       !! (unitless)   
+    REAL(r_std), DIMENSION(npts)                           :: fracnat                  !! Fraction of natural vegetation within a 
+                                                                                       !! grid cell (unitless;0-1)   
+    REAL(r_std)                                            :: sumfpc_wood              !! Total natural woody fpc (unitless)   
+    REAL(r_std)                                            :: sumdelta_fpc_wood        !! Change in total woody fpc (unitless)   
+    REAL(r_std)                                            :: maxfpc_wood              !! Maximum wood fpc (unitless)   
+    INTEGER(i_std)                                         :: optpft_wood              !! Which woody pft is maximum (unitless)   
+    REAL(r_std)                                            :: sumfpc_grass             !! Total natural grass fpc (unitless)   
+    REAL(r_std), DIMENSION(npts,nvm)                       :: fpc_nat                  !! This year's foliage projected cover on 
+                                                                                       !! natural part of the grid cell 
+                                                                                       !! @tex $(m^2)$ @endtex
+    REAL(r_std), DIMENSION(nvm)                            :: deltafpc                 !! fpc change within last year (unitless)    
+    REAL(r_std)                                            :: reduct                   !! Relative change of number of individuals
+                                                                                       !! for trees (ind)    
+    REAL(r_std), DIMENSION(nvm)                            :: survive                  !! Fraction of plants that survive 
+                                                                                       !! (unitless;0-1)     
+    REAL(r_std), DIMENSION(npts)                           :: fpc_real                 !! FPC for static mode (unitless)     
+    REAL(r_std), DIMENSION(npts)                           :: lai_ind                  !! FPC mortality for static mode     
+    REAL(r_std)                                            :: sumfpc_grass2            !! New total grass fpc     
+    REAL(r_std), DIMENSION(npts,nvm)                       :: light_death              !! Fraction of plants that dies each day 
+                                                                                       !! @tex $(day^{-1})$ @endtex     
+    REAL(r_std)                                            :: fpc_dec                  !! Relative change of number of individuals 
+                                                                                       !! for trees
+!_ ================================================================================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering light'
+
+    
+ !! 1. Write diagnostics to out_orchidee files
+  
+    IF ( firstcall ) THEN
+
+       WRITE(numout,*) 'light:'
+
+       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. Light competition in DGVM
+
+    IF (control%ok_dgvm) THEN
+             
+       !! 2.1 Calculate natural part of the grid cell
+       fracnat(:) = un
+       DO j = 2,nvm
+          IF ( .NOT. natural(j) ) THEN
+             fracnat(:) = fracnat(:) - veget_max(:,j)
+          ENDIF
+       ENDDO
+       
+       !! 2.2 Calculate fpc on natural part of grid cell
+       fpc_nat(:,:) = zero
+       fpc_nat(:,ibare_sechiba) = un
+
+       DO j = 2, nvm ! loop over #PFTs
+
+
+          !! 2.2.1 Natural PFTs
+          IF ( natural(j) ) THEN
+   
+             !!?? it seems that the treatment below for trees and grasses are the same? so there is no necessity to use IF...ELSE...ENDIF structure?
+	     !!?? CODE SHOULD BE CLEANED UP BELOW
+
+             !! 2.2.1.1 Trees
+             IF ( is_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
+                !NV : modif from SZ version : fpc is based on veget_max, not veget.
+
+                WHERE(fracnat(:).GE.min_stomate)
+
+                   !            WHERE(LAI(:,j) == val_exp)
+                   !               fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:)
+                   !            ELSEWHERE
+                   !               fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:) * &
+                   !                    MAX( ( 1._r_std - exp( - lm_lastyearmax(:,j) * sla(j) * ext_coeff(j) ) ), min_cover )
+                   !            ENDWHERE
+
+                   fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:)
+                ENDWHERE
+
+             ELSE
+
+                !NV : modif from SZ version : fpc is based on veget_max, not veget.
+		!!?? DO GRASSES HAVE CROWNS?
+                
+                !! 2.2.1.1 Grasses
+                WHERE(fracnat(:).GE.min_stomate)
+
+                   !            WHERE(LAI(:,j) == val_exp)
+                   !               fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:)
+                   !            ELSEWHERE
+                   !               fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:) * &
+                   !                    ( 1._r_std - exp( - lm_lastyearmax(:,j) * sla(j) * ext_coeff(j) ) )
+                   !            ENDWHERE
+
+                   fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:)
+                ENDWHERE
+
+!!!$                ! 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.2.2 Agricultural PFTs
+             !        Agriculural PFTs are not present on natural part
+             fpc_nat(:,j) = zero
+
+          ENDIF    ! natural/agricultural
+
+       ENDDO
+
+       
+       !! 2.3 Total fpc for grid point
+       sumfpc(:) = zero
+       DO j = 2,nvm
+
+          !SZ bug correction MERGE: need to subtract agricultural area!
+          sumfpc(:) = sumfpc(:) + fpc_nat(:,j)
+       ENDDO
+
+       
+       !! 2.4 Light competition
+
+       light_death(:,:) = zero
+
+       DO i = 1, npts ! SZ why this loop and not a vector statement ?
+
+          !! 2.4.1 Dense canopy 
+          IF ( sumfpc(i) .GT. fpc_crit ) THEN
+
+             ! 2.4.1.1 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,:)),  zero )
+             ELSE
+                deltafpc(:) = MAX( (fpc_nat(i,:)-veget_lastlight(i,:)),  zero )
+             ENDIF
+
+             !! 2.4.1.2 Default survival
+             survive(:) = un
+
+             
+             !! 2.4.1.3 Determine some characteristics of the fpc distribution
+             sumfpc_wood = zero
+             sumdelta_fpc_wood = zero
+             maxfpc_wood = zero
+             optpft_wood = 0
+             sumfpc_grass = zero
+
+             DO j = 2,nvm ! loop over #PFTs
+
+                IF(veget_max(i,j) == zero)THEN
+                   ! this vegetation type is not present, so no reason to do the 
+                   ! calculation
+                   CYCLE
+                ENDIF
+
+                !! 2.4.1.3.1 Natural pfts
+                IF ( natural(j) ) THEN
+
+                   !! 2.4.1.3.1.1 Trees
+                   IF ( is_tree(j) ) THEN
+
+                      ! 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
+
+                      !! 2.4.1.3.1.2 Grasses
+                      ! total (natural) grass fpc
+                      sumfpc_grass = sumfpc_grass + fpc_nat(i,j)
+
+                   ENDIF   ! tree or grass
+
+                ENDIF   ! natural
+
+             ENDDO  ! loop over pfts
+
+             !! 2.4.1.4 Wood outcompetes grass
+             !          Light competition where wood outcompetes grasses
+             
+             !SZ             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 ! Loop over #PFTs
+
+
+                IF(veget_max(i,j) == zero)THEN
+                   ! this vegetation type is not present, so no reason to do the 
+                   ! calculation
+                   CYCLE
+                ENDIF
+
+
+                ! only present and natural pfts compete
+                IF ( PFTpresent(i,j) .AND. natural(j) ) THEN
+
+                   !! 2.4.1.4.1 Trees
+                   IF ( is_tree(j) ) THEN
+
+                      ! no single woody pft is overwhelming
+                      ! (original DGVM: tree_mercy = 0.0 )
+                      ! The reduction rate is proportional to the ratio deltafpc/fpc.
+                      IF (sumfpc_wood .GE. fpc_crit .AND. fpc_nat(i,j) .GT. min_stomate .AND. & 
+                           sumdelta_fpc_wood .GT. min_stomate) THEN
+
+                         ! reduct = MIN( ( ( deltafpc(j)/sumdelta_fpc_wood * &
+                         !     (sumfpc_wood-fpc_crit) ) / fpc_nat(i,j) ), &
+                         !     ( 1._r_std - 0.01 ) ) ! (0.01 = tree_mercy previously)
+
+                         !!? difficult to fully understand but doesn't look so simple
+                         reduct = un - MIN((fpc_nat(i,j)-(sumfpc_wood-fpc_crit) & 
+                              * deltafpc(j)/sumdelta_fpc_wood)/fpc_nat(i,j), un )
+
+                      ELSE
+
+                         ! tree fpc didn't icrease or it started from nothing
+                         reduct = zero
+
+                      ENDIF
+                   ELSE
+
+                      !! 2.4.1.4.2 Grasses 
+                      !            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.
+                      !
+
+                      IF(sumfpc_grass .GE. un-MIN(fpc_crit,sumfpc_wood).AND. & 
+                           sumfpc_grass.GE.min_stomate) THEN
+
+                         fpc_dec = (sumfpc_grass - un + MIN(fpc_crit,sumfpc_wood))*fpc_nat(i,j)/sumfpc_grass
+
+                         reduct = fpc_dec
+                      ELSE 
+                         reduct = zero
+                      ENDIF
+                   ENDIF   ! tree or grass
+
+                   survive(j) = un - reduct
+                ENDIF     ! pft there and natural
+
+             ENDDO       ! loop over pfts
+
+             !SZ
+!!!$          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 ( is_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
+
+             
+             !! 2.4.1.5 Update biomass and litter pools
+             
+             DO j = 2,nvm ! Loop over #PFTs
+
+
+                IF(veget_max(i,j) == zero)THEN
+                   ! this vegetation type is not present, so no reason to do the 
+                   ! calculation
+                   CYCLE
+                ENDIF
+
+
+                ! Natural PFTs
+                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)
+
+                   !? We are in a section where ok_dgvm is already at TRUE: No need to test it again
+                   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) / 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
+
+       
+       !! 2.5 Recalculate fpc for natural PFTs
+       !      Recalculate fpc on natural part of the grid cell for next light competition
+       DO j = 2,nvm ! loop over #PFT
+
+
+          IF(veget_max(i,j) == zero)THEN
+               ! this vegetation type is not present, so no reason to do the 
+               ! calculation
+               CYCLE
+          ENDIF
+
+
+          !! 2.5.1 Natural PFTs
+          IF ( natural(j) ) THEN
+ 
+             !! 2.5.1.1 Trees
+             IF ( is_tree(j) ) THEN
+
+                DO i = 1, npts
+
+                   !NVMODIF         
+                   !    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( ( un - exp( -lai(i,j) * ext_coeff(j) ) ), min_cover )
+                   !             ENDIF
+                   !!                veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j)
+ 
+                   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( ( un - EXP( - lm_lastyearmax(i,j) * sla(j) * ext_coeff(j) ) ), min_cover )
+                   ENDIF
+                ENDDO
+
+             ELSE
+
+                !! 2.5.1.2 Grasses
+                DO i = 1, npts
+
+                   !NVMODIF         
+                   !            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
+                   !!veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j) 
+
+                   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( - lm_lastyearmax(i,j) * sla(j) * ext_coeff(j) ) )
+                   ENDIF
+                ENDDO
+             ENDIF    ! tree/grass
+
+          ELSE
+
+             !! 2.5.2 Agricultural PFTs
+             !        Agricultural PFTs are not present on the natural part of the grid point
+             veget_lastlight(:,j) = zero
+
+          ENDIF  ! natural/agricultural
+
+       ENDDO ! # PFTs
+
+    ELSE ! control%ok_dgvm
+
+ !! 3. Light competition in stomate (without DGVM)
+
+       light_death(:,:) = zero
+
+       DO j = 2, nvm 
+
+          IF(veget_max(i,j) == zero)THEN
+              ! this vegetation type is not present, so no reason to do the 
+              ! calculation
+              CYCLE
+          ENDIF
+
+
+          IF ( natural(j) ) THEN
+
+	     !! NUMBERING BELOW SHOULD BE 5.0 or 4.3
+             !! 2.1.1 natural PFTs, in the one PFT only case there needs to be no special case for grasses,
+             !! neither a redistribution of mortality (delta fpc)
+             
+             !! 3.1 XXX
+             WHERE( ind(:,j)*cn_ind(:,j) .GT. min_stomate ) 
+                lai_ind(:) = sla(j) * lm_lastyearmax(:,j) / ( ind(:,j) * cn_ind(:,j) )
+             ELSEWHERE
+                lai_ind(:) = zero
+             ENDWHERE
+
+             fpc_nat(:,j) =  cn_ind(:,j) * ind(:,j) * & 
+                  MAX( ( un - exp( - ext_coeff(j) * lai_ind(:) ) ), min_cover )
+
+             WHERE(fpc_nat(:,j).GT.fpc_max(:,j))
+
+                light_death(:,j) = MIN(un, un - fpc_max(:,j)/fpc_nat(:,j)) 
+
+             ENDWHERE
+
+             !! 3.2 Update biomass and litter pools
+             DO m = 1,nelements
+                DO k=1,nparts
+                   
+                   bm_to_litter(:,j,k,m) = bm_to_litter(:,j,k,m) + light_death(:,j)*biomass(:,j,k,m)
+                   biomass(:,j,k,m) = biomass(:,j,k,m) - light_death(:,j)*biomass(:,j,k,m)
+                   
+                ENDDO
+             END DO
+
+             !! 3.3 Update number of individuals
+             ind(:,j) = ind(:,j)-light_death(:,j)*ind(:,j)
+
+          ENDIF
+       ENDDO
+
+       light_death(:,:) = light_death(:,:)/dt
+
+    ENDIF ! control%ok_dgvm
+
+   
+ !! 4. Write history files
+    CALL xios_orchidee_send_field("LIGHT_DEATH",light_death)
+
+    CALL histwrite_p (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: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_pftinout.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_pftinout.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/lpj_pftinout.f90	(revision 7236)
@@ -0,0 +1,484 @@
+! =================================================================================================================================
+! MODULE       : lpj_pftinout
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Introduce and eliminate PFT's from pixel
+!!
+!! \n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S) : None 
+!!
+!! REFERENCE(S) :
+!! - Sitch, S., B. Smith, et al. (2003), Evaluation of ecosystem dynamics,
+!!        plant geography and terrestrial carbon cycling in the LPJ dynamic 
+!!        global vegetation model, Global Change Biology, 9, 161-185.\n
+!! - Thonicke, K., S. Venevsky, et al. (2001), The role of fire disturbance 
+!!        for global vegetation dynamics: coupling fire into a Dynamic Global
+!!        Vegetation Model, Global Ecology and Biogeography, 10, 661-677.\n
+!! - Haxeltine, A. and I. C. Prentice (1996), BIOME3: An equilibrium
+!!        terrestrial biosphere model based on ecophysiological constraints, 
+!!        resource availability, and competition among plant functional types,
+!!        Global Biogeochemical Cycles, 10(4), 693-709.\n
+!! - Smith, B., I. C. Prentice, et al. (2001), Representation of vegetation
+!!        dynamics in the modelling of terrestrial ecosystems: comparing two
+!!        contrasting approaches within European climate space,
+!!        Global Ecology and Biogeography, 10, 621-637.\n
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ==============================================================================================================================
+
+MODULE lpj_pftinout
+
+  ! modules used:
+
+  USE ioipsl_para
+  USE stomate_data
+  USE pft_parameters
+  USE constantes
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC pftinout,pftinout_clear
+
+  LOGICAL, SAVE                       :: firstcall = .TRUE.                !! first call
+!$OMP THREADPRIVATE(firstcall)
+
+CONTAINS
+
+
+!! ================================================================================================================================
+!! SUBROUTINE  : pftinout_clear
+!!
+!>\BRIEF       Set flag ::firstcall to true and initialize the variables
+!_ ================================================================================================================================
+
+  SUBROUTINE pftinout_clear
+    firstcall = .TRUE.
+  END SUBROUTINE pftinout_clear
+
+!! ================================================================================================================================ 
+!! SUBROUTINE  : pftinout
+!! 
+!>\BRIEF       Introduce and eliminate PFT's from pixel
+!!
+!! DESCRIPTION**3 : Introduction and elimination of PFTs on the basis of climate condition.
+!! For natural and woody PFTs the foliage projected coverage is calculated as follows:
+!! \latexonly
+!!  \input{equation_lpj_pftinout.tex}
+!! \endlatexonly
+!! \n
+!! where FPC is foliage projective cover (::fpc_nat), CN crown area (::cn_ind, 
+!! @tex $ m^{2} $ @endtex), IND number of individuals (::ind, @tex $ m^{-2} $ @endtex,
+!! FRAC total fraction occupied by natural vegetation (::fracnat),
+!! @tex $ LM_{rm max} $ @endtex maximum leaf mass in last year
+!! (::lm_lastyearmax, @tex $ g C m^{-2} $ @endtex), SLA specific leaf area (sla,
+!! @tex $ m^{2} (g C)^{-1} $ @endtex), and coff coefficient (::ext_coeff). ::ext_coeff 
+!! describes a property of the canopy (i.e. law of Lambert-Beer) and is defined in **2
+!!
+!! The foliage projective cover feeds into the calculation of the space available for 
+!! expansion of existing and dispersion of new PFTs within a gridbox. In turn, available
+!! space is use to calculate the number of individuals with a PFT. 
+!!
+!! Saplings are introduced under the condition that winter temperature is 
+!! moderate, plant age is older than 1.25, (and for some PFTs at least one adjacent grid 
+!! box exists for expansion), new saplings are introduced for narural PFT. In the simulation of 
+!! agricultural grassland, if target PFT does not exist in the gridbox, it is introduced 
+!! regardless of climate condition. When a new PFT is introduced CO_2 is taken from the
+!! atmosphere to account for CO_2 present in the seed and required by the germinated seeds
+!! to establish a sapling. These initial phases in ontology are not accounted for. However,
+!! by taking this small amount of CO2 from the atmosphere, mass balance closure for C is
+!! preserved. 
+!!
+!! PFTs are eliminated under the condition that they are no longer adapted to the critical 
+!! temperatures in winter. When a PFT is eliminated its number of indiviuals is set to zero and
+!! the rest of the elimination process is taken care of in lpj_kill.f90.
+!! 
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): :: avail_tree (space availability for trees, unitless),   
+!! :: avail_grass (space availability for grasses, unitless), :: biomass (biomass, \f$gC m^{-2}\f$) 
+!! and :: ind (density of individuals, \f$m^{-2}\f$)    
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    :
+!! \latexonly
+!!   \includegraphics[scale = 0.6]{pftinout.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+
+
+
+
+
+  SUBROUTINE pftinout (npts, dt, adapted, regenerate, &
+       neighbours, veget_max, &
+       biomass, ind, cn_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. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+    
+    INTEGER(i_std), INTENT(in)                                :: npts            !! Domain size - number of pixels (unitless)            
+    REAL(r_std), INTENT(in)                                   :: dt              !! Time step of vegetation dynamics for stomate
+                                                                                 !! (days)               
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: adapted         !! Winter not too cold (unitless)   
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: regenerate      !! Winter sufficiently cold (unitless)  
+    INTEGER(i_std), DIMENSION(npts,8), INTENT(in)             :: neighbours      !! Indices of the 8 neighbours of each grid point
+                                                                                 !! (unitless); 1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 
+                                                                                 !! 7=W, 8=NW       
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: veget_max       !! "maximal" coverage fraction of a PFT (LAI ->
+                                                                                 !! infinity) on ground (unitless)        
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(npts), INTENT(out)                 :: avail_tree      !! Space availability for trees (unitless)   
+    REAL(r_std), DIMENSION(npts), INTENT(out)                 :: avail_grass     !! Space availability for grasses (unitless)      
+
+
+    !! 0.3 Modified variables   
+
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(inout) :: biomass  !! Biomass (gC m^{-2})      
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: ind             !! Density of individuals (m^{-2})
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: cn_ind          !! Crown area of individuals (m^2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: age             !! Mean age (years)            
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout) :: leaf_frac       !! Fraction of leaves in leaf age class (unitless)  
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: npp_longterm    !! "long term" net primary productivity 
+                                                                                 !! (gC m^{-2} year^{-1})   
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: lm_lastyearmax  !! Last year's maximum leaf mass, for each PFT 
+                                                                                 !! (gC m^{-2})  
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)               :: senescence      !! Plant senescent for deciduous trees; .FALSE. 
+                                                                                 !! if PFT is introduced or killed      
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)               :: PFTpresent      !! PFT exists    
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: everywhere      !! is the PFT everywhere in the grid box or very 
+                                                                                 !! localized (unitless)  
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: when_growthinit !! how many days ago was the beginning of the 
+                                                                                 !! growing season (days) 
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)               :: need_adjacent   !! in order for this PFT to be introduced, does it
+                                                                                 !! have to be present in an adjacent grid box?   
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: RIP_time        !! How much time ago was the PFT eliminated for 
+                                                                                 !! the last time (years)    
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: co2_to_bm       !! biomass uptaken (gC m^{-2} day^{-1})        
+ 
+    !! 0.4 Local variables
+
+    REAL(r_std), DIMENSION(npts)                              :: avail           !! availability           
+    INTEGER(i_std)                                            :: i,j,m           !! indices      
+    REAL(r_std), DIMENSION(npts)                              :: sumfrac_wood    !! total woody vegetation cover     
+    INTEGER(i_std), DIMENSION(npts)                           :: n_present       !! number of adjacent grid cells where PFT is 
+                                                                                 !! ubiquitous        
+    LOGICAL, DIMENSION(npts)                                  :: can_introduce   !! we can introduce this PFT    
+    REAL(r_std), DIMENSION(npts)                              :: fracnat         !! no real need for dimension(ntps) except for 
+                                                                                 !! vectorisation          
+!_ ================================================================================================================================
+
+    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. Total woody fpc and space avaibility on grid
+
+    ! Only natural part of the grid cell\n
+    ! SZ bug correction MERGE: need to subtract agricultural area!
+    ! fraction of agricultural surface
+
+    !! 2.1 only natural PFT
+    fracnat(:) = un
+    DO j = 2,nvm ! Loop over # PFTs
+       IF ( .NOT. natural(j) ) THEN
+          fracnat(:) = fracnat(:) - veget_max(:,j)
+       ENDIF
+    ENDDO ! Loop over # PFTs
+
+    !! 2.2 Total woody fractional plant cover
+    sumfrac_wood(:) = zero
+    DO j = 2,nvm ! Loop over # PFTs
+       
+       ! SZ problem here: agriculture, not convinced that this representation of LPJ is correct
+       ! if agriculture is present, ind must be recalculated to correspond to the natural density...
+       ! since ind is per grid cell, can be achived by discounting for agricultura fraction
+       IF ( natural(j).AND.is_tree(j) ) THEN
+          WHERE(fracnat(:).GT.min_stomate) 
+                sumfrac_wood(:) = sumfrac_wood(:) + cn_ind(:,j) * ind(:,j) / fracnat(:) & 
+                     * ( un - exp( - lm_lastyearmax(:,j) * sla(j) * ext_coeff(j) ) )
+                !lai changed to lm_last
+          ENDWHERE
+       ENDIF
+    ENDDO ! Loop over # PFTs
+
+    !! 2.3 Space availability
+    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
+
+    ! Agricultural PFTs are only present if they are prescribed
+    DO j = 2,nvm ! Loop over # PFTs
+       
+       IF ( .NOT. natural(j) ) THEN
+          
+          IF (bavard.GE.4) WRITE(numout,*) 'pftinout: Agricultural PFTs'
+          
+          !! 4.1 Agricultural trees
+          !      Agricultural trees are not treated for the moment
+          IF ( is_tree(j) ) THEN
+
+             WRITE(numout,*) 'pftinout: Agricultural trees not treated. We stop.'
+             STOP
+
+          !! 4.2 Initialization of agricultural grass lands
+          !      Initialize parameter values of prescribed agricultural PFTs
+          ELSE
+
+             DO i = 1, npts ! Loop over # pixels - domain size
+
+                IF ( ( veget_max(i,j) .GT. min_stomate ) .AND. ( .NOT. PFTpresent(i,j) ) ) THEN
+
+                   ! prescribed, but not yet there.
+                   ind(i,j) = veget_max(i,j)
+                   biomass(i,j,:,:) = bm_sapl_old(j,:,:) * ind(i,j) /veget_max(i,j) 
+                   co2_to_bm(i,j) =  co2_to_bm(i,j) +SUM( biomass(i,j,:,icarbon) ) / 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 # pixels - domain size
+
+          ENDIF
+
+       ENDIF ! not natural
+
+    ENDDO ! Loop over # PFTs
+
+  !! 5 Eliminate PFTs
+
+    DO j = 2,nvm ! Loop over # PFTs
+
+       ! only for natural PFTs
+       IF ( natural(j) ) THEN
+
+          ! Number of individuals are set to zero in the condition of cold winter   
+          ! 'adapted_crit' critical value for being adapted = 1.-(1./euler); see 'stomate_constants.f90'
+          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
+                   WRITE(6,*) 'jfieozje lpj_pftinout',ind
+
+       ENDIF ! natural
+
+    ENDDO ! Loop over # PFTs
+
+  !! 6. Introduce PFTs
+
+    DO j = 2,nvm ! Loop over # PFTs
+
+       IF ( natural(j) ) THEN
+
+          ! space availability for this PFT
+          IF ( is_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 ! Loop over # pixels - domain size
+
+             IF ( .NOT. PFTpresent(i,j) .AND. &
+                  ( adapted(i,j) .GT. adapted_crit ) .AND. &
+                  ( regenerate(i,j) .GT. regenerate_crit )  ) THEN
+
+                ! Seed are available nearby
+                IF ( need_adjacent(i,j) ) THEN
+
+                   !! 6.1.1 Climate allows introduction of the PFT but dispersion requires the 
+                   !        presence of seeds. Seed are considered available if at least one
+                   !        neighbouring pixel is entirely invaded by the PFT. If that condition is
+                   !        satisfied, the PFT can establish in the new pixel.
+                   ! 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 ubiquitous in at least one adjacent grid box
+                      can_introduce(i) = .TRUE.
+
+                   ENDIF
+
+                ELSE
+
+                   !! 6.1.2 No seed (trees) required for dispersion
+                   !        The PFT can establish without the presence of seed trees in 
+                   !        neighbouring pixels.
+                   can_introduce(i) = .TRUE.
+
+                ENDIF ! do we have to look at the neighbours?
+
+             ENDIF ! we'd like to introduce the PFT
+
+          ENDDO ! Loop over # pixels - domain size 
+
+          !! 6.2 Has the PFT been eliminated lately?
+          !      Additional test whether the PFT has been eliminated lately, i.e.
+          !      less than 1.25 years ago. Do not only take full years as success of
+          !      introduction, as introduction might depend on season.
+          WHERE ( RIP_time(:,j) .LT. RIP_time_min )
+
+             ! 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
+             ! initial density of individuals (ind_0) = 0.02, see 'stomate_constant.f90'
+             ind(:,j) = ind_0 * (dt/one_year) * avail(:)
+             
+             WHERE(veget_max(:,j) .GT. min_stomate)
+                biomass(:,j,ileaf,icarbon) = bm_sapl_old(j,ileaf,icarbon) * ind(:,j) /veget_max(:,j)
+                biomass(:,j,isapabove,icarbon) = bm_sapl_old(j,isapabove,icarbon) * ind(:,j) /veget_max(:,j)
+                biomass(:,j,isapbelow,icarbon) = bm_sapl_old(j,isapbelow,icarbon) * ind(:,j)/veget_max(:,j)
+                biomass(:,j,iheartabove,icarbon) = bm_sapl_old(j,iheartabove,icarbon) * ind(:,j)/veget_max(:,j)
+                biomass(:,j,iheartbelow,icarbon) = bm_sapl_old(j,iheartbelow,icarbon) * ind(:,j)/veget_max(:,j)
+                biomass(:,j,iroot,icarbon) = bm_sapl_old(j,iroot,icarbon) * ind(:,j)/veget_max(:,j)
+                biomass(:,j,ifruit,icarbon) = bm_sapl_old(j,ifruit,icarbon) * ind(:,j)/veget_max(:,j)
+                biomass(:,j,icarbres,icarbon) = bm_sapl_old(j,icarbres,icarbon) * ind(:,j)/veget_max(:,j)
+             ELSEWHERE              
+                biomass(:,j,ileaf,icarbon) = bm_sapl_old(j,ileaf,icarbon) * ind(:,j)
+                biomass(:,j,isapabove,icarbon) = bm_sapl_old(j,isapabove,icarbon) * ind(:,j)
+                biomass(:,j,isapbelow,icarbon) = bm_sapl_old(j,isapbelow,icarbon) * ind(:,j)
+                biomass(:,j,iheartabove,icarbon) = bm_sapl_old(j,iheartabove,icarbon) * ind(:,j)
+                biomass(:,j,iheartbelow,icarbon) = bm_sapl_old(j,iheartbelow,icarbon) * ind(:,j)
+                biomass(:,j,iroot,icarbon) = bm_sapl_old(j,iroot,icarbon) * ind(:,j)
+                biomass(:,j,ifruit,icarbon) = bm_sapl_old(j,ifruit,icarbon) * ind(:,j)
+                biomass(:,j,icarbres,icarbon) = bm_sapl_old(j,icarbres,icarbon) * ind(:,j)
+             END WHERE
+            
+             co2_to_bm(:,j) = &
+                  co2_to_bm(:,j) / dt * &
+                  ( biomass(:,j,ileaf,icarbon) + biomass(:,j,isapabove,icarbon) + &
+                  biomass(:,j,isapbelow,icarbon) + biomass(:,j,iheartabove,icarbon) + &
+                  biomass(:,j,iheartbelow,icarbon) + biomass(:,j,iroot,icarbon) + &
+                  biomass(:,j,ifruit,icarbon) + biomass(:,j,icarbres,icarbon) )
+
+             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) = npp_longterm_init
+
+             lm_lastyearmax(:,j) = bm_sapl_old(j,ileaf,icarbon) * ind(:,j)
+
+          ENDWHERE    ! we can introduce the PFT
+
+          !! 6.4 Expansion of the PFT within the grid box 
+          !      PFT expansion/dispersion to a new grid box should not be confused with 
+          !      expansion in areal coverage
+          IF ( treat_expansion ) THEN
+
+             WHERE ( can_introduce(:) )
+
+                ! low value at the beginning
+                everywhere(:,j) = everywhere_init
+             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
+
+    !   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: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/sapiens_agriculture.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/sapiens_agriculture.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/sapiens_agriculture.f90	(revision 7236)
@@ -0,0 +1,448 @@
+! ================================================================================================================================
+! MODULE       : sapiens_agriculture
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Simple approach to harvesting croplands
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S) : None
+!!
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_stomate/stomate_lpj.f90 $
+!! $Date: 2013-08-28 16:34:04 +0200 (Wed, 28 Aug 2013) $
+!! $Revision: 1438 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE sapiens_agriculture
+
+  ! modules used:
+  USE stomate_data
+  USE constantes
+  USE pft_parameters
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC crop_planting, crop_harvest
+
+  ! Variable declaration 
+
+  LOGICAL, SAVE             :: firstcall = .TRUE.                !! first call flag
+  !$OMP THREADPRIVATE(firstcall)
+
+CONTAINS
+
+
+  !! ================================================================================================================================
+  !! SUBROUTINE   : crop_planting
+  !!
+  !>\BRIEF        Plant croplands
+  !!
+  !! DESCRIPTION  : Plant the crops when the weather is suitable. Uses begin_leaves to decide
+  !! when to plant a crop. To be used within the DOFOCO branch.
+  !!
+  !! RECENT CHANGE(S) : 
+  !!
+  !! MAIN OUTPUT VARIABLE(S): 
+  !!
+  !! REFERENCE(S) :
+  !!
+  !! FLOWCHART    : None
+  !! \n
+  !_ =============================================================================================================================
+
+  SUBROUTINE crop_planting(npts, dt, ipts, ivm, &
+       veget_max, PFTpresent, c0_alloc, when_growthinit, &
+       time_hum_min, everywhere, senescence, ind, &
+       circ_class_n, KF, leaf_frac, age, &
+       npp_longterm, lm_lastyearmax, biomass, circ_class_biomass, &
+       co2_to_bm, k_latosa_adapt)
+
+
+  !! 0. Variable and parameter declaration
+  
+  !! 0.1 Input variables
+  
+    INTEGER(i_std), INTENT(in)                         :: npts                 !! Domain size - number of grid cells (unitless)
+    INTEGER(i_std), INTENT(in)                         :: ipts                 !! specific pixel to plant (unitless)
+    INTEGER(i_std), INTENT(in)                         :: ivm                  !! specific pft to plant in the specific pixel
+                                                                               !! (unitless)
+    REAL(r_std), INTENT(in)                            :: dt                   !! time step (dt_days)  
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: veget_max            !! "maximal" coverage fraction of a 
+                                                                               !! PFT (LAI -> infinity) on ground 
+                                                                               !! (0-1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: c0_alloc             !! Root to sapwood tradeoff parameter
+
+
+  !! 0.2 Ouput variables
+
+
+  !! 0.3 Modified variables
+    
+    LOGICAL, DIMENSION(:,:), INTENT(inout)             :: PFTpresent           !! PFT exists (true/false)
+    LOGICAL, DIMENSION(:,:), INTENT(inout)             :: senescence           !! is the plant senescent? (only 
+                                                                               !! for deciduous trees - 
+                                                                               !! carbohydrate reserve) (true/false)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: when_growthinit      !! how many days since the 
+                                                                               !! beginning of the growing season (days) 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: time_hum_min         !! time elapsed since strongest 
+                                                                               !! moisture availability (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: everywhere           !! is the PFT everywhere in the grid box or 
+                                                                               !! very localized (after its introduction) (?)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: ind                  !! Stand level number of individuals
+                                                                               !! @tex $(ind m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)       :: circ_class_n         !! Number of individuals in each circ class
+                                                                               !! @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: KF                   !! Scaling factor to convert sapwood mass
+                                                                               !! into leaf mass (m)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: k_latosa_adapt       !! Leaf to sapwood area adapted for long 
+                                                                               !! term water stress (m)
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)       :: leaf_frac            !! fraction of leaves in leaf age 
+                                                                               !! class (0-1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: age                  !! mean age (years)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: npp_longterm         !! "long term" net primary productivity
+                                                                               !! @tex ($gC m^{-2} year^{-1}$) @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: lm_lastyearmax       !! last year's maximum leaf mass for each PFT 
+                                                                               !! @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: co2_to_bm            !! co2 taken up by carbohydrate 
+                                                                               !! reserve at the beginning of the 
+                                                                               !! growing season @tex ($gC m^{-2} 
+                                                                               !! of total ground/day$) @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)     :: biomass              !! biomass @tex ($gC m^{-2} of 
+                                                                               !! ground$) @endtex
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout)   :: circ_class_biomass   !! Biomass components of the model tree  
+                                                                               !! within a circumference class
+                                                                               !! class @tex $(g C ind^{-1})$ @endtex
+    
+  !! 0.4 Local variables
+    
+    REAL(r_std), DIMENSION(npts,nvm)                   :: LF                   !! Scaling factor to convert sapwood mass
+                                                                               !! into root mass (unitless)
+    REAL(r_std), DIMENSION(npts,nvm)                   :: k_latosa             !! Height dependent base value to calculate 
+                                                                               !! KF (-) 
+    REAL(r_std), DIMENSION(npts,nvm)                   :: histvar              !! controls the history output 
+                                                                               !! level - 0: nothing is written; 
+                                                                               !! 10: everything is written 
+                                                                               !! (0-10, unitless)
+    REAL(r_std), DIMENSION(npts,nvm)                   :: lstress_fac          !! Light stress factor, based on total
+                                                                               !! transmitted light (unitless, 0-1)
+    REAL(r_std)                                        :: Cs_grass             !! Individual plant, sapwood compartment
+                                                                               !! @tex $(gC. ind^{-1})$ @endtex
+    REAL(r_std)                                        :: Cl_init              !! Initial leaf carbon required to start
+                                                                               !! the growing season
+                                                                               !! @tex $(gC tree^{-1})$ @endtex
+    REAL(r_std)                                        :: Cr_init              !! Initial root carbon required to start
+                                                                               !! the growing season
+                                                                               !! @tex $(gC tree^{-1})$ @endtex
+!_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering sapiens_crop_planting'
+
+    IF ( veget_max(ipts,ivm) .GT. min_stomate .AND. ind(ipts,ivm) .LT. min_stomate) THEN
+
+       !! 1. Prescribe the crops
+ 
+       ! Prescribe the crops - should move to an agricultural routine
+       ! Lightstress varies from 0 to 1 and is calculated from the canopy structure (veget)
+       ! Given that there is no vegetation at this point, the lightstress cannot be 
+       ! calculated and is set to 1. However as soon as we grow a canopy it will 
+       ! experience light stress and so KF should be adjusted. If this is not done, we 
+       ! can't prescribe tall vegetation which is a useful feature to speed up 
+       ! optimisation and testing. We will have iterate over light stress and KF to 
+       ! prescribe vegetation that is in balance with its light environment. 
+       lstress_fac(ipts,ivm) = un
+
+       ! For crops we assume that an individual crop is 1 m2 of crop. This is set
+       ! in nmaxtrees in pft_parameters.f90. It could be set to another value but 
+       ! with the current code this should not have any meaning. The cropland
+       ! does not necessarily covers the whole 1 m2 so adjust for the canopy cover
+       ind(ipts,ivm) = nmaxtrees(ivm) * ha_to_m2 * canopy_cover(ivm)
+       
+       ! Now we generate the size of a single crop sapling. We do not deal with 
+       ! circumference classes for crops, but we want to keep the arrays the 
+       ! same as for the trees so we put the sapling information into the first 
+       ! circumference class
+
+       ! Calculate the sapwood to leaf mass in a similar way as has been done for trees.
+       ! For trees this approach had been justified by observations. For crops such
+       ! justification is not supported by observations but we didn't try to find it.
+       ! Needs more work by someone interested in crops. There might be a more elegant
+       ! solution making use of a well observed parameter. 
+       k_latosa(ipts,ivm) = (k_latosa_adapt(ipts,ivm) + (lstress_fac(ipts,ivm) * &
+            (k_latosa_max(ivm)-k_latosa_min(ivm))))
+
+       ! The mass of the structural carbon relates to the mass of the leaves through
+       ! a prescribed parameter ::k_latosa
+       KF(ipts,ivm) = k_latosa(ipts,ivm)
+
+       ! Calculate leaf to root area 
+       LF(ipts,ivm) = c0_alloc(ipts,ivm) * KF(ipts,ivm)
+
+       !---TEMP---
+       IF(ld_presc .AND. test_pft == ivm)THEN
+          WRITE(numout,*) 'KF, ', k_latosa(ipts,ivm), KF(ipts,ivm)
+          WRITE(numout,*) 'LF, c0_alloc, ', c0_alloc(ipts,ivm) * KF(ipts,ivm), &
+               c0_alloc(ipts,ivm)
+       ENDIF
+       !----------
+
+       ! initialize everything to make sure there are not random values floating around
+       ! for ncirc = 1
+       circ_class_biomass(ipts,ivm,:,:,icarbon) = zero
+       circ_class_biomass(ipts,ivm,1,:,icarbon) = val_exp
+       
+       ! Similar as for trees, the initial height of the vegetation can be calculated 
+       ! from prescribed parameters
+       circ_class_biomass(ipts,ivm,1,ileaf,icarbon) = height_init_min(ivm) / &
+            lai_to_height(ivm) / sla(ivm)
+       
+       ! Use allometric relationships to define the root mass based on leaf mass. Some 
+       ! sapwood mass is needed to store the reserves.
+       circ_class_biomass(ipts,ivm,1,iroot,icarbon) = &
+            circ_class_biomass(ipts,ivm,1,ileaf,icarbon) / LF(ipts,ivm)
+       circ_class_biomass(ipts,ivm,1,isapabove,icarbon) = &
+            circ_class_biomass(ipts,ivm,1,ileaf,icarbon) / KF(ipts,ivm)
+       
+       ! Some of the biomass components that exist for trees are undefined for grasses
+       circ_class_biomass(ipts,ivm,1,isapbelow,icarbon) = zero
+       circ_class_biomass(ipts,ivm,1,iheartabove,icarbon) = zero
+       circ_class_biomass(ipts,ivm,1,iheartbelow,icarbon) = zero
+       circ_class_biomass(ipts,ivm,1,ifruit,icarbon) = zero
+       circ_class_biomass(ipts,ivm,1,icarbres,icarbon) = zero
+       
+       ! Pools that are defined in the same way for trees and grasses      
+       circ_class_biomass(ipts,ivm,1,ilabile,icarbon) = labile_to_total * &
+            ( circ_class_biomass(ipts,ivm,1,ileaf,icarbon) + &
+            fcn_root(ivm) *  circ_class_biomass(ipts,ivm,1,iroot,icarbon) + &
+            fcn_wood(ivm) * ( circ_class_biomass(ipts,ivm,1,isapabove,icarbon) +  &
+            circ_class_biomass(ipts,ivm,1,isapbelow,icarbon) + &
+            circ_class_biomass(ipts,ivm,1,icarbres,icarbon)))
+       
+       ! Write initial values
+       IF (ld_presc) THEN
+          WRITE(numout,*) 'Crop prescribed biomass: ', &
+               circ_class_biomass(ipts,ivm,1,:,icarbon)
+       ENDIF
+
+       ! Initial biomass (g C m-2)
+       biomass(ipts,ivm,:,icarbon) = circ_class_biomass(ipts,ivm,1,:,icarbon) * &
+            ind(ipts,ivm)
+       
+       ! Synchronize biomass and circ_class_biomass (gC tree-1). This 
+       ! allows to more easily check the mass balance closure
+       circ_class_n(ipts,ivm,1) = ind(ipts,ivm)
+       
+       ! Set leaf age classes -> all leaves will be current year leaves
+       leaf_frac(ipts,ivm,:) = zero
+       leaf_frac(ipts,ivm,1) = un
+       
+       ! Set time since last beginning of growing season but only
+       ! for the first day of the whole simulation. When the model
+       ! is initialized when_growthinit is set to undef. In subsequent
+       ! time steps it should have a value.
+       IF (when_growthinit(ipts,ivm) .EQ. undef) THEN
+          when_growthinit(ipts,ivm) = 200
+          time_hum_min(ipts,ivm) = 200
+       ENDIF
+       
+       ! The biomass to build the saplings is taken from the atmosphere, keep track of
+       ! amount to calculate the C-balance closure
+       co2_to_bm(ipts,ivm) = co2_to_bm(ipts,ivm) + &
+            ( SUM(biomass(ipts,ivm,:,icarbon))  / dt )
+
+       !! 2.3 Declare PFT present 
+       !! Now that the PFT has biomass it should be declared 'present'
+       !! everywhere in that grid box. Assign some additional properties
+       PFTpresent(ipts,ivm) = .TRUE.
+       everywhere(ipts,ivm) = un
+       age(ipts,ivm) = zero
+       npp_longterm(ipts,ivm) = npp_longterm_init
+       lm_lastyearmax(ipts,ivm) = zero
+
+       !! 4.3 reset when_growthinit counter: start of the growing season
+       when_growthinit(ipts,ivm) = zero
+       senescence(ipts,ivm) = .FALSE.
+
+    ! PFT is not present, initialize the variables
+    ELSE
+
+       ! At the tree level
+       circ_class_n(ipts,ivm,:) = zero
+       circ_class_biomass(ipts,ivm,:,:,icarbon) = zero
+       
+       ! At the stand level
+       biomass(ipts,ivm,:,icarbon) = zero
+       ind(ipts,ivm) = zero
+       
+    ENDIF ! veget_max gt min_stomate
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving sapiens_crop_planting'
+
+  END SUBROUTINE crop_planting
+
+
+  !! ================================================================================================================================
+  !! SUBROUTINE   : crop_harvest
+  !!
+  !>\BRIEF        Harvest of croplands
+  !!
+  !! DESCRIPTION  : To take into account biomass harvest from crop (mainly to take 
+  !! into account for the reduced litter input and then decreased soil carbon. it is a 
+  !! constant (40\%) fraction of turnover. To be used within the DOFOCO branch.
+  !!
+  !! RECENT CHANGE(S) : Harvest is stored in harvest_pool for further modelling of product use 
+  !!
+  !! MAIN OUTPUT VARIABLE(S): ::harvest_pool
+  !!
+  !! REFERENCE(S) :
+  !! - Piao, S., P. Ciais, P. Friedlingstein, N. de Noblet-Ducoudre, P. Cadule, N. Viovy, and T. Wang. 2009. 
+  !!   Spatiotemporal patterns of terrestrial carbon cycle during the 20th century. Global Biogeochemical 
+  !!   Cycles 23:doi:10.1029/2008GB003339.
+  !!
+  !! FLOWCHART    : None
+  !! \n
+  !_ ================================================================================================================================
+
+  SUBROUTINE crop_harvest(npts, ipts, ivm, dt_days, &
+       veget_max, turnover, harvest_pool, harvest_type, &
+       harvest_cut, harvest_area, resolution, biomass, &
+       ind, leaf_meanage) 
+
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER, INTENT(in)                                :: npts            !! Domain size (unitless)
+    INTEGER(i_std), INTENT(in)                         :: ipts            !! specific pixel to plant (unitless)
+    INTEGER(i_std), INTENT(in)                         :: ivm             !! specific pft to plant in the specific pixel
+                                                                          !! (unitless)
+    REAL(r_std), INTENT(in)                            :: dt_days         !! Time step (days)
+    REAL(r_std),DIMENSION(npts,2), INTENT(in)          :: resolution      !! The length in m of each grid-box in X and Y
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)       :: veget_max       !! Fraction of the pixel covered by a PFT 
+                                                                          !! @tex $(m^2 m^{-2})$ @endtex
+
+    !! 0.2 Output variables
+
+
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)    :: biomass          !! biomass @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(:,:,:,:),INTENT(inout)     :: turnover         !! Turnover rates 
+                                                                          !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)    :: harvest_pool     !! The wood and biomass that have been
+                                                                          !! havested by humans @tex $(gC)$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: harvest_type     !! Type of management that resulted
+                                                                          !! in the harvest (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: harvest_cut      !! Type of cutting that was used for the harvest
+                                                                          !! (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: harvest_area     !! Harvested area (m^{2})
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: ind              !! Density of individuals 
+                                                                          !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: leaf_meanage     !! mean age of the leaves (days)
+
+
+    !! 0.4 Local variables
+               
+    REAL(r_std)                                       :: pixel_area       !! surface area of the pixel @tex ($m^{2}$) @endtex
+
+ !_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering sapiens_crop_harvest'
+
+    !! 1. Initialize
+    !  Reset harvest pool
+    IF(ld_trnov .AND. ipts == test_grid .AND. ivm == test_pft)THEN
+       WRITE(numout,*) "Entering the crop_harvest routine: ",harvest_pool(ipts,ivm,:,icarbon)
+    ENDIF
+    !!! We should not reset!  Sometimes there is harvest in the harvest pool, and our
+    ! mass balance will not be closed if we eliminate it here.  It seems possible that we hit
+    ! senesence twice in a single year.  This happened on a grid point near the equator in the
+    ! Pacific ocean.
+    !harvest_pool(ipts,ivm,:,icarbon) = zero
+
+    !  Surface area (m2) of the pixel
+    pixel_area = resolution(ipts,1) * resolution(ipts,2)
+   
+
+    !! 2. Harvest croplands
+
+    ! NOTE that this is a quick fix rather than a final solution. The turnover
+    ! of crop biomass has for long be calculated and was assumed to entirely 
+    ! return to the litter pools. This approach ignored crop harvest. Rather 
+    ! than harvesting the aboveground biomass (or below ground for some
+    ! crops i.e. potatoes, beet, etc which is currently not accounted for) this
+    ! routine makes use of the turnover and diverts part of the turnover into 
+    ! the harvest pool. By doing so it does not end up in the litter.
+
+    ! Assume all aboveground biomass is harvested and put it all in the first 
+    ! diameter class.
+    harvest_pool(ipts,ivm,1,icarbon) =  harvest_pool(ipts,ivm,1,icarbon) + &
+         harvest_ratio(ivm) * ( biomass(ipts,ivm,ileaf,icarbon) + &
+         biomass(ipts,ivm,icarbres,icarbon) + biomass(ipts,ivm,ilabile,icarbon) + &
+         biomass(ipts,ivm,ifruit,icarbon) + biomass(ipts,ivm,isapabove,icarbon) ) * &
+         veget_max(ipts,ivm) * pixel_area
+
+    ! Associated harvest variables
+    harvest_type(ipts,ivm) = ifm_crop
+    harvest_cut(ipts,ivm) = icut_crop
+    harvest_area(ipts,ivm) = veget_max(ipts,ivm) * pixel_area
+
+    ! The belowground becomes litter. All roots remain on site. Half (::harvest_ratio) 
+    ! of the other biomas pools was harvested.
+    turnover(ipts,ivm,iroot,icarbon) = turnover(ipts,ivm,iroot,icarbon) + &
+         biomass(ipts,ivm,iroot,icarbon) 
+    turnover(ipts,ivm,ileaf,icarbon) = turnover(ipts,ivm,ileaf,icarbon) + &
+         (un - harvest_ratio(ivm)) * biomass(ipts,ivm,ileaf,icarbon)
+    turnover(ipts,ivm,icarbres,icarbon) = turnover(ipts,ivm,icarbres,icarbon) + &
+         (un - harvest_ratio(ivm)) * biomass(ipts,ivm,icarbres,icarbon)
+    turnover(ipts,ivm,ilabile,icarbon) = turnover(ipts,ivm,ilabile,icarbon) + &
+         (un - harvest_ratio(ivm)) * biomass(ipts,ivm,ilabile,icarbon)
+    turnover(ipts,ivm,ifruit,icarbon) = turnover(ipts,ivm,ifruit,icarbon) + &
+         (un - harvest_ratio(ivm)) * biomass(ipts,ivm,ifruit,icarbon)
+    turnover(ipts,ivm,isapabove,icarbon) = turnover(ipts,ivm,isapabove,icarbon) + &
+         (un - harvest_ratio(ivm)) * biomass(ipts,ivm,isapabove,icarbon) 
+
+    ! Account for the pools that should not contain biomass for the moment
+    ! Do so to make sure the mass balance will be closed 
+    turnover(ipts,ivm,isapbelow,icarbon) = turnover(ipts,ivm,isapbelow,icarbon) +  &
+         biomass(ipts,ivm,isapbelow,icarbon)
+    turnover(ipts,ivm,iheartabove,icarbon) = turnover(ipts,ivm,iheartabove,icarbon) +  &
+         biomass(ipts,ivm,iheartabove,icarbon)
+    turnover(ipts,ivm,iheartbelow,icarbon) = turnover(ipts,ivm,iheartbelow,icarbon) +  &
+         biomass(ipts,ivm,iheartbelow,icarbon)
+
+    ! Reset the biomass pools
+    biomass(ipts,ivm,isapabove,icarbon) = zero
+    biomass(ipts,ivm,ileaf,icarbon) = zero
+    biomass(ipts,ivm,iroot,icarbon) = zero
+    biomass(ipts,ivm,ifruit,icarbon) = zero
+    biomass(ipts,ivm,icarbres,icarbon) = zero
+    biomass(ipts,ivm,ilabile,icarbon) = zero
+                
+    ! These pools should always be empty for crops - just to be sure
+    biomass(ipts,ivm,iheartbelow,icarbon) = zero
+    biomass(ipts,ivm,iheartabove,icarbon) = zero
+    biomass(ipts,ivm,isapbelow,icarbon) = zero
+
+    ! No individuals left
+    ind(ipts,ivm) = zero
+
+    ! reset leaf age
+    leaf_meanage(ipts,ivm) = zero
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving sapiens_crop_harvest'
+
+  END SUBROUTINE crop_harvest
+
+END MODULE sapiens_agriculture
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/sapiens_forestry.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/sapiens_forestry.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/sapiens_forestry.f90	(revision 7236)
@@ -0,0 +1,2260 @@
+! =================================================================================================================================
+! MODULE       : forestry
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Gathers the main elements for forest management: the "forestry"
+!! subroutine, which itself calls a set of subroutines
+!! forestry_clear, clearcut, thinning, harvest, force_load, QsortC, and
+!! Partition, and a set of functions used in these subroutines.
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)   :
+!! - Asael, S., 1999. Typologie des peuplements forestiers du massif vosgiens. 
+!! C.R.P.F. Lorraine-Alsace, Nancy, 54 p.
+!! - Bellassen, V., Le Maire, G., Dhote, J.F., Viovy, N., Ciais, P., 2010. 
+!! Modeling forest management within a global vegetation model â Part 1: 
+!! model structure aSnd general behaviour. Ecological Modelling 221, 2458â2474.
+!! - Bellassen, V., Le Maire, G., Guin, O., Dhote, J.F., Viovy, N., Ciais, P., 
+!! 2011a. Modeling forest management within a global vegetation model â Part 2: 
+!! model validation from tree to continental scale. Ecological Modelling 222, 
+!! 57â75.
+!! - Bellassen, V., Viovy, N., Luyssaert, S., Le Maire, G., Schelhaas, M.J., 
+!! Ciais, P., 2011b. Reconstruction and attribution of the carbon sink of 
+!! European forests between 1950 and 2000. Global Change Biology 17, 3274-3292.
+!! - Bottcher, H., Kurz, W.A., Freibauer, A., 2008. Accounting of forest carbon
+!! sinks and sources under a future climate protocol-factoring out past 
+!! disturbance and management effects on age-class structure. Environmental 
+!! Science & Policy 11, 669-686.
+!! - Cazin, A., Vallet, P., Dhote, J.F., 2003. Propositions LERFoB pour CARBOFOR
+!! Atelier modÃ©lisation.
+!! - Condes, S., Sterba, H., 2005. Derivation of compatible crown width 
+!! equations for some important tree species of Spain. Forest Ecology and 
+!! Management 217, 203-218.
+!! - Deleuze, C., Pain, O., Dhote, J.F., Herve, J.C., 2004. A flexible radial
+!! increment model for individual trees in pure even-aged stands. Annals of 
+!! Forest Science 61, 327-335.
+!! - DhÃŽte, J.-F., HervÃ©, J.-C., 2000. Changements de productivitÃ© dans quatre 
+!! forÃªts de chÃªnes sessiles depuis 1930 : une approche au niveau du peuplement. 
+!! Ann. For. Sci. 57, 651-680.
+!! - DhÃŽte, J.F., 1999. CompÃ©tition entre classes sociales chez le chÃªne sessile
+!! et le hÃªtre. Revue ForestiÃšre FranÃ§aise, 309-325.
+!! - DhÃŽte, J.F., Le MoguÃ©dec, G., 2003. PrÃ©sentation du modÃšle FagacÃ©es. 
+!! INRA, 31 p.
+!! - IFN, 2008. Raw inventory data - 2005-2007 inventory campaigns, www.ifn.fr.
+!! - Kolari, P., Pumpanen, J., Rannik, U., Ilvesniemi, H., Hari, P., Berninger,
+!! F., 2004. Carbon balance of different aged Scots pine forests in Southern 
+!! Finland. Global Change Biology 10, 1106-1119.
+!! - Lanier, L., 1994. PrÃ©cis de sylviculture. Ecole Nationale du GÃ©nie Rural, 
+!! des Eaux et des ForÃªts (ENGREF), Nancy, 477 p.
+!! - Law, B.E., Sun, O.J., Campbell, J., Van Tuyl, S., Thornton, P.E., 2003. 
+!! Changes in carbon storage and fluxes in a chronosequence of ponderosa pine. 
+!! Global Change Biology 9, 510-524.
+!! - Liberloo, M., Calfapietra, C., Lukac, M., Godbold, D., Luos, Z.B., Polle, 
+!! A., Hoosbeek, M.R., Kull, O., Marek, M., Raines, C., Rubino, M., Taylor, G., 
+!! Scarascia-Mugnozza, G., Ceulemans, R., 2006. Woody biomass production during 
+!! the second rotation of a bio-energy Populus plantation increases in a future 
+!! high CO2 world. Global Change Biology 12, 1094-1106.
+!! - Liberloo, M., Luyssaert, S., Bellassen, V., Djomo, S.N., Lukac, M., 
+!! Calfapietra, C., Janssens, I., Hoosbeek, M.R., Viovy, N., Churkina, G., 
+!! Scarascia-Mugnozza, G., Ceulemans, R., 2010. Bio-energy retains its 
+!! mitigation potential under elevated CO2. PLOS-one 5, e1 1648.
+!! - Litton, C.M., Raich, J.W., Ryan, M.G., 2007. Carbon allocation in forest 
+!! ecosystems. Global Change Biology 13, 2089-2109.
+!! - Luyssaert, S., Inglima, I., Jung, M., Richardson, A.D., Reichsteins, M., 
+!! Papale, D., Piao, S.L., Schulzes, E.D., Wingate, L., Matteucci, G., Aragao, 
+!! L., Aubinet, M., Beers, C., Bernhoffer, C., Black, K.G., Bonal, D., 
+!! Bonnefond, J.M., Chambers, J., Ciais, P., Cook, B., Davis, K.J., Dolman, 
+!! A.J., Gielen, B., Goulden, M., Grace, J., Granier, A., Grelle, A., Griffis,
+!! T., Grunwald, T., Guidolotti, G., Hanson, P.J., Harding, R., Hollinger, D.
+!! Y., Hutyra, L.R., Kolar, P., Kruijt, B., Kutsch, W., Lagergren, F., 
+!! Laurila, T., Law, B.E., Le Maire, G., Lindroth, A., Loustau, D., Malhi, Y.,
+!! Mateus, J., Migliavacca, M., Misson, L., Montagnani, L., Moncrieff, J., 
+!! Moors, E., Munger, J.W., Nikinmaa, E., Ollinger, S.V., Pita, G., 
+!! Rebmann, C., Roupsard, O., Saigusa, N., Sanz, M.J., Seufert, G., Sierra, C., 
+!! Smith, M.L., Tang, J., Valentini, R., Vesala, T., Janssens, I.A., 2007. CO2 
+!! balance of boreal, temperate, and tropical forests derived from a global 
+!! database. Global Change Biology 13, 2509-2537.
+!! - Mokany, K., Raison, R.J., Prokushkin, A.S., 2006. Critical analysis of 
+!! root: shoot ratios in terrestrial biomes. Global Change Biology 12, 84-96.
+!! - Mund, M., Kummetz, E., Hein, M., Bauer, G.A., Schulze, E.D., 2002. Growth
+!! and carbon stocks of a spruce forest chronosequence in central Europe. 
+!! Forest Ecology and Management 171, 275-296.
+!! - Newton, R.F., Amponsah, I.G., 2007. Comparative evaluation of five height-
+!! diameter models developed for black spruce and jack pine stand-types in 
+!! terms of goodness-of-fit, lack-of-fit and predictive ability. Forest Ecology
+!! and Management 247, 149-166.
+!! - Numerical Recipes, 2007. Numerical Recipes: The Art of Scientific Computing. 
+!! Cambridge University Press, 1256 p.
+!! - Ovington, J.D., Madgwick, H.A.I., 1957. Afforestation and soil reaction. 
+!! Journal of Soil Science 8, 141-149.
+!! - Pontailler, J.Y., Ceulemans, R., Guittet, J., 1999. Biomass yield of poplar 
+!! after five 2-year coppice rotations. Forestry 72, 157-163.
+!! - Pretzsch, H., Biber, P., DurskÃœ, J., 2002. The single tree-based stand 
+!! simulator SILVA: construction, application and evaluation. Forest Ecology and 
+!! Management 162, 3.
+!! - Reineke, L.H., 1933. Perfecting a stand-density index for even-aged forests. 
+!! Journal of Agricultural Research 46, 627-638.
+!! - Turner, D.P., Ritts, W.D., Cohen, W.B., Maeirsperger, T.K., Gower, S.T., 
+!! Kirschbaum, A.A., Running, S.W., Zhao, M.S., Wofsy, S.C., Dunn, A.L., Law, B.E.,
+!! Campbell, J.L., Oechel, W.C., Kwon, H.J., Meyers, T.P., Small, E.E., Kurc, S.A.,
+!! Gamon, J.A., 2005. Site-level evaluation of satellite-based global terrestrial 
+!! gross primary production and net primary production monitoring. Global Change 
+!! Biology 11, 666-684.
+!! - Vacchiano, G., Motta, R., Long, J.N., Shaw, J.D., 2008. A density management 
+!! diagram for Scots pine (Pinus sylvestris L.): A tool for assessing the forest's 
+!! protective effect. Forest Ecology and Management 255, 2542-2554.
+!! - Vieira, I.C.G., de Almeida, A.S., Davidson, E.A., Stone, T.A., de Carvalho, 
+!! C.J.R., Guerrero, J.B., 2003. Classifying successional forests using Landsat 
+!! spectral properties and ecological characteristics in eastern Amazonia. Remote 
+!! Sensing of Environment 87, 470-481.
+!! - Zianis, D., Mencuccini, M., 2004. On simplifying allometric analyses of forest 
+!! biomass. Forest Ecology and Management 187, 311-332.
+!! 
+!! SVN      :
+!! $HeadURL: $
+!! $Date: $
+!! $Revision: $
+!! \n
+!_ ================================================================================================================================
+
+MODULE sapiens_forestry
+
+  ! modules used:
+#ifdef __NAGFOR
+  USE,INTRINSIC :: IEEE_ARITHMETIC
+#endif
+
+  USE netcdf
+  USE ioipsl_para
+  USE constantes
+  USE pft_parameters
+  USE function_library,         ONLY: wood_to_volume, wood_to_height, wood_to_cn, wood_to_circ, &
+                                      Nmax, wood_to_dia, Nmaxyield, Nminyield, wood_to_qmdia
+  USE interpol_help,            ONLY: aggregate_p
+  USE stomate_data
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC forestry,forestry_clear,read_in_fm_map, read_in_litter_map, litter_raking
+
+  
+  LOGICAL, SAVE                 :: firstcall = .TRUE.           !! first call
+
+CONTAINS
+
+!! ================================================================================================================================
+!! FUNCTION     : calculate_rdi
+!!
+!>\BRIEF        Calculate the relative density index of a stand
+!!
+!! DESCRIPTION   : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : calculate_rdi
+!!
+!! REFERENCE(S)   : Bellassen, V., Le Maire, G., Dhote, J.F., Viovy, N., Ciais, P., 2010. 
+!! Modeling forest management within a global vegetation model â Part 1: 
+!! model structure and general behaviour. Ecological Modelling 221, 2458â2474.
+!!
+!! FLOWCHART   : None
+!! \n
+!_ ================================================================================================================================
+  
+  FUNCTION calculate_rdi(diameters_temp,circ_class_n_temp,ivm)
+
+ !! 0. Variable and parameter declaration
+
+    IMPLICIT NONE
+
+    !! 0.1 Input variables
+    REAL(r_std),DIMENSION(ncirc),INTENT(in)            :: circ_class_n_temp   !! The distribution of individuals
+                                                                              !! for a given grid square and PFT  
+    REAL(r_std),DIMENSION(ncirc),INTENT(in)            :: diameters_temp      !! The diameters of the trunks
+                                                                              !! for each circ class (m)
+    INTEGER(i_std),INTENT(IN)                          :: ivm                 !! The number of the PFT
+                                                                              !! (unitless)
+
+    !! 0.2 Output variables
+    REAL(r_std)                                        :: calculate_rdi       !! The RDI of the stand 
+                                                                              !! (unitless, always positive)
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std)                                        :: Dg                  !! The quadratic mean diameter
+    REAL(r_std)                                        :: ind_loc
+    INTEGER(i_std)                                     :: icir                !! Indices
+
+!_ ================================================================================================================================
+
+ !! 1. Calculate the relative density index for a stand, based on
+ !!    the number of trees in each circumference class and the
+ !!    the diameter of a model tree in each class.
+    
+    ind_loc=SUM(circ_class_n_temp(:))
+
+    Dg=zero
+
+    DO icir=1,ncirc
+       Dg=Dg+circ_class_n_temp(icir)*m2_to_ha*(diameters_temp(icir)*m_to_cm)**2
+    ENDDO
+    Dg=SQRT(Dg/(ind_loc*m2_to_ha))
+    
+    calculate_rdi=(ind_loc*m2_to_ha)/Nmax(Dg,ivm)
+
+  END FUNCTION calculate_rdi
+
+
+!! ================================================================================================================================
+!! SUBROUTINE    : forestry_clear
+!!
+!>\BRIEF        Set the flag ::firstcall to .TRUE. and as such activate section 2 of the subroutine forestry (see below).
+!! 
+!_ ================================================================================================================================
+
+  SUBROUTINE forestry_clear
+    firstcall = .TRUE.
+  END SUBROUTINE forestry_clear
+
+
+!! ================================================================================================================================
+!! SUBROUTINE    : forestry
+!!
+!>\BRIEF        This subroutine is the core of the forest management module. It
+!! has been modified so it only decides if trees are getting cut or not.
+!!
+!! DESCRIPTION   : This forest management module has been changed quite a bit
+!! from Valentin's original version (documented in Ballassen et al (2010).  The
+!! biggest reason for these changes is that it is meant to be used with the new
+!! functional allocation scheme.  This scheme already includes circumference
+!! classes.  In each circumference class there are circ_class_n model trees
+!! which are all identical.  Therefore, we don't need to create a picture
+!! of every tree on the stand since in reality we only have ncirc trees, each
+!! of which are replicated.
+!!
+!! In addition to this, several other processes that were done here were moved
+!! to other parts of the code.  For example, trees are just scheduled to die
+!! here; the actually killing of the biomass and moving the wood to the harvest
+!! and litter pools is done in sapiens_kill.f90.  All tree establishment after
+!! clearcutting is done in stomate_prescribe.f90.  Self-thinning is a completely
+!! natural process, and therefore done with environmental mortality in 
+!! stomate_mark_kill.f90.
+
+!!++++ CHECK REFERNCE ++++
+!! Liberloo et al. (2010) describes how short 
+!! rotation coppices are simulated and validated.\n
+!!+++++++++++++++++++++++
+
+!! The forest management flags have changed as well.
+!! FM = 1 : No human intervention (ORCHIDEE default)
+!!      2 : Thinnings based on the RDI, clearcuts based on tree density,
+!!              annual increment, and tree diameter.  Thinnings from above and
+!!              from below are determined by the sign of thstrat.
+!!      3 : Coppices
+!!      4 : Short rotation coppices
+!!
+!! Relative density index (RDI) target of human thinning at the beginning of 
+!! the rotation (unitless). This is the value aimed at by human thinning at 
+!! the beginning of the rotation. It is necessarily lower than 1. The actual 
+!! RDI varies around this target, + or - delta_rdi, when forest_managed = 2. 
+!! When forest_managed = 3, human thinning occurs every year.  For FM = 4,
+!! the thinnings occur as a function of stand age.
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::circ_class_kill
+!!
+!! REFERENCE(S)   : See above, module description.
+!!
+!! FLOWCHART    : 
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE forestry (npts, biomass, age_stand, last_cut, &
+             circ_class_n, circ_class_kill, forest_managed, rdi,&
+             circ_class_biomass, mai, pai, previous_wood_volume, &
+             mai_count, coppice_dens, veget_max, rdi_target_upper,&
+             rdi_target_lower)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                             :: npts                !! Domain size - number of pixels 
+                                                                                  !! (dimensionless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: veget_max           !! "maximal" coverage fraction of a PFT on 
+                                                                                  !! the ground (unitless, 0-1) 
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements), &                      
+                                          INTENT(in)       :: circ_class_biomass  !! Biomass components of the model tree  
+                                                                                  !! within a circumference class
+                                                                                  !! class @tex $(g C ind^{-1})$ @endtex
+    INTEGER(i_std), DIMENSION(npts,nvm),INTENT(in)         :: last_cut            !! Years since last thinning (years)
+    INTEGER(i_std), DIMENSION(npts,nvm),INTENT(in)         :: age_stand           !! Age of stand (years)
+
+    !! 0.2 Output
+
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(inout)  :: circ_class_n        !! Number of trees in each circumference 
+                                                                                  !! class (0-2.2+ and poles-large wood, see 
+                                                                                  !! part 12.) 
+       
+
+    !! 0.3 Modified fields
+
+    REAL(r_std),DIMENSION(npts,nvm,nparts,nelements), &
+                                             INTENT(inout) :: biomass             !! Biomass @tex $(gC m^{-2})$ @endtex
+    INTEGER(i_std), DIMENSION(npts,nvm), INTENT(inout)     :: forest_managed      !! Forest management flag: 0 = orchidee 
+                                                                                  !! standard, 1= self-thinning only, 2= 
+                                                                                  !! high-stand, 3= high-stand smoothed, 4= 
+                                                                                  !! coppices 
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nfm_types,ncut_times), &
+                                             INTENT(inout) :: circ_class_kill     !! Number of trees within a circ that needs
+                                                                                  !! to be killed @tex $(ind m^{-2})$ @endtex  
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: mai                 !! The mean annual increment
+                                                                                  !! @tex $(m**3 / m**2 / year)$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: pai                 !! The period annual increment
+                                                                                  !! @tex $(m**3 / m**2 / year)$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: previous_wood_volume!! The volume of the tree trunks
+                                                                                  !! in a stand for the previous year.
+                                                                                  !! @tex $(m**3 / m**2 )$ @endtex
+    INTEGER(i_std), DIMENSION(npts,nvm),INTENT(inout)      :: mai_count           !! The number of times we've
+                                                                                  !! calculated the volume increment
+                                                                                  !! for a stand
+    REAL(r_std), DIMENSION(npts,nvm),INTENT(inout)         :: coppice_dens        !! The density of a coppice at the first
+                                                                                  !! cutting.
+                                                                                  !! @tex $( 1 / m**2 )$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: rdi                 !! Relative density index (unitless, 0-2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: rdi_target_upper    !! Upper limit of RDI. When reached the stand
+                                                                                  !! needs to be thinned (unitless)   
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: rdi_target_lower    !! Lower limit of RDI. When thinned, thin to this             
+                                                                                  !! stand density (unitless)
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                         :: icir,ivm,ipts       !! Indexes
+    INTEGER(i_std)                                         :: imbc, iele, ipar    !! Indexes
+    REAL(r_std)                                            :: trees,total_trees   !! a number of trees
+    REAL(r_std), DIMENSION(ncirc)                          :: diameters_temp      !! Trunk diameter calculated from allometry [m]
+    REAL(r_std), DIMENSION(ncirc)                          :: circ_temp           !! Trunk circumference calculated from allometry
+    REAL(r_std), DIMENSION(npts,nvm,ncirc)                 :: height,dia,cn       !! Tree height calculated from allometric 
+                                                                                  !! relationships (m)
+    REAL(r_std)                                            :: ave_tree_height
+    REAL(r_std)                                            :: woody_biomass
+    REAL(r_std)                                            :: current_wood_volume
+    REAL(r_std)                                            :: current_increment
+    REAL(r_std)                                            :: ave_tree_dia
+    INTEGER(i_std)                                         :: nrotations          !! The number of rotations that we've done
+                                                                                  !! for SRC minus one
+    REAL(r_std)                                            :: qm_dia              !! quadratic mean diameter of the forest (m)
+
+!_ ================================================================================================================================
+
+    IF ( bavard >= 2 ) WRITE(numout,*) 'Entering forestry'
+
+ !! 1. Initialize
+
+    ! 1.1 Initialize check for mass balance closure
+    !  The mass balance is calculated at the end of this routine
+    !  in section 4.
+    ! We don't actually have to do this in forestry, since none of the pools are
+    ! changed.  The sole purpose of this routine is to schedule trees for killing
+    ! which means that only circ_class_kill is changed.
+
+    ! initialize all of the output variables...we will give them strange values
+    ! instead of zero so that we know if something has gone wrong later on
+!!$    rdi(:,:) = val_exp
+!!$    rdi_target_upper(:,:) = val_exp
+!!$    rdi_target_lower(:,:) = val_exp
+
+
+    ! for every forest stand in the model, we need to decide if we are thinning or clearcutting.
+    DO ipts=1,npts
+
+       pft:DO ivm=1,nvm
+
+          IF(.NOT. is_tree(ivm)) CYCLE
+
+          IF(veget_max(ipts,ivm) == zero)THEN
+              ! this vegetation type is not present, so no reason to do the 
+              ! calculation
+              CYCLE
+          ENDIF
+
+          IF(SUM(biomass(ipts,ivm,:,icarbon)) .LE. min_stomate) CYCLE
+          
+          ! does our management strategy allow for thinning?
+          IF ( forest_managed(ipts,ivm) > 1 ) THEN
+
+             IF(ld_forestry)THEN
+                WRITE(numout,*) 'Forestry, check whether the stand needs management', ivm
+             ENDIF
+
+             ! Now we need to recompute the mean annual increment and the
+             ! periodic annual increment.  For this, we need to convert the 
+             ! aboveground woody biomass into a wood volume, removing the influence
+             ! of the branches.
+!!$          !+++CHECK+++
+!!$          This calculation has been included in the library
+!!$             woody_biomass=(biomass(ipts,ivm,isapabove,icarbon)+&
+!!$                  biomass(ipts,ivm,iheartabove,icarbon))*&
+!!$                  (un - branch_ratio(ivm))
+!!$          !+++++++++++
+             current_wood_volume=wood_to_volume(biomass(ipts,ivm,:,icarbon),&
+                  ivm,branch_ratio(ivm),0)
+
+             ! The mean annual increment is tricky.  I want to calculate
+             ! for the volume, since that is what foresters use and the NPP
+             ! would include leaf NPP.  However, we cannot calculate a
+             ! volume increment immediately after thinning.  Instead, the first
+             ! year after a thinning or after a clearcut (for consistency)
+             ! we just save the current volume.
+             IF(last_cut(ipts,ivm) .EQ. 1)THEN
+
+                ! do nothing.  We'll save the current wood volume later.
+                
+             ELSEIF(last_cut(ipts,ivm) .GT. 1)THEN
+
+                current_increment=current_wood_volume-previous_wood_volume(ipts,ivm)
+
+                mai_count(ipts,ivm)=mai_count(ipts,ivm)+1
+                mai(ipts,ivm)=mai(ipts,ivm)*REAL(mai_count(ipts,ivm)-1)/&
+                     REAL(mai_count(ipts,ivm))+current_increment/REAL(mai_count(ipts,ivm))
+
+                ! The periodic annual increment is an average over the past few
+                ! years.  Notice that the first year after a cut that we can
+                ! compute an increment for is year 2 (the difference between 
+                ! year 2 and year 1).  
+                
+                IF(last_cut(ipts,ivm) .LT. (n_pai+1))THEN
+                   
+                   pai(ipts,ivm)=pai(ipts,ivm)*REAL(last_cut(ipts,ivm)-2)/&
+                        REAL(last_cut(ipts,ivm)-1)+&
+                        current_increment/REAL(last_cut(ipts,ivm)-1)
+
+                ELSE
+
+                   pai(ipts,ivm)=pai(ipts,ivm)*REAL(n_pai-1)/REAL(n_pai)+&
+                        (current_wood_volume-previous_wood_volume(ipts,ivm))&
+                        /REAL(n_pai)
+
+                ENDIF
+
+             ELSE
+
+                ! I cannot think of a scenario where last_cut is zero.
+                ! If it is zero, we thinned or clearcut, but that happens
+                ! after this routine and we always increment it before this
+                ! routine.
+                WRITE(numout,*) 'Forestry, why is last_cut equal to zero?'
+                WRITE(numout,*) 'ipts, ivm, last_cut(ipts,ivm) ',&
+                     ipts, ivm, last_cut(ipts,ivm)
+                STOP
+             ENDIF
+
+             ! We also need to store the wood volume of this year in order to 
+             ! calculate the PAI for next year.
+             previous_wood_volume(ipts,ivm)=current_wood_volume
+
+             ! The following is specific for each forest management strategy
+             IF(forest_managed(ipts,ivm) == ifm_thin)THEN
+
+                ! Forests can only be thinned if it is profitable for the managers to do so.  
+                ! This profitability is based on the average height of the 100 tallest trees
+                ! per hectare.  If it's profitable, the stand is thinned to a target relative density
+                ! index (RDI), which is the ratio of the true density to the self thinning 
+                ! density.  This target depends on the management type, but it is always less
+                ! than unity.  Table 1 in Valentin et al, Ecological Modeling (2010) gives values
+                ! for some of these parameters.
+
+                ! First, calculate the average height of the 100 tallest trees on the hectare.
+                ! Remember that all our trees are the same height in a given circ class.
+                ! Since we don't explicitly track trees, we just start at the largest circ
+                ! class and add trees to our average until we have 100
+                height(ipts,ivm,:)=wood_to_height(circ_class_biomass(ipts,ivm,:,:,icarbon), ivm)
+
+                IF(ld_forestry)THEN
+                   WRITE(numout,*) 'Forestry, check for thinning', ivm
+                   ! just for printing out some information
+                   cn(ipts,ivm,:)=wood_to_cn(circ_class_biomass(ipts,ivm,:,:,icarbon), ivm)
+                   dia(ipts,ivm,:)=wood_to_dia(circ_class_biomass(ipts,ivm,:,:,icarbon), ivm)
+                   DO icir=1,ncirc     
+                      WRITE(numout,*) circ_class_n(ipts,ivm,icir)*m2_to_ha,height(ipts,ivm,icir), &
+                           deux*SQRT(cn(ipts,ivm,icir)/pi), dia(ipts,ivm,icir)
+                   ENDDO
+                ENDIF
+
+                total_trees=zero
+                ave_tree_height=zero
+                tree:DO icir=ncirc,1,-1
+                   trees=circ_class_n(ipts,ivm,icir)*m2_to_ha
+                   IF(trees .GE. ntrees_profit)THEN
+                      ave_tree_height=height(ipts,ivm,icir)
+                      EXIT tree
+                   ELSEIF((trees + total_trees) .GE. ntrees_profit)THEN
+                      ave_tree_height=ave_tree_height*total_trees/REAL(ntrees_profit,r_std)+&
+                           (REAL(ntrees_profit,r_std)-total_trees)/REAL(ntrees_profit,r_std)*&
+                           height(ipts,ivm,icir)
+                      EXIT tree
+                   ELSE
+                      ave_tree_height=ave_tree_height*total_trees/(total_trees+trees)+&
+                           trees/(total_trees+trees)*height(ipts,ivm,icir)
+                      total_trees=total_trees+trees
+                   ENDIF
+
+                ENDDO tree
+
+                ! this is our condition for thinning
+                IF(ave_tree_height >= h_first(ivm))THEN
+
+                   IF(ld_forestry)THEN
+                      WRITE(numout,*) 'Forestry, check for thinning - tree height OK', ivm
+                   ENDIF
+
+                   ! in order to thin, we need to know the relative density index (RDI) of
+                   ! our stand.  This is the ratio of the current stand density to
+                   ! the self-thinning density, Nmax.
+                   diameters_temp(:)=wood_to_dia(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)
+
+                   ! with these diameters, we can check to see if we want to clearcut.
+                   ! If the diameters get too big, harvesting equipment can't handle the
+                   ! trees anymore.  On the other hand, we need to make sure there
+                   ! are enough big trees that it is worthwhile to cut them down.
+
+                   total_trees=zero
+                   DO icir=1,ncirc
+                      IF(diameters_temp(icir) .GT. largest_tree_dia(ivm)) THEN
+                         total_trees=total_trees+circ_class_n(ipts,ivm,icir)*m2_to_ha
+                      ENDIF
+                   ENDDO
+
+                   IF(total_trees .GT. ntrees_dia_profit(ivm))THEN
+
+                      IF(ld_forestry)THEN
+                         WRITE(numout,*) 'Forestry, diameter exceeds treshold, clearcut', ivm
+                         WRITE(numout,*) 'total_trees: ', total_trees
+                         WRITE(numout,*) 'ntrees_dia_profit: ', ntrees_dia_profit(ivm)
+                         WRITE(numout,*) 'largest_tree_dia: ', largest_tree_dia(ivm)
+                         WRITE(numout,*) 'diameters_temp: ', diameters_temp(:)
+                         WRITE(numout,*) 'circ_class_n (in trees per hectare): ', &
+                              circ_class_n(ipts,ivm,:)*m2_to_ha
+                      ENDIF
+                      CALL clearcut_harvest(circ_class_n(ipts,ivm,:), &
+                           circ_class_kill(ipts,ivm,:,ifm_thin,icut_clear))
+
+                      CYCLE pft
+                   ENDIF
+
+                   ! Another condition of a clearcut is if the tees start growing 
+                   ! too slowly. This is measured by looking at the mean annual 
+                   ! increment, which is simply the trunk volume divided by the
+                   ! age of the tree.  We compare this to average tree growth over
+                   ! the past five years (i.e. the tree volume divided by 5), called
+                   ! the periodic annual increment.  If the PAI is smaller than the
+                   ! MAI, the trees are past their prime and the owner will cut
+                   ! them and plant anew.
+
+                   ! We calculate the MAI and the PAI at the same place where we 
+                   ! increment the age of the stand, so here we just have to
+                   ! compare them.  We need to check that we have enough years from
+                   ! the last cut to calculate a good PAI.
+
+                   IF(PAI(ipts,ivm) .LT. MAI(ipts,ivm) .AND. &
+                        last_cut(ipts,ivm) .GT. n_pai)THEN
+
+                      IF(ld_forestry)THEN
+                         WRITE(numout,*) 'Forestry, harvesting increment PAI<MAI'
+                         WRITE(numout,*) 'ipts, ivm, mai, pai: ',ipts, &
+                              ivm, mai(ipts,ivm), pai(ipts,ivm)
+                      ENDIF
+
+                      CALL clearcut_harvest(circ_class_n(ipts,ivm,:), &
+                           circ_class_kill(ipts,ivm,:,ifm_thin,icut_clear))
+                      CYCLE pft
+                   ENDIF
+		   
+                   ! our rdi_target will become a function of both PFT and diameter/density
+                   ! Calculate rdi and rdi_target and delta_rdi based on the yield models
+                   ! rdi of the stand as it is
+                   qm_dia = wood_to_qmdia(circ_class_biomass(ipts,ivm,:,:,icarbon), circ_class_n(ipts,ivm,:), ivm)
+
+                   ! The self-thinning and yield relationships are for diameters expressed in cm
+                   rdi(ipts,ivm) = (SUM(circ_class_n(ipts,ivm,:))*m2_to_ha)/Nmax(qm_dia*m_to_cm,ivm)  
+                   
+                   ! rdi_target_upper (based on the yield tables)
+                   ! rdi depends on the observed self-thinning relationship and rdi_target_upper
+
+                   rdi_target_upper(ipts,ivm) = Nmaxyield(qm_dia*m_to_cm,ivm)/Nmax(qm_dia*m_to_cm,ivm)
+                  
+                   IF(ld_forestry)THEN
+                      WRITE(numout,*) 'rdi', rdi(:,:)
+                      WRITE(numout,*) 'rdi_target_upper calcul', rdi_target_upper(:,:)
+                   ENDIF
+
+                   ! depends on the yield tables. Because the data are not perfect and the model
+                   ! fitted to the yield table data is rather limited it happens that rdi_target_upper
+                   ! exceeds rdi. This is nonesensical from a biological point of view. Either
+                   ! we have to use more flexible statistical models to fit to the yield data or
+                   ! we need a better algorithm that takes the above constraint into account or
+                   ! we simply use the minimum of the two. The last solution is here implemented by
+                   ! prescribing an rdi_limit_upper. In theory this value is one but because self-
+                   ! thinning is checked daily and thinning annually this condition is rarely 
+                   ! satisfied. So to make sure thinning keeps happening set the limit to a value 
+                   ! just below 1 i.e. 0.9
+
+                                   
+                   
+                   ! rdi_target_lower (based on the yield tables). If the lower rdi for harvest is
+
+                   rdi_target_upper(ipts,ivm) = MIN(rdi_target_upper(ipts,ivm), rdi_limit_upper)
+
+                  ! WRITE(numout,*) 'rdi_target_upper under harvest', rdi_target_upper(:,:)
+            
+	           ! rdi_target_lower (based on the yield tables). If the lower rdi for harvest is
+                   ! also above self-thinning there won't be any thinning because then the upper
+                   ! and lower harvest rdi are equal. This is an undesired situation but we have
+                   ! to deal with the numerics to avoid stupid results.
+
+                   ! rdi_target_lower (based on the yield tables)
+                   rdi_target_lower(ipts,ivm) = Nminyield(qm_dia*m_to_cm,ivm)/Nmax(qm_dia*m_to_cm,ivm)
+                  
+                   !WRITE(numout,*) 'rdi_target_lower calcul', rdi_target_lower(:,:)
+                   
+                   rdi_target_lower(ipts,ivm) = MIN(rdi_target_lower(ipts,ivm), rdi_limit_upper)
+                   
+          
+                   !WRITE(numout,*) 'rdi_target_lower under self_thinning', rdi_target_lower(:,:)
+
+                   !+++TEMP+++
+!!$                   ! Compare old and new calculations
+!!$                   IF ((rdi(ipts,ivm) - calculate_rdi(diameters_temp(:),circ_class_n(ipts,ivm,:),ivm) .GT. min_stomate) .OR. &
+!!$                        (rdi(ipts,ivm) - calculate_rdi(diameters_temp(:),circ_class_n(ipts,ivm,:),ivm) .LT. -min_stomate)) THEN
+!!$                      WRITE(numout,*) 'WARNING: forestry, compare rdi (new vs old), ', ivm, rdi(ipts,ivm), &
+!!$                           calculate_rdi(diameters_temp(:),circ_class_n(ipts,ivm,:),ivm)
+!!$                   ENDIF
+!!$                   WRITE(numout,*) 'rdi_target_upper, ', ivm, rdi_target_upper
+!!$                   WRITE(numout,*) 'rdi_target_lower, ', ivm, rdi_target_lower
+                   !+++++++++++
+
+                   ! we only need to thin if the rdi of our stand is outside the acceptable
+                   ! rdi range given by rdi_target_upper and rdi_target_lower
+                   IF(ld_forestry)THEN
+                      IF(ivm == test_pft .AND. ipts == test_grid)THEN
+                         WRITE(numout,*) 'Forestry, rdi print ',rdi(ipts,ivm),ipts,&
+                              ivm, rdi_target_upper(ipts,ivm),&
+                              rdi_target_lower(ipts,ivm)
+                         WRITE(numout,*) "qm_dia,Nminyield ",qm_dia,Nminyield(qm_dia*m_to_cm,ivm)
+                         WRITE(numout,*) "qm_dia,Nmaxyield ",qm_dia,Nmaxyield(qm_dia*m_to_cm,ivm)
+                         WRITE(numout,*) "alpha_rdi_upper,beta_rdi_upper ",alpha_rdi_upper(ivm),beta_rdi_upper(ivm)
+                         WRITE(numout,*) "nmaxtrees,dens_target ",nmaxtrees(ivm),dens_target(ivm)
+                      ENDIF
+                   ENDIF
+
+                   IF((rdi(ipts,ivm) .GT. (rdi_target_upper(ipts,ivm))))THEN
+
+                      ! we always thin down to the lower end of this range, which then gives our forest
+                      ! a few years to grow before we need to thin again
+
+                      IF(ld_forestry)THEN
+                         DO icir=1,ncirc
+                            WRITE(numout,*) 'Forestry, ',height(ipts,ivm,icir),circ_class_n(ipts,ivm,icir)*m2_to_ha
+                         ENDDO
+                      ENDIF
+
+                      ! we need the circumference of each model tree in meters 
+                      circ_temp(:)=wood_to_circ(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)
+
+                      CALL thinning(taumin(ivm),taumax(ivm),thinstrat(ivm),diameters_temp(:),&
+                           circ_temp(:),circ_class_kill(ipts,ivm,:,ifm_thin,icut_thin),circ_class_n(ipts,ivm,:),&
+                           rdi_target_lower(ipts,ivm),ivm)
+
+                      IF(ld_forestry)THEN
+                         WRITE(numout,*) 'Forestry, thinning ',circ_class_kill(ipts,ivm,:,ifm_thin,icut_thin)
+                         WRITE(numout,*) 'circ_class_n(ipts,ivm,:) ',circ_class_n(ipts,ivm,:)
+                         DO icir=1,ncirc
+                            WRITE(numout,*) 'Forestry, circ_biomass(ipts,ivm,:) ',circ_class_biomass(ipts,ivm,icir,:,icarbon)
+                         ENDDO
+                      ENDIF
+
+                   ENDIF
+
+
+                ENDIF
+
+             ELSEIF(forest_managed(ipts,ivm) == ifm_cop)THEN
+
+                ! This is for coppicing.
+                ! It makes no sense to coppice an evergreen tree, apparently.
+                IF(.NOT. is_deciduous(ivm))THEN
+
+                   WRITE(numout,*) '!+++++++++++++++++++++++++++++++++++++++++++++++'
+                   WRITE(numout,*) 'Forestry, Coppicing (FM = 3) should only be done on ' &
+                        // 'deciduous trees.'
+                   WRITE(numout,*) 'ipts,ivm,forest_managed(ipts,ivm): ',&
+                       ipts,ivm,forest_managed(ipts,ivm) 
+                   !STOP
+                    WRITE(numout,*) ' I am not going to stop you now.  Be sure you know what you are doing!'
+                    WRITE(numout,*) '!+++++++++++++++++++++++++++++++++++++++++++++++'
+                   
+                ENDIF
+
+                ! Depending on the age of the stand we have different options.
+                ! The current system is to do nothing until the diameter of the
+                ! trees is greater than a certain value.  Once this happens, we
+                ! coppice, saving the number of trees that exist in this stand.
+                ! The trees then regrow until they reach this diameter again.
+                ! Some trees will have died to due mortality.  At the second
+                ! (and subsequent) cuts, we redistribute the below ground root mass
+                ! to have the same number of trees as the first cut, killing the
+                ! fine roots and harvesting aboveground biomass.
+
+                ! Check first to see if the average diameter of the
+                ! stand is greater than an input parameter.
+                diameters_temp(:)=wood_to_dia(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)
+                ave_tree_dia=zero
+                DO icir=1,ncirc
+                   ave_tree_dia=ave_tree_dia+diameters_temp(icir)*circ_class_n(ipts,ivm,icir)
+                ENDDO
+                ave_tree_dia=ave_tree_dia/SUM(circ_class_n(ipts,ivm,:))
+
+                IF(ld_forestry)THEN
+                   WRITE(numout,*) 'Forestry, Do we coppice? '
+                   WRITE(numout,*) 'ipts,ivm,SUM(circ_class_n(ipts,ivm,:)) ',&
+                        ipts,ivm,SUM(circ_class_n(ipts,ivm,:))
+                   WRITE(numout,*) 'ave_tree_dia,coppice_diameter(ivm),coppice_dens(ipts,ivm) ',&
+                        ave_tree_dia,coppice_diameter(ivm),coppice_dens(ipts,ivm)
+                ENDIF
+
+                IF(ave_tree_dia .GE. coppice_diameter(ivm) .AND. coppice_dens(ipts,ivm) .GT. zero)THEN
+
+                   IF(ld_forestry)THEN
+                      WRITE(numout,*) 'Forestry, Coppicing second cut. '
+                   ENDIF
+
+                   ! We have already coppiced once, so we know our target
+                   ! tree density.  We just have to mark all the trees
+                   ! for coppicing.
+                   circ_class_kill(ipts,ivm,:,ifm_cop,icut_cop2)=circ_class_n(ipts,ivm,:)
+
+                ELSEIF(ave_tree_dia .GE. coppice_diameter(ivm))THEN
+                   ! this is our first time coppicing
+
+                   IF(ld_forestry)THEN
+                      WRITE(numout,*) 'Forestry, Coppicing first cut. '
+                      WRITE(numout,*) 'coppice_dens(ipts,ivm): ',&
+                           SUM(circ_class_n(ipts,ivm,:))
+                   ENDIF
+
+                   ! save this tree density.  We will reallocate to this in future
+                   ! cuts.
+                   coppice_dens(ipts,ivm)=SUM(circ_class_n(ipts,ivm,:))
+
+                   ! Mark all trees for the first coppice cut.
+                   circ_class_kill(ipts,ivm,:,ifm_cop,icut_cop1)=circ_class_n(ipts,ivm,:)
+
+
+                ELSE
+                   
+                   ! We don't need to coppice anything.
+
+                ENDIF
+
+             ELSEIF(forest_managed(ipts,ivm) == ifm_src)THEN
+
+                ! This is for short rotation coppices.
+
+                ! It makes no sense to coppice an evergreen tree, apparently.
+                IF(.NOT. is_deciduous(ivm))THEN
+
+                   WRITE(numout,*) 'Forestry, Short rotation coppicing (FM = 4) should only be done on ' &
+                        // 'deciduous trees.'
+                   WRITE(numout,*) 'ipts,ivm,forest_managed(ipts,ivm): ',&
+                       ipts,ivm,forest_managed(ipts,ivm) 
+                   STOP
+                   
+                ENDIF
+
+                ! The qualifications for doing a short rotation coppice are fairly
+                ! simple.  It's based on the age of the stand.  We harvest all the
+                ! aboveground biomass.  After a certain number of rotations, we
+                ! harvest the aboveground and kill the belowground.
+                ! http://www.coppiceresources.co.uk/SRC.asp says that 30 years between
+                ! total harvests.
+
+                IF(ld_forestry)THEN
+                   WRITE(numout,*) 'Forestry, Do we SRC? '
+                   WRITE(numout,*) 'ipts,ivm,SUM(circ_class_n(ipts,ivm,:)) ',&
+                        ipts,ivm,SUM(circ_class_n(ipts,ivm,:))
+                   WRITE(numout,*) 'age_stand(ipts,ivm),src_rot_length(ivm),coppice_dens(ipts,ivm): ',&
+                        age_stand(ipts,ivm),src_rot_length(ivm),coppice_dens(ipts,ivm)
+                   WRITE(numout,*) 'src_nrots(ivm) ',&
+                        src_nrots(ivm)
+                ENDIF
+
+                IF(MOD(age_stand(ipts,ivm),src_rot_length(ivm)) == 0)THEN
+
+                   nrotations=age_stand(ipts,ivm)/src_rot_length(ivm)
+
+                   IF(nrotations == src_nrots(ivm))THEN
+
+                      ! This is the final harvest, where we will kill
+                      ! all belowground biomass.
+                      IF(ld_forestry)THEN
+                         WRITE(numout,*) 'Forestry, SRC final harvest. '
+                      ENDIF
+
+                      circ_class_kill(ipts,ivm,:,ifm_src,icut_cop3)=&
+                           circ_class_n(ipts,ivm,:)
+
+                   ELSEIF(nrotations == 1)THEN
+
+                      ! This is the first harvest, which will lead
+                      ! to coppices.
+
+                      IF(ld_forestry)THEN
+                         WRITE(numout,*) 'Forestry, SRC first harvest. '
+                      ENDIF
+
+                      ! save this tree density.  We will reallocate to this in future
+                      ! cuts.
+                      coppice_dens(ipts,ivm)=SUM(circ_class_n(ipts,ivm,:))
+                      
+                      ! Mark all trees for the first coppice cut.
+                      circ_class_kill(ipts,ivm,:,ifm_src,icut_cop1)=circ_class_n(ipts,ivm,:)
+
+
+                   ELSEIF(nrotations < src_nrots(ivm))THEN
+
+                      ! This is a standard harvest where we take the
+                      ! aboveground biomass and leave the belowground.
+
+                      IF(ld_forestry)THEN
+                         WRITE(numout,*) 'Forestry, SRC standard harvest. '
+                      ENDIF
+
+                      ! Mark all trees for a standard coppice cut.
+                      circ_class_kill(ipts,ivm,:,ifm_src,icut_cop2)=circ_class_n(ipts,ivm,:)
+
+                  ELSE
+
+                      WRITE(numout,*) 'Forestry, How did we arrive here? We must have '
+                      WRITE(numout,*) 'somehow skipped the harvest in SRC. '
+                      WRITE(numout,*) 'nrotations,src_nrots(ivm): ',&
+                           nrotations,src_nrots(ivm)
+                      STOP
+
+                   ENDIF ! check to see how many rotations we've done
+
+
+                ENDIF ! checking if it's a harvest year
+
+
+             ELSE
+
+                WRITE(numout,*) 'Forestry, We do not have any action for this management strategy'
+                WRITE(numout,*) 'forest_managed(ipts,ivm),ipts,ivm ', &
+                     forest_managed(ipts,ivm),ipts,ivm
+                STOP 
+
+             ENDIF ! test of management strategy
+
+
+          END IF
+
+       ENDDO pft
+    ENDDO
+
+    IF(ld_forestry)THEN
+       WRITE(numout,*) 'Forestry, How many trees do we kill?'
+       WRITE(numout,*) 'Name  icir  test_pft  circ_class_kill  '
+       DO icir=1,ncirc
+          WRITE(numout,*) 'Thin ',icir,test_pft,circ_class_kill(test_grid,test_pft,:,ifm_thin,icut_thin)
+          WRITE(numout,*) 'Clearcut ',icir,test_pft,circ_class_kill(test_grid,test_pft,:,ifm_thin,icut_clear)
+          WRITE(numout,*) 'Coppice 1 ',icir,test_pft,circ_class_kill(test_grid,test_pft,:,ifm_cop,icut_cop1)
+          WRITE(numout,*) 'Coppice 2 ',icir,test_pft,circ_class_kill(test_grid,test_pft,:,ifm_cop,icut_cop2)
+          WRITE(numout,*) 'SRC 1 ',icir,test_pft,circ_class_kill(test_grid,test_pft,:,ifm_src,icut_cop1)
+          WRITE(numout,*) 'SRC 2 ',icir,test_pft,circ_class_kill(test_grid,test_pft,:,ifm_src,icut_cop2)
+          WRITE(numout,*) 'SRC 3 ',icir,test_pft,circ_class_kill(test_grid,test_pft,:,ifm_src,icut_cop3)
+       ENDDO
+    ENDIF
+
+ !! 4. Check mass balance closure
+   
+    !  Consider this whole routine as a black box with incoming and outgoing 
+    !  fluxes and a change in the mass of the box. Express in absolute 
+    !  units gC (or gN), hence, multiply with dt and veget_max. In most routines 
+    !  veget_max does not change and could be omitted but a general approach 
+    !  was prefered.
+
+    ! We don't actually have to do this in forestry, since none of the pools are
+    ! changed.  The sole purpose of this routine is to schedule trees for killing
+    ! which means that only circ_class_kill is changed.
+
+    IF (bavard >= 2) WRITE(numout,*) 'Leaving forestry'
+
+  END SUBROUTINE forestry
+
+
+!! ================================================================================================================================
+!! SUBROUTINE    : clearcut_harvest
+!!
+!>\BRIEF        Marks all the trees at this point and this PFT for clearing
+!!
+!! DESCRIPTION   : This marks all the trees in this stand for killing.  The
+!!                 difference between this and clearcut_noharvest is that
+!!                 these trees are moved into the harvest pools in stomate_kill,
+!!                 where only the branches should be left onsite.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::circ_class_kill; the number of trees in each circumference class to kill
+!!
+!! REFERENCE(S)   : See above, module description.
+!!
+!! FLOWCHART    : 
+!! \latexonly 
+!! \includegraphics[scale=0.5]{clearcutflow.jpg}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE clearcut_harvest(circ_class_n_temp, circ_class_kill_temp)
+
+    IMPLICIT NONE
+
+ !! 0  Variable and parameter declaration
+
+    !! 0.1 Input variables
+    REAL(r_std), DIMENSION(ncirc), INTENT(IN)            :: circ_class_n_temp          !! Number of trees in each circumference 
+                                                                                       !! class 
+    !! 0.2 Output variables
+    REAL(r_std), DIMENSION(ncirc), INTENT(OUT)  :: circ_class_kill_temp                !! Number of trees within a circ that needs
+                                                                                       !! to be killed @tex $(ind m^{-2})$ @endtex  
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+   
+
+!_ ================================================================================================================================
+
+
+    ! This routine has gotten much simpler.  All we want to do here is to
+    ! indicate how many trees we want to kill.  The actual killing of
+    ! the trees will be done in lpj_gap.  As this is a clearcut, we
+    ! want to kill all of the trees.
+
+    circ_class_kill_temp(:)=circ_class_n_temp(:)
+
+
+  END SUBROUTINE clearcut_harvest
+
+!! ================================================================================================================================
+!! SUBROUTINE    : thinning
+!!
+!>\BRIEF        Thinning of the stand in gridpoint i for PFT j according to the
+!! management type (self-thinning, anthropogenic thinning, smoothed anthropogenic
+!! thinning or coppicing). Selects which trees are thinned in order to respect 
+!! self-thinning rules or rdi_objective. Only trees with circumference lower than 
+!! circ_lim can be thinned.
+!!
+!! DESCRIPTION   : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::circ_ij0; circumference of all individual trees 
+!! before thinning for 1 ha at gridpoint i and for PFT j (m), ::vol_thinned 
+!! Volume of thinned trees including waste wood \f$(m^3 ha^{-1})\f$ all other readjusted 
+!! stand-level variables: ::rdi, ::ind, ::av_height, ...
+!!
+!! REFERENCE(S)   : See above, module description.
+!!
+!! FLOWCHART    : 
+!! \latexonly 
+!! \includegraphics[scale=0.5]{thinningflow.jpg}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE thinning(tmin,tmax,thstrat,diameters_temp,circ_temp,circ_class_kill_temp,circ_class_n_temp,&
+       rdi_limit,ivm)
+    
+ !! 0  Variable and parameter declaration
+    
+    !! 0.1 Input variables
+    REAL(r_std), INTENT(in)                :: tmin
+    REAL(r_std), INTENT(in)                :: tmax
+    REAL(r_std), INTENT(in)                :: thstrat
+    REAL(r_std), INTENT(in)                :: rdi_limit
+    REAL(r_std), DIMENSION(ncirc), INTENT(in)                :: diameters_temp
+    REAL(r_std), DIMENSION(ncirc), INTENT(in)                :: circ_temp
+    REAL(r_std), DIMENSION(ncirc), INTENT(in)                :: circ_class_n_temp
+    INTEGER(i_std),INTENT(IN)                  :: ivm
+
+
+    !! 0.2 Output variables
+    REAL(r_std), DIMENSION(ncirc), INTENT(out)                :: circ_class_kill_temp
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std), DIMENSION(ncirc)                :: probability
+    REAL(r_std), DIMENSION(ncirc)                :: circ_class_kill_pot
+    REAL(r_std)                                  :: circmax
+    REAL(r_std)                                  :: circmin
+    REAL(r_std)                                  :: current_rdi
+    REAL(r_std)                                  :: potential_rdi
+    REAL(r_std)                                  :: dead_trees
+    REAL(r_std)                                  :: previous_step
+    INTEGER    :: icir,endcir,startcir,inccir,nsteps_tried
+
+
+    
+
+!_ ================================================================================================================================    
+
+
+    ! We are going to assign a thinning probability to every circumference class, 
+    ! based on Eq. 12 in Bellassen 2010.  He does it there for individual trees.
+    ! The equation differs based on the thinning strategy used (from above or below).
+
+    circ_class_kill_temp(:)=zero
+
+    circmin=circ_temp(1)
+    circmax=circ_temp(ncirc)
+
+    probability(:)=zero
+    
+    DO icir=1,ncirc
+       
+       IF(thstrat .GE. zero)THEN
+          ! thinning from below
+
+          IF(ncirc == 1)THEN
+             ! In this case, circmin=circmax and the denominator will be
+             ! zero.  However, if we have only one circ class it doesn't really
+             ! matter what the probability is set to, because all the biomass
+             ! has to come from this circ class.  So we set it equal to the minimum
+             ! probability.
+             probability(icir)=tmin
+
+          ELSE
+             probability(icir)=tmin+(tmax-tmin)*((circmax-circ_temp(icir))/(circmax-circmin))**thstrat
+          ENDIF
+
+       ELSE
+          ! thinning from above
+
+          IF(ncirc == 1)THEN
+             ! Same issue as above
+             probability(icir)=tmin
+          ELSE
+             probability(icir)=tmin+(tmax-tmin)*((circ_temp(icir)-circmin)/(circmax-circmin))**ABS(thstrat)
+          ENDIF
+
+       ENDIF
+
+    ENDDO
+
+    ! now we need to kill enough trees to get down to the proper density.  If we
+    ! are thinning from above, we start from the highest class, and from
+    ! below, we start from the lowest.  One thing to keep in mind here is
+    ! that it is possible that we have not removed enough trees after looping
+    ! through all the circ classes one time, so we need to keep looping through 
+    ! until our density is low enough.
+
+    IF(thstrat .GE. zero)THEN
+       startcir=1
+       endcir=ncirc
+       inccir=1
+    ELSE
+       startcir=ncirc
+       endcir=1
+       inccir=-1
+    ENDIF
+
+    thin_out:DO
+
+       DO icir=startcir,endcir,inccir
+
+          IF(ld_forestry .AND. ivm == test_pft)THEN
+             WRITE(numout,*) 'Debugging thinning',ivm
+             WRITE(numout,*) 'icir,startcir,endcir,inccir',icir,startcir,endcir,inccir
+             WRITE(numout,*) 'rdi_limit',rdi_limit
+          ENDIF
+
+          ! check the density to see if we have gotten enough trees.  Notice we only want to
+          ! include the trees that will still be living at the end of this step
+          current_rdi=calculate_rdi(diameters_temp(:),circ_class_n_temp(:)-circ_class_kill_temp(:),ivm)
+          IF( current_rdi .LE. rdi_limit)THEN      
+             EXIT thin_out
+          ENDIF
+
+          ! if not, we need to kill some or all of the trees in this class
+          ! this is the maximum number of trees we can kill in this circ class
+          dead_trees=probability(icir)*(circ_class_n_temp(icir)-circ_class_kill_temp(icir))
+
+          ! if we kill all these trees, can we get the RDI as low as we want?
+          circ_class_kill_pot(:)=circ_class_kill_temp(:)
+          circ_class_kill_pot(icir)=circ_class_kill_temp(icir)+dead_trees
+          potential_rdi=calculate_rdi(diameters_temp(:),circ_class_n_temp(:)-circ_class_kill_pot(:),ivm)
+
+          IF(ld_forestry .AND. ivm == test_pft)THEN
+             WRITE(numout,*) 'potential_rdi,rdi_limit',potential_rdi,rdi_limit
+          ENDIF
+
+          IF(potential_rdi .LE. rdi_limit)THEN
+
+             ! yes we can.  How do we know how many trees to kill, though?  The problem is
+             ! that the RDI depends on the diameters of the remaining trees in a non-linear
+             ! fashion.  Let us do a simple bisection search .  If we are here, we know that
+             ! circ_class_kill_pot(icir) is too high.  So cut it in half and try again.
+             previous_step=dead_trees/deux
+             circ_class_kill_pot(icir)=circ_class_kill_temp(icir)+previous_step
+             nsteps_tried=0
+             inner_loop:DO
+
+                potential_rdi=calculate_rdi(diameters_temp(:),circ_class_n_temp(:)-circ_class_kill_pot(:),ivm)
+                nsteps_tried=nsteps_tried+1
+                
+                !+++++ CHECK +++++
+                ! this value should be externalised
+                ! Our RDI is within our tolerance of the target, so we're good.
+                IF( ABS(potential_rdi - rdi_limit) .LE. 0.001_r_std)THEN
+                   EXIT inner_loop
+                ENDIF
+
+                ! Is our potential RDI too high or too low?
+                previous_step=previous_step/deux
+                IF(potential_rdi .GT. rdi_limit)THEN
+
+                   ! We need to kill more trees, so we add half of our previous step size
+                   ! back.
+                   circ_class_kill_pot(icir)=circ_class_kill_pot(icir)+previous_step
+                                
+                ELSE
+
+                   ! We need to kill fewer trees, so we take half of our previous step size
+                   ! away.
+                   circ_class_kill_pot(icir)=circ_class_kill_pot(icir)-previous_step
+
+                ENDIF
+
+
+!!$                WRITE(6,*) 'pot ',circ_class_kill_pot(:)
+                !+++++ CHECK +++++
+                ! this value should be externalised
+                IF(nsteps_tried .GT. 100)THEN
+                   WRITE(6,*) 'pot ',circ_class_kill_pot(:)
+                   WRITE(6,*) 'kill ',circ_class_kill_temp(:)
+                   WRITE(6,*) 'n ',circ_class_n_temp(:)
+                   STOP 'Trying too many steps in the bisection search in forestry thinning.'
+                ENDIF
+             ENDDO inner_loop
+
+             ! Schedule the trees for killing.
+
+             circ_class_kill_temp(icir)=circ_class_kill_pot(icir)
+
+             EXIT thin_out
+
+          ELSE
+
+             ! no we can't, so we have to kill all possible trees and move onto the next class
+             circ_class_kill_temp(icir)=circ_class_kill_temp(icir)+dead_trees
+
+          ENDIF
+
+        
+       ENDDO 
+          
+       ! check to see if we have any trees left.  We should!  If not, there is a problem,
+       ! and we need to catch it to avoid an infinite loop.
+       IF( (SUM(circ_class_n_temp(:)) - SUM(circ_class_kill_temp(:))) .LE. min_stomate)THEN
+          WRITE(6,*) 'kill ',circ_class_kill_temp(:)
+          WRITE(6,*) 'n ',circ_class_n_temp(:)
+          STOP 'We are thinning, but we have no trees left!'
+
+       ENDIF
+
+    ENDDO thin_out
+    
+
+  END SUBROUTINE thinning
+
+
+!! ================================================================================================================================
+!! SUBROUTINE    : read_in_fm_map
+!!
+!>\BRIEF        Read in a map that gives the forest management strategy
+!!              for each pixel and each PFT.
+!!
+!! DESCRIPTION   :  
+!!     
+!!
+!! FM = 1 : No human intervention (ORCHIDEE default)
+!!      2 : Thinnings based on the RDI, clearcuts based on tree density,
+!!              annual increment, and tree diameter.  Thinnings from above and
+!!              from below are determined by the sign of thstrat.
+!!      3 : Coppices
+!!      4 : Short rotation coppices
+!!
+!!       NOTE: This routine was mostly copied from slowproc where the PFTmap is read in.
+!!             Grid interpolation is used, but only to look at the nearby pixels to see
+!!             see which management strategy is dominant.
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::forest_managed
+!!
+!! REFERENCE(S)   : 
+!!
+!! FLOWCHART    : 
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE read_in_fm_map ( npts, lalo, neighbours, resolution, contfrac, forest_managed )
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+    INTEGER(i_std), INTENT(in)                             :: npts            !! Domain size - number of pixels 
+                                                                              !! (dimensionless)
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)             :: lalo            !! Vector of latitude and longitudes (beware of the order !)
+    INTEGER(i_std), DIMENSION(npts,8), INTENT(in)          :: neighbours     !! 
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)             :: resolution      !! The size in m of each grid-box in X and Y
+    REAL(r_std), DIMENSION(npts), INTENT(in)               :: contfrac        !! Fraction of continent in the grid
+
+    !! 0.2 Output
+    INTEGER(i_std), DIMENSION(npts,nvmap), INTENT(out)       :: forest_managed  !! Forest management flag: 0 = orchidee 
+                                                                              !! standard, 1= self-thinning only, 2= 
+                                                                              !! high-stand, 3= high-stand smoothed, 4= 
+                                                                              !! coppices 
+
+    !! 0.3 Modified fields
+
+
+    !! 0.4 Local variables
+    CHARACTER(LEN=80)                                      :: filename        !! A string to hold the file name
+    LOGICAL                                                :: debug=.FALSE.   !! A flag to print out debugging information.
+    INTEGER(i_std)                                         :: fid             !! The ID of the NetCDF file.
+    INTEGER(i_std)                                         :: nb_coord        !! The number of coordinates in the NetCDF file    
+    INTEGER(i_std)                                         :: nb_gat          !!
+    INTEGER(i_std)                                         :: nb_var          !! The number of variables in the NetCDF file
+    INTEGER(i_std)                                         :: nb_dim          !! The number of dimensions in the NetCDF file
+    INTEGER(i_std)                                         :: iml, jml, lml,ivm !! indices
+    INTEGER(i_std)                                         :: ip, inbv, jp    !! indices
+    LOGICAL                                                :: l_ex            !! A flag which indicates if a variable
+                                                                              !! exists in the NetCDF file
+    REAL(r_std), ALLOCATABLE, DIMENSION(:)                 :: lat_lu, lon_lu  !! The latitude and longitude read in from
+                                                                              !! the NetCDF file    
+    INTEGER,DIMENSION(flio_max_var_dims)                   :: l_d_w           !! List of the dimension lengths of the variable
+                                                                              !! in the NetCDF file
+    INTEGER(i_std)                                         :: ipts            !! index
+    INTEGER(i_std)                                         :: ALLOC_ERR       !! A flag tripped if we have an error in allocation
+    REAL(r_std),DIMENSION(:,:,:),ALLOCATABLE               :: fmmap_r         !! The map read in from the NetCDF file
+    INTEGER(i_std),DIMENSION(:,:,:),ALLOCATABLE            :: fmmap_i         !! The integer form of the map read in
+    INTEGER(i_std)                                         :: closest_lat     !! The index of the closest latitude we found.
+    INTEGER(i_std)                                         :: closest_lon     !! The index of the closest longitude we found.
+    REAL(r_std)                                            :: distance        !! The distance from the current point to the 
+                                                                              !! point on the map
+    REAL(r_std)                                            :: closest_dist    !! The distance to the closet point we've found.
+    INTEGER                                                :: large_int       !! A number which indicates that the grid data
+                                                                              !! is not available
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_ful, lon_ful
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)    :: sub_area
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:)  :: sub_index
+    CHARACTER(LEN=30) :: callsign
+    INTEGER(i_std) :: ibvm, nbvmax,ifm, ivma
+    LOGICAL ::           ok_interpol ! optionnal return of aggregate_2d
+    REAL(r_std)                                            :: sum_fm,sumf
+    REAL(r_std),DIMENSION(nfm_types)                       :: fm_sum
+    LOGICAL ::           ltemp ! temporary logical variable
+  !_ ================================================================================================================================
+
+    IF ( bavard >= 2 ) WRITE(numout,*) 'Entering read_in_fm_map'
+
+    ! This integer has to be large enough that it never shows up on the map, without being
+    ! so large that is causes overflows.  Since none of the points on the map should be
+    ! larger than the number of FM strategies we have (nfm_types), this is sufficiently big.
+    large_int = nvmap*nfm_types+1
+
+   !
+    !Config Key   = FM_FILE
+    !Config Desc  = Name of file from which the forest management map is to be read
+    !Config If    = OK_STOMATE
+    !Config Def   = FMmap.nc
+    !Config Help  = The name of the file to be opened to read a forest management
+    !Config         map (including a layer for every PFT) is given here. 
+    !Config Units = [FILE]
+    !
+    filename = 'FMmap.nc'
+    CALL getin_p('FM_FILE',filename)
+
+    IF (is_root_prc) THEN
+       IF (debug) THEN
+          WRITE(numout,*) "Entering read_in_fm_map. 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)
+
+    ! This finds the number of longitude points in the file.
+    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,*) "FM Map: iml =",iml
+
+    ! This finds the number of latitude points in the file.
+    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,*) "FM Map: jml =",jml
+
+    ! Now find the number of PFTs in the file.  If this is not equal to the number
+    ! of PFTs that we actually have, that's a problem and we'll crash.
+    IF (is_root_prc) &
+         CALL flioinqv (fid,v_n="FM_STRAT",l_ex=l_ex,nb_dims=nb_dim,len_dims=l_d_w) 
+    CALL bcast(l_d_w)
+    lml=l_d_w(3)
+
+    IF (lml /= nvmap) THEN
+       WRITE(numout,*) 'lml = ',lml
+       WRITE(numout,*) 'nvmap = ',nvmap
+       WRITE(numout,*) 'Stopping. '
+       CALL ipslerr_p (3,'sapians_forestry', &
+            &          'Problem with forest management strateg map.','lml /= nvmap', &
+            &          '(number of pft must be equal)')
+    ENDIF
+    !
+
+    ! Allocate the map that will be read in
+    WRITE(numout,*) 'Reading the Forest Management strategy file'
+    !
+    ALLOC_ERR=-1
+    ALLOCATE(fmmap_r(iml,jml,nvmap), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of fmmap_r : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(fmmap_i(iml,jml,nvmap), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of fmmap_i : ",ALLOC_ERR
+      STOP 
+    ENDIF
+
+    ! This reads in the map that is in the file
+    IF (is_root_prc) THEN
+       fmmap_r(:,:,:)=large_int*2.0
+       CALL fliogetv (fid,"FM_STRAT", fmmap_r, start=(/ 1, 1, 1 /), count=(/ iml, jml, nvmap /))
+       ! Right now the values are all real, but they should be integers.
+       ! Careful, NINT might not work if the precision of fmmap_r is not single.
+       ! In that case, IDNINT should be used.
+       DO ip=1,iml
+          DO jp=1,jml
+             DO ivma=1,nvmap
+                !  There will be some fill values in here.  If we pass
+                ! a large fill value to NINT, it crashes.  So let's 
+                ! test for it
+#ifdef __NAGFOR
+                ltemp=IEEE_IS_NAN(fmmap_r(ip,jp,ivma))    
+#else
+                ltemp=isnan(fmmap_r(ip,jp,ivma))    
+#endif
+                IF(ltemp)THEN
+                   fmmap_i(ip,jp,ivma)=large_int
+
+                ELSE
+                   IF(fmmap_r(ip,jp,ivma) .GE. 0.0 .AND. fmmap_r(ip,jp,ivma) < large_int)THEN
+                      fmmap_i(ip,jp,ivma)=NINT(fmmap_r(ip,jp,ivma))
+                   ELSE
+                      ! This value should be big enough that we don't fool ourselves
+                      ! below.
+                      fmmap_i(ip,jp,ivma)=large_int
+                   ENDIF
+                ENDIF
+             ENDDO
+          ENDDO
+       ENDDO
+    ENDIF
+
+    CALL bcast(fmmap_i)
+
+    ! Now I need to get the latitude and longitude
+    ! First, get the axes from the map file.
+    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 (is_root_prc) THEN
+       CALL fliogstc (fid, x_axis=lon_lu,y_axis=lat_lu)
+    ENDIF
+    CALL bcast(lon_lu)
+    CALL bcast(lat_lu)
+
+    ! Now I can interpolate.  Remember that we are dealing with integer
+    ! values and management strategies.  Therefore, we cannot do a strict
+    ! interpolation, since that might gives values of the strategy to be
+    ! 2.3, or something ridiculous.  We cannot just round the number, either,
+    ! since we could have some squares with 1 (no management) and some with
+    ! 3 (coppices);  An average of that would be 2 (high stands), which doesn't
+    ! make any sense.  So we look to see what the most prevalent type of
+    ! management of nearby pixels is, and then just take that.
+    
+    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 FOREST MANAGEMENT file'
+    !
+    !
+
+    !
+    ! 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
+          ! If at least one PFT has a management strategy, we should interpolate
+          ! this grid point.
+          sum_fm=SUM(fmmap_i(ip,jp,:))
+          IF ( sum_fm .GT. min_sechiba .AND. sum_fm .LT. large_int) THEN
+             mask(ip,jp) = 1
+             IF (debug) THEN
+                WRITE(numout,*) "update : SUM(fmmap(",ip,jp,")) = ",sum_fm
+             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="Forest Management 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(npts, 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(npts, 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(npts, 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
+    !
+    DO ipts = 1, npts
+       ! For this point, we need to see what dominant FM types are
+       ! nearby.
+       sumf=zero
+       ! We need to do this for every PFT
+       DO ivma=1,nvmap
+          ! If it's not a forest, we don't care.
+          IF(.NOT. is_tree(start_index(ivma)))THEN
+             forest_managed(ipts,ivma)=0
+          ELSE
+             fm_sum(:)=0.0
+             DO ibvm=1, nbvmax
+                ! Leave the do loop if all sub areas are treated, sub_area <= 0
+                IF ( sub_area(ipts,ibvm) <= zero ) EXIT
+                ip = sub_index(ipts,ibvm,1)
+                jp = sub_index(ipts,ibvm,2)
+                ifm=fmmap_i(ip,jp,ivma)
+                fm_sum(ifm)=fm_sum(ifm)+sub_area(ipts,ibvm)
+             ENDDO
+             ! Whichever FM type has the most area, we use that one.
+             forest_managed(ipts,ivma)=MAXLOC(fm_sum(:),1)
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    WRITE(numout,*) 'forestry_update : Interpolation Done for FM map'
+    !
+    DEALLOCATE(fmmap_i)
+    DEALLOCATE(fmmap_r)
+    DEALLOCATE(lat_lu,lon_lu)
+    DEALLOCATE(lat_ful,lon_ful)
+    DEALLOCATE(mask)
+    IF(ALLOCATED(sub_index)) DEALLOCATE(sub_index)
+    IF(ALLOCATED(sub_area)) DEALLOCATE(sub_area)
+
+
+   IF ( bavard >= 2 ) WRITE(numout,*) 'Leaving read_in_fm_map'
+
+  END SUBROUTINE read_in_fm_map
+
+!! ================================================================================================================================
+!! SUBROUTINE    : read_in_litter_map
+!!
+!>\BRIEF        Read in a map that gives the litter demand for each pixel.
+!!
+!! DESCRIPTION   :  Reads in a map for the litter demand of each pixel and interpolates
+!!                  to find the demand for all pixels that we are interested in.  The map
+!!                  in this case has units of gC/year.  We convert it to be gC/m**2/year, since
+!!                  all the other units in the model are given per square meter.  The litter
+!!                  demand maps can be calculated based on, for example, the demand needed
+!!                  per head of livestock for storing them indoors in the winter.  This practice
+!!                  reached its peak during the 19th century and rapidly declined afterwards
+!!                  in Europe.  If you are not interested in historical simulations or improved 
+!!                  estimation of soil carbon pools during a historical spinup, you probably 
+!!                  don't need this.
+!!     
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::litter_demand
+!!
+!! REFERENCE(S)   : 
+!!
+!! FLOWCHART    : 
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE read_in_litter_map ( npts, lalo, neighbours, resolution, contfrac, litter_demand )
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+    INTEGER(i_std), INTENT(in)                             :: npts            !! Domain size - number of pixels 
+                                                                              !! (dimensionless)
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)             :: lalo            !! Vector of latitude and longitudes (beware of the order !)
+    INTEGER(i_std), DIMENSION(npts,8), INTENT(in)          :: neighbours      !! 
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)             :: resolution      !! The size in m of each grid-box in X and Y
+    REAL(r_std), DIMENSION(npts), INTENT(in)               :: contfrac        !! Fraction of continent in the grid
+
+    !! 0.2 Output
+    REAL(r_std), DIMENSION(npts), INTENT(out)              :: litter_demand   !! The litter removed from each pixel due
+                                                                              !! to litter raking at the end of the year.
+                                                                              !! @tex $(gC year^{-1})$ @endtex
+
+    !! 0.3 Modified fields
+
+
+    !! 0.4 Local variables
+    !
+    ! PARAMETERS...taken from grid.f90.  I don't know why this variable is not in constants.f90.
+    ! default resolution (m)
+    REAL(r_std), PARAMETER :: default_resolution = 250000.
+
+    CHARACTER(LEN=80)                                      :: filename        !! A string to hold the file name
+    LOGICAL                                                :: debug=.TRUE.   !! A flag to print out debugging information.
+    INTEGER(i_std)                                         :: fid             !! The ID of the NetCDF file.
+    INTEGER(i_std)                                         :: nb_coord        !! The number of coordinates in the NetCDF file    
+    INTEGER(i_std)                                         :: nb_gat          !!
+    INTEGER(i_std)                                         :: nb_var          !! The number of variables in the NetCDF file
+    INTEGER(i_std)                                         :: nb_dim          !! The number of dimensions in the NetCDF file
+    INTEGER(i_std)                                         :: iml, jml, lml,ivm !! indices
+    INTEGER(i_std)                                         :: ip, inbv, jp    !! indices
+    LOGICAL                                                :: l_ex            !! A flag which indicates if a variable
+                                                                              !! exists in the NetCDF file
+    REAL(r_std), ALLOCATABLE, DIMENSION(:)                 :: lat_lu, lon_lu  !! The latitude and longitude read in from
+                                                                              !! the NetCDF file    
+    INTEGER,DIMENSION(flio_max_var_dims)                   :: l_d_w           !! List of the dimension lengths of the variable
+                                                                              !! in the NetCDF file
+    INTEGER(i_std)                                         :: ipts            !! index
+    INTEGER(i_std)                                         :: ALLOC_ERR       !! A flag tripped if we have an error in allocation
+    REAL(r_std),DIMENSION(:,:),ALLOCATABLE                 :: littermap       !! The map read in from the NetCDF file
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_ful, lon_ful
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)    :: sub_area
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:)  :: sub_index
+    CHARACTER(LEN=30) :: callsign
+    INTEGER(i_std) :: ibvm, nbvmax,ifm
+    LOGICAL ::           ok_interpol ! optionnal return of aggregate_2d
+    REAL(r_std)                                            :: area_sum, coslat
+    REAL(r_std),DIMENSION(nfm_types)                       :: fm_sum
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:)    :: temp_resolution
+    REAL(r_std)                :: fillvalue
+    INTEGER :: i_rc,i_v,no_fill
+    LOGICAL ::           ltemp ! temporary logical variable
+!_ ================================================================================================================================
+
+    IF ( bavard >= 2 ) WRITE(numout,*) 'Entering read_in_litter_map'
+
+    litter_demand(:)=zero
+
+   !
+    !Config Key   = FM_FILE
+    !Config Desc  = Name of file from which the forest management map is to be read
+    !Config If    = OK_STOMATE
+    !Config Def   = FMmap.nc
+    !Config Help  = The name of the file to be opened to read a forest management
+    !Config         map (including a layer for every PFT) is given here. 
+    !Config Units = [FILE]
+    !
+    filename = 'litter_map.nc'
+    CALL getin_p('LITTER_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)
+
+    ! I need the fill value of the map.  This doesn't seem to available through
+    ! the IOISPL routines that I can see.
+    ! NF90_INQ_VAR_FILL seems to be only valid for NetCDF-'?  So I am going to make
+    ! a HUGE assumption here about the fill value of the maps.  I hope that none of the values
+    ! in the maps are above this value.
+    fillvalue=1e20
+    WRITE(numout,*) "WARNING: You are using a litter demand map.  I cannot determine"
+    WRITE(numout,*) "         the fill value of this map.  I am assuming that the fill"
+    WRITE(numout,*) "         value is 1e20 and that all your real values are below that."
+    WRITE(numout,*) "         CONFIRM THIS WITH YOUR LITTER MAP!"
+    
+
+    ! This finds the number of longitude points in the file.
+    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,*) "Litter map: iml =",iml
+
+    ! This finds the number of latitude points in the file.
+    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,*) "Litter map: jml =",jml
+
+    ! Now find the number of PFTs in the file.  If this is not equal to the number
+    ! of PFTs that we actually have, that's a problem and we'll crash.
+    IF (is_root_prc) &
+         CALL flioinqv (fid,v_n="LITTER_DEMAND",l_ex=l_ex,nb_dims=nb_dim,len_dims=l_d_w) 
+    CALL bcast(l_d_w)
+
+    !
+
+    ! Allocate the map that will be read in
+    WRITE(numout,*) 'Reading the litter file',l_d_w
+    !
+    ALLOC_ERR=-1
+    ALLOCATE(littermap(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of littermap : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+
+    ! This reads in the map that is in the file
+    IF (is_root_prc) THEN
+       CALL fliogetv (fid,"LITTER_DEMAND", littermap, start=(/ 1, 1 /), count=(/ iml, jml /))
+    ENDIF
+
+    CALL bcast(littermap)
+
+    ! Now I need to get the latitude and longitude
+    ! First, get the axes from the map file.
+    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 (is_root_prc) THEN
+       CALL fliogstc (fid, x_axis=lon_lu,y_axis=lat_lu)
+    ENDIF
+    CALL bcast(lon_lu)
+    CALL bcast(lat_lu)
+
+    ! Now I can interpolate.  This should be straightforward, since
+    ! we are interpolating real numbers.
+    
+    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
+    
+    ! The map is in absolute numbers.  We cannot interpolate absolute numbers, we want
+    ! to add them together (or subtract them, if we are going to finer resolution).  Therefore,
+    ! let's convert all the map values to per m**2 first, interpolate that, and then
+    ! convert back to absolute numbers.
+    ! This is ugly.  Unfortunately, we had to steal this from grid.f90, since the resolution is
+    ! not passed for every grid square, just those that we are interested in.
+    ALLOC_ERR=-1
+    ALLOCATE(temp_resolution(iml,jml,2), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of temp_resolution : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    DO ip=1,iml
+       DO jp=1,jml
+          !
+          ! 2 resolution
+          !
+          
+          !
+          ! 2.1 longitude
+          !
+          
+          ! prevent infinite resolution at the pole
+          coslat = MAX( COS( lat_ful(ip,jp) * pi/180. ), mincos )     
+          IF ( iml .GT. 1 ) THEN
+             
+             IF ( ip .EQ. 1 ) THEN
+                temp_resolution(ip,jp,1) = &
+                     ABS( lon_ful(ip+1,jp) - lon_ful(ip,jp) ) * &
+                     pi/180. * R_Earth * coslat
+             ELSEIF ( ip .EQ. iml ) THEN
+                temp_resolution(ip,jp,1) = &
+                     ABS( lon_ful(ip,jp) - lon_ful(ip-1,jp) ) * &
+                     pi/180. * R_Earth * coslat
+             ELSE
+                temp_resolution(ip,jp,1) = &
+                     ABS( lon_ful(ip+1,jp) - lon_ful(ip-1,jp) )/2. *&
+                     pi/180. * R_Earth * coslat
+             ENDIF
+             
+          ELSE
+             
+             temp_resolution(ip,jp,1) = default_resolution
+             
+          ENDIF
+
+          !
+          ! 2.2 latitude
+          !
+          
+          IF ( jml .GT. 1 ) THEN
+
+             IF ( jp .EQ. 1 ) THEN
+                temp_resolution(ip,jp,2) = &
+                     ABS( lat_ful(ip,jp) - lat_ful(ip,jp+1) ) * &
+                     pi/180. * R_Earth
+             ELSEIF ( jp .EQ. jml ) THEN
+                temp_resolution(ip,jp,2) = &
+                     ABS( lat_ful(ip,jp-1) - lat_ful(ip,jp) ) * &
+                     pi/180. * R_Earth
+             ELSE
+                temp_resolution(ip,jp,2) = &
+                     ABS( lat_ful(ip,jp-1) - lat_ful(ip,jp+1) )/2. *&
+                     pi/180. * R_Earth
+             ENDIF
+             
+          ELSE
+             
+             temp_resolution(ip,jp,2) = default_resolution
+
+          ENDIF
+             
+#ifdef __NAGFOR
+                ltemp=IEEE_IS_NAN(littermap(ip,jp))
+#else
+                ltemp=isnan(littermap(ip,jp))
+#endif
+          IF( .NOT. ltemp)THEN
+
+             IF(littermap(ip,jp) .LT. fillvalue)THEN
+                ! Convert to per square meter for the interpolation if this is a real map value.
+                littermap(ip,jp)=littermap(ip,jp)/temp_resolution(ip,jp,1)/temp_resolution(ip,jp,2)
+             ENDIF
+             
+          ENDIF
+          
+       ENDDO
+
+    ENDDO
+
+    !
+    WRITE(numout,*) 'Reading the LITTER file'
+    !
+    !
+
+    !
+    ! 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
+          ! If the grid has any litter, we should interpolate
+          ! this grid point.
+#ifdef __NAGFOR
+                ltemp=IEEE_IS_NAN(littermap(ip,jp))
+#else
+                ltemp=isnan(littermap(ip,jp))
+#endif
+          IF( .NOT. ltemp)THEN
+             IF ( littermap(ip,jp) .GT. min_sechiba .AND. littermap(ip,jp) .LT. fillvalue ) THEN
+                mask(ip,jp) = 1
+                IF (debug) THEN
+                   WRITE(numout,*) "update : littermap(",ip,jp,")) = ",littermap(ip,jp)
+                ENDIF
+             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="Litter 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(npts, 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(npts, 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(npts, 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
+    !
+    DO ipts = 1, npts
+
+       litter_demand(ipts)=zero
+       area_sum=zero
+
+       DO ibvm=1, nbvmax
+          ! Leave the do loop if all sub areas are treated, sub_area <= 0
+          IF ( sub_area(ipts,ibvm) <= zero ) EXIT
+          ip = sub_index(ipts,ibvm,1)
+          jp = sub_index(ipts,ibvm,2)
+          area_sum=area_sum+sub_area(ipts,ibvm)
+          litter_demand(ipts)=litter_demand(ipts)+sub_area(ipts,ibvm)*littermap(ip,jp)
+       ENDDO
+
+       IF(area_sum .LT. min_stomate)THEN
+          WRITE(numout,*) 'Missing data for the litter map on this land point!'
+          WRITE(numout,*) 'ipts,lalo',ipts,lalo(ipts,:)
+          litter_demand(ipts)=zero
+       ELSE
+          litter_demand(ipts)=litter_demand(ipts)/area_sum
+          ! This is in gC/year/m**2 from the interpolation.  I need to convert it back
+          ! to absolute numbers.
+          litter_demand(ipts)=litter_demand(ipts)*resolution(ipts,1)*resolution(ipts,2)
+       ENDIF
+
+    ENDDO
+
+    !
+    WRITE(numout,*) 'forestry_update : Interpolation Done for litter map'
+    !
+    DEALLOCATE(littermap)
+    DEALLOCATE(temp_resolution)
+    DEALLOCATE(lat_lu,lon_lu)
+    DEALLOCATE(lat_ful,lon_ful)
+    DEALLOCATE(mask)
+    IF(ALLOCATED(sub_index)) DEALLOCATE(sub_index)
+    IF(ALLOCATED(sub_area)) DEALLOCATE(sub_area)
+
+
+   IF ( bavard >= 2 ) WRITE(numout,*) 'Leaving read_in_litter_map'
+
+  END SUBROUTINE read_in_litter_map
+
+!! ================================================================================================================================
+!! SUBROUTINE    : litter_raking
+!!
+!>\BRIEF        Read in a map that gives the litter demand for each pixel.
+!!
+!! DESCRIPTION   :  Reads in a map for the litter demand of each pixel and interpolates
+!!                  to find the demand for all pixels that we are interested in.  The map
+!!                  in this case has units of gC/year.  We convert it to be gC/m**2/year, since
+!!                  all the other units in the model are given per square meter.  The litter
+!!                  demand maps can be calculated based on, for example, the demand needed
+!!                  per head of livestock for storing them indoors in the winter.  This practice
+!!                  reached its peak during the 19th century and rapidly declined afterwards
+!!                  in Europe.  If you are not interested in historical simulations or improved 
+!!                  estimation of soil carbon pools during a historical spinup, you probably 
+!!                  don't need this.
+!!     
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::litter_demand
+!!
+!! REFERENCE(S)   : 
+!!
+!! FLOWCHART    : 
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE litter_raking ( npts, veget_max, resolution, litter_demand, litter, lrake_frac )
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+    INTEGER(i_std), INTENT(in)                             :: npts            !! Domain size - number of pixels 
+                                                                              !! (dimensionless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)                :: veget_max       !! "Maximal" coverage fraction of a PFT (LAI 
+                                                                              !! -> infinity) on ground
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)             :: resolution      !! The size in m of each grid-box in X and Y
+    REAL(r_std), DIMENSION(npts), INTENT(in)               :: litter_demand   !! The litter removed from each pixel due
+                                                                              !! to litter raking at the end of the year.
+                                                                              !! @tex $(gC year^{-1})$ @endtex
+
+    !! 0.2 Output
+    REAL(r_std), DIMENSION(:,:), INTENT(OUT)                :: lrake_frac      !! TEMP
+
+
+    !! 0.3 Modified fields
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: litter                  !! Metabolic and structural litter, above 
+                                                                                !! and below ground 
+                                                                                !! @tex $(gC m^{-2})$ @endtex 
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                   :: ipts, ivm               !! Indices
+    REAL(r_std)                                      :: total_litter,ind_litter, crop_frac, forest_frac, litter_transfer
+    REAL(r_std),DIMENSION(nlitt)                     :: litter_ratio
+    REAL(r_std),DIMENSION(nvm)                       :: lfrac
+    INTEGER(i_std) :: ncrops
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements)   :: check_intern      !! Contains the components of the internal
+                                                                              !! mass balance chech for this routine
+                                                                              !! @tex $(gC m^{-2} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)           :: closure_intern    !! Check closure of internal mass balance
+                                                                              !! @tex $(gC m^{-2} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)           :: pool_start        !! Start pool of this routine 
+                                                                              !! @tex $(gC m^{-2} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)           :: pool_end          !! End pool of this routine 
+                                                                              !! @tex $(gC m^{-2} dt^{-1})$ @endtex
+    REAL(r_std)                                          :: temp_sum          !! Temporary storage
+    INTEGER(i_std)                                   :: iele, ilitt, ilevs, imbc     !! Indices
+    REAL(r_std), DIMENSION(npts,nvm)                 :: pft_area              !! The absolute area covered by this PFT
+                                                                              !! @tex $(m^2)$ @endtex
+    REAL(r_std), DIMENSION(npts)                 :: pixel_area              !! The absolute area covered by this PFT
+                                                                              !! @tex $(m^2)$ @endtex
+    REAL(r_std) :: litter_lost,litter_gained
+    LOGICAL :: lall_litter
+!_ ================================================================================================================================
+
+    IF ( bavard >= 2 ) WRITE(numout,*) 'Entering litter_raking'
+
+    DO ipts=1,npts
+       pft_area(ipts,:)=resolution(ipts,1)*resolution(ipts,2)* veget_max(ipts,:)
+       pixel_area(ipts)=resolution(ipts,1)*resolution(ipts,2)
+    ENDDO
+
+    !! 1.1 Initialize check for mass balance closure  
+    !  Initial values of litter
+    ! We cannot check the litter for every PFT individually, since
+    ! we are moving litter between forest and crop PFTs.
+    ! We have no problem doing this every time this routine is called
+    ! because it's only called at the end of the year and this calculation
+    ! is not very expensive.
+    pool_start(:,:,:) = zero
+    
+    DO iele = 1,nelements
+       
+       ! Litter pool (gC m-2) *  (m2 m-2) 
+       DO ilitt = 1,nlitt
+          DO ilevs = 1,nlevs
+             pool_start(:,:,iele) = pool_start(:,:,iele) + &
+                  litter(:,ilitt,:,ilevs,iele) * veget_max(:,:)
+          ENDDO
+       ENDDO
+       
+       
+    ENDDO ! # nelements
+
+    lrake_frac(:,:)=zero
+
+    ! We need to find how much litter we can get from the forests for each grid point.
+    DO ipts=1,npts
+       litter_lost=zero
+       litter_gained=zero
+       total_litter=zero
+       DO ivm=1,nvm
+          IF(is_tree(ivm))THEN
+             ! We will take all the above ground litter, since that is what a farmer
+             ! could pick up.  Unlikely they dug into the soil to collect litter.
+             ! Notice these are in absolute units, not per square meter.
+             total_litter=total_litter+SUM(litter(ipts,:,ivm,iabove,icarbon))&
+                  *pft_area(ipts,ivm)
+          ENDIF
+       ENDDO
+
+       ! If we have no forest litter, we cannot rake anything.
+       IF(total_litter .LT. min_stomate)CYCLE
+
+       ! The forests are tricky.  The litter they produce will not necessarily be proportional
+       ! to the area they take up.  We want to reduce the amount of litter in each forest in a way
+       ! that doesn't leave any litter pools negative.
+       lfrac(:)=zero
+       DO ivm=1,nvm
+          IF(is_tree(ivm))THEN
+             lfrac(ivm)=SUM(litter(ipts,:,ivm,iabove,icarbon))&
+                  *pft_area(ipts,ivm)/total_litter
+          ENDIF
+       ENDDO
+
+       ! Now compute the amount of the litter that we need to take to satisfy our demand.
+       litter_transfer=litter_demand(ipts)
+
+       ! We don't take more litter than we have.  I'm also putting in a logical flag to prevent
+       ! us from having numerical issues.
+       lall_litter=.FALSE.
+       IF(litter_transfer .GT. total_litter) THEN
+          lall_litter=.TRUE.
+          litter_transfer=total_litter
+       ENDIF
+
+       ! How many crop PFTs are present on this grid square?
+       crop_frac=zero
+       DO ivm=1,nvm
+          IF(.NOT. natural(ivm))THEN
+             crop_frac=crop_frac+veget_max(ipts,ivm)
+          ENDIF
+       ENDDO
+
+       IF(crop_frac .GT. min_stomate)THEN
+          DO ivm=1,nvm
+
+             IF(veget_max(ipts,ivm) .LE. min_stomate) CYCLE
+
+             ! If we have a forest, we remove litter.  Keep the ratio of the pools the same.
+             IF(is_tree(ivm))THEN
+                ind_litter=SUM(litter(ipts,:,ivm,iabove,icarbon))*&
+                     pft_area(ipts,ivm)
+                !  I guess there is a chance that a forest has no litter.  This
+                ! means there is nothing to take away.
+                IF(ind_litter .LE. min_stomate)CYCLE
+
+                litter_ratio(:)=litter(ipts,:,ivm,iabove,icarbon)*&
+                     pft_area(ipts,ivm)/ind_litter
+                lrake_frac(ipts,ivm)=lfrac(ivm)*litter_transfer/ind_litter
+                ! We don't want to have negative litter values
+                IF(lall_litter)THEN
+                   ind_litter=zero
+                ELSE
+                   ind_litter=ind_litter-lfrac(ivm)*litter_transfer
+                ENDIF
+                litter_lost=litter_lost-lfrac(ivm)*litter_transfer
+
+                ! This is a problem.  We are taking differences of numbers which are 1e9 or so, which means
+                ! we could have a negative value that is insignificant.  I put the 
+                ! flag to try to prevent that.
+                IF(.NOT. lall_litter .AND. ind_litter .LT. -min_stomate)THEN
+                   WRITE(numout,*) "Took away too much litter!"
+                   WRITE(numout,*) "ipts,ivm:",ipts,ivm
+                   WRITE(numout,*) "lfrac(ivm),ind_litter,litter_transfer: ",&
+                        lfrac(ivm),SUM(litter(ipts,:,ivm,iabove,icarbon))*&
+                        pft_area(ipts,ivm),litter_transfer
+                ENDIF
+                litter(ipts,:,ivm,iabove,icarbon)=litter_ratio(:)*ind_litter&
+                     /pft_area(ipts,ivm)
+
+             ELSEIF( .NOT. natural(ivm))THEN
+                ! If we have a crop, we add litter.
+                ind_litter=SUM(litter(ipts,:,ivm,iabove,icarbon))*pft_area(ipts,ivm)
+                ! Is it possible that we have no crop litter but we have veget_max?  Maybe.
+                IF(ind_litter .LT. min_stomate)THEN
+                   litter_ratio(:)=un/REAL(nlitt)
+                ELSE
+                   litter_ratio(:)=litter(ipts,:,ivm,iabove,icarbon)*pft_area(ipts,ivm)/ind_litter
+                ENDIF
+                ! This is the total litter we have for this PFT in this pixel
+                ind_litter=ind_litter+veget_max(ipts,ivm)/crop_frac*litter_transfer
+                litter_gained=litter_gained+veget_max(ipts,ivm)/crop_frac*litter_transfer
+                litter(ipts,:,ivm,iabove,icarbon)=litter_ratio(:)*ind_litter&
+                     /pft_area(ipts,ivm)
+
+             ENDIF ! checking to see if this PFT is a crop or forest
+
+
+          ENDDO ! loop over PFTs
+
+       ELSE
+          ! We have no agricultural PFTs to move the litter to, so we
+          ! assume that no litter raking was done in this grid square.
+       ENDIF ! checking to see if we have crops
+
+    ENDDO ! loop over pixels
+    
+ !! 2. Check mass balance closure
+   
+    !  Consider this whole routine as a black box with incoming and outgoing 
+    !  fluxes and a change in the mass of the box. Express in absolute 
+    !  units gC (or gN), hence, multiply with dt and veget_max. In most routines 
+    !  veget_max does not change and could be omitted but a general approach 
+    !  was prefered.
+
+    !! 2.1 Calculate pools at the end of the routine
+    pool_end = zero
+    DO iele = 1,nelements
+       DO ilitt = 1,nlitt
+          DO ilevs = 1,nlevs
+             pool_end(:,:,iele) = pool_end(:,:,iele) + &
+                  litter(:,ilitt,:,ilevs,iele) * veget_max(:,:)
+          ENDDO
+       ENDDO
+    ENDDO
+
+     !! 2.2 Calculate components of the mass balance
+    check_intern(:,:,iatm2land,icarbon) = zero
+    check_intern(:,:,iland2atm,icarbon) = -un * zero
+    check_intern(:,:,ilat2out,icarbon) = zero
+    check_intern(:,:,ilat2in,icarbon) = -un * zero
+    check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - pool_start(:,:,icarbon))
+    closure_intern = zero
+    DO imbc = 1,nmbcomp
+       closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + check_intern(:,:,imbc,icarbon)
+    ENDDO
+ 
+    ! Write outcome.  We sum over all the PFTs in the gridcell here.
+    DO ipts=1,npts
+       IF(ABS(SUM(closure_intern(ipts,:,icarbon))) .LE. min_stomate)THEN
+          IF (ld_massbal) WRITE(numout,*) 'Mass balance closure in litter_raking'
+       ELSE
+          WRITE(numout,*) 'Error: mass balance is not closed in litter_raking'
+          DO ivm=1,nvm
+             WRITE(numout,*) '   ipts,ivm; ', ipts,ivm
+             WRITE(numout,*) '   Difference is, ', closure_intern(ipts,ivm,icarbon)
+             WRITE(numout,*) '   pool_end,pool_start: ', pool_end(ipts,ivm,icarbon), pool_start(ipts,ivm,icarbon)
+          ENDDO
+          IF(ld_stop)THEN
+             CALL ipslerr_p (3,'litter_raking', 'Mass balance error.','','')
+          ENDIF
+       ENDIF
+    ENDDO
+    
+    IF ( bavard >= 2 ) WRITE(numout,*) 'Leaving litter_raking'
+    
+  END SUBROUTINE litter_raking
+
+END MODULE sapiens_forestry
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/sapiens_kill.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/sapiens_kill.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/sapiens_kill.f90	(revision 7236)
@@ -0,0 +1,1526 @@
+! =================================================================================================================================
+! MODULE       : sapiens_kill
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Kill all vegetation scheduled for killing by human activities.
+!!
+!!\n DESCRIPTION : Actually kills biomass.  The biomass is scheduled for killing
+!!       by the variable circ_class_kill in other sapiens routines.  Here the
+!!       biomass is moved to the litter and harvest pools, as appropriate.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S) : 
+!! - Sitch, S., B. Smith, et al. (2003), Evaluation of ecosystem dynamics,
+!!         plant geography and terrestrial carbon cycling in the LPJ dynamic 
+!!         global vegetation model, Global Change Biology, 9, 161-185.\n
+!! - Waring, R. H. (1983). "Estimating forest growth and efficiency in relation 
+!!         to canopy leaf area." Advances in Ecological Research 13: 327-354.\n
+!! 
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_stomate/lpj_gap.f90 $
+!! $Date: 2013-08-19 17:50:44 +0200 (Mon, 19 Aug 2013) $
+!! $Revision: 1425 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE sapiens_kill
+
+  ! modules used:
+
+  USE stomate_data
+  USE pft_parameters
+  USE ioipsl_para 
+  USE function_library,       ONLY : distribute_mortality_biomass,&
+                                     nmax,  wood_to_dia
+  USE constantes
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC gap_prog_sapiens
+  
+  ! Variable declaration 
+
+CONTAINS
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : gap_prog_sapiens
+!!
+!>\BRIEF        Transfer dead biomass to litter and update stand density as a result
+!!              of human activities.
+!!
+!! DESCRIPTION  : This routine has a simple purpose: kill individuals by human activities.  
+!!   The variable circ_class_kill indicates how many individuals need to be killed by the various
+!!   processes in the code, and is calculated in other modules.  gap_prog_sapiens takes
+!!   this variable and decides on the correct order of which to actually kill the
+!!   trees.  As these are all human activities, some of the biomass may be moved to
+!!   harvest pools, while other parts are moved to litter.
+!!
+!! RECENT CHANGE(S): 
+!!
+!! MAIN OUTPUT VARIABLE(S): ::circ_class_biomass; ::biomass; ::ind
+!!
+!! REFERENCE(S)   :
+!! - Sitch, S., B. Smith, et al. (2003), Evaluation of ecosystem dynamics,
+!!         plant geography and terrestrial carbon cycling in the LPJ dynamic 
+!!         global vegetation model, Global Change Biology, 9, 161-185.
+!! - Waring, R. H. (1983). "Estimating forest growth and efficiency in relation 
+!!         to canopy leaf area." Advances in Ecological Research 13: 327-354.
+!!
+!! FLOWCHART    : None
+!!\n
+!_ ================================================================================================================================
+ 
+  SUBROUTINE gap_prog_sapiens (npts, biomass, ind,  &
+       bm_to_litter, circ_class_biomass, circ_class_kill, &
+       circ_class_n, harvest_pool_bound, harvest_pool, harvest_type, &
+       harvest_cut, harvest_area, resolution, &
+       veget_max, age_stand, last_cut, mai_count, circ_class_dist, &
+       coppice_dens)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables 
+    INTEGER(i_std), INTENT(in)                                   :: npts               !! Domain size (-)
+    REAL(r_std), DIMENSION(0:ndia_harvest+1), INTENT(in)         :: harvest_pool_bound !! The boundaries of the diameter classes
+
+                                                                                       !! in the wood harvest pools
+                                                                                       !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,2), INTENT(in)                    :: resolution         !! The length of each grid-box in X and Y
+                                                                                       !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)                   :: veget_max          !! Maximum fraction of vegetation type 
+    REAL(r_std), DIMENSION(ncirc), INTENT(in)                    :: circ_class_dist    !! The probability distribution of trees 
+                                                                                       !! in a circ class in case of a 
+                                                                                       !! redistribution (unitless).
+    REAL(r_std), DIMENSION(npts,nvm),INTENT(in)                  :: coppice_dens       !! The density of a coppice at the first
+                                                                                       !! cutting.
+                                                                                       !! @tex $( 1 / m**2 )$ @endtex 
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables   
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                             INTENT(inout)       :: biomass            !! Biomass @tex $(gC m^{-2}) $@endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)              :: ind                !! Stand level number of individuals 
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements), &                         
+                                              INTENT(inout)      :: circ_class_biomass !! Biomass of the components of the model  
+                                                                                       !! tree within a circumference
+                                                                                       !! class @tex $(gC ind^{-1})$ @endtex  
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(inout)        :: circ_class_n       !! Number of individuals in each circ class
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nfm_types,ncut_times),&
+                                                  INTENT(inout)  :: circ_class_kill    !! Number of trees within a circ that needs
+                                                                                       !! to be killed @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                                  INTENT(inout)  :: bm_to_litter       !! Biomass transfer to litter 
+                                                                                       !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)               :: harvest_pool       !! The wood and biomass that have been
+                                                                                       !! havested by humans @tex $(gC)$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_type       !! Type of management that resulted
+                                                                                       !! in the harvest (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_cut        !! Type of cutting that was used for the harvest
+                                                                                       !! (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_area       !! Harvested area (m^{2})
+    INTEGER(i_std), DIMENSION(npts,nvm),INTENT(inout)            :: last_cut           !! Years since last thinning or clearcut (years)
+    INTEGER(i_std), DIMENSION(npts,nvm),INTENT(inout)            :: age_stand          !! Age of stand (years)
+    INTEGER(i_std), DIMENSION(npts,nvm),INTENT(inout)            :: mai_count          !! The number of times we've
+                                                                                       !! calculated the volume increment
+                                                                                       !! for a stand
+ 
+    !! 0.4 Local variables
+    INTEGER(i_std)                                               :: ipts,ivm           !! Indices
+    INTEGER(i_std)                                               :: iele               !! Indices
+    INTEGER(i_std)                                               :: ipar, imbc         !! Indices
+    
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements)           :: check_intern       !! Contains the components of the internal
+                                                                                       !! mass balance chech for this routine
+                                                                                       !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)                   :: closure_intern     !! Check closure of internal mass balance
+                                                                                       !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)                   :: pool_start         !! Start pool of this routine 
+                                                                                       !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)                   :: pool_end           !! End pool of this routine 
+                                                                                       !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+!_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering gap_prog_sapiens'
+
+!! 2. Initialize variables
+
+    ! 2.1 Initialize check for mass balance closure
+    !  The mass balance is calculated at the end of this routine
+    !  in section .
+    pool_start = zero
+    DO ipar = 1,nparts
+       DO iele = 1,nelements
+          !  Initial litter and biomass
+          pool_start(:,:,iele) = pool_start(:,:,iele) + &
+               (biomass(:,:,ipar,iele) * veget_max(:,:)) + &
+               (bm_to_litter(:,:,ipar,iele) * veget_max(:,:))
+       ENDDO
+    ENDDO
+
+    ! The biomass harvest pool shouldn't be multiplied by veget_max
+    ! its units are already in gC pixel-1
+    ! Right now the harvest pool is in gC.  We will divide by the
+    ! resolution to make it per pixel.
+    ! 
+    DO ipts = 1, npts
+       pool_start(ipts,:,icarbon) = pool_start(ipts,:,icarbon) + &
+         SUM(harvest_pool(ipts,:,:,icarbon),2) / &
+         (resolution(ipts,1) * resolution(ipts,2))
+    ENDDO
+
+ !! 3. Kill plants
+
+    DO  ipts = 1,npts ! loop over land_points
+
+       DO ivm = 2,nvm  ! loop over #PFT
+
+          IF(veget_max(ipts,ivm) == zero)THEN
+              ! this vegetation type is not present, so no reason to do the 
+              ! calculation
+              CYCLE
+          ENDIF
+
+
+          DO iele = 1,nelements
+
+             ! Clearcuts and thinning can only happen on trees.
+             IF(is_tree(ivm))THEN
+
+
+                ! Now see if there are any plants to be killed by a clearcut.
+                ! Only the stems are harvested.  This should be done before
+                ! a thinning so that we don't overcount.
+                CALL clearcut_harvest_aboveground_dead_roots(npts, ipts, ivm, iele, &
+                     ifm_thin, icut_clear, biomass, ind, bm_to_litter, &
+                     circ_class_biomass, circ_class_kill, circ_class_n, harvest_pool, &
+                     harvest_type, harvest_cut, harvest_area, &
+                     harvest_pool_bound, resolution, veget_max, last_cut, age_stand, &
+                     mai_count, un - branch_ratio(ivm))
+
+
+                ! Not only do we harvest stems during thinning, we have to adjust
+                ! the mortality.  We'll do all this in a subroutine.
+                CALL thinning_harvest_aboveground_dead_roots(npts, ipts, ivm, iele, &
+                     ifm_thin, icut_thin, biomass, ind, bm_to_litter, &
+                     circ_class_biomass, circ_class_kill, circ_class_n, harvest_pool, &
+                     harvest_type, harvest_cut, harvest_area, &
+                     harvest_pool_bound, resolution, veget_max, last_cut, &
+                     un - branch_ratio(ivm))
+
+                ! And the final cut of an SRC, where the underground wood dies.  This is
+                ! exactly the same as the clearcut above, except that we take all
+                ! of the aboveground biomass.
+                CALL clearcut_harvest_aboveground_dead_roots(npts, ipts, ivm, iele, &
+                     ifm_src, icut_cop3, biomass, ind, bm_to_litter, &
+                     circ_class_biomass, circ_class_kill, circ_class_n, harvest_pool, &
+                     harvest_type, harvest_cut, harvest_area, &
+                     harvest_pool_bound, resolution, veget_max, last_cut, age_stand, &
+                     mai_count, un)
+
+               ! Have we cut a coppice system for the first time?
+                CALL first_coppice_cut(npts, ipts, ivm, iele, ifm_cop, &
+                     icut_cop1, harvest_pool_bound, resolution, veget_max, biomass, &
+                     ind, circ_class_biomass, circ_class_n, circ_class_kill, &
+                     bm_to_litter, harvest_pool, harvest_type, harvest_cut, &
+                     harvest_area, last_cut)
+                CALL first_coppice_cut(npts, ipts, ivm, iele, ifm_src, &
+                     icut_cop1, harvest_pool_bound, resolution, veget_max, biomass, &
+                     ind, circ_class_biomass, circ_class_n, circ_class_kill, &
+                     bm_to_litter, harvest_pool, harvest_type, harvest_cut, &
+                     harvest_area, last_cut)
+
+                ! What if we coppice for the second (and subsequent) cuts?
+                CALL second_coppice_cut(npts, ipts, ivm, iele, ifm_cop, &
+                     icut_cop2, harvest_pool_bound, resolution, veget_max, biomass, &
+                     ind, circ_class_biomass, circ_class_n, circ_class_kill, &
+                     bm_to_litter, harvest_pool, harvest_type, harvest_cut, &
+                     harvest_area, circ_class_dist, last_cut, coppice_dens)
+                ! For short rotation coppices
+                CALL second_coppice_cut(npts, ipts, ivm, iele, ifm_src, &
+                     icut_cop2, harvest_pool_bound, resolution, veget_max, biomass, &
+                     ind, circ_class_biomass, circ_class_n, circ_class_kill, &
+                     bm_to_litter, harvest_pool, harvest_type, harvest_cut, &
+                     harvest_area, circ_class_dist, last_cut, coppice_dens)
+
+             ENDIF ! is_tree(ivm)
+
+             ! Here some circ classes may be empty.  We do not want to do
+             ! anything about that yet, since we have not killed the natural
+             ! mortality biomass.  If we redistribute the biomass now we will
+             ! change the circ_class_biomass, but the old values for this
+             ! were used to determine circ_class_kill(inatural) in 
+             ! stomate_mark_kill.  If we change those values we will kill 
+             ! the wrong amount of biomass in lpj_gap.
+
+          ENDDO ! loop over elements
+
+       ENDDO  ! loop over pfts
+
+    END DO ! loop over land points
+
+ !! 4. Check mass balance closure
+   
+    !  Consider this whole routine as a black box with incoming and outgoing 
+    !  fluxes and a change in the mass of the box. Express in absolute 
+    !  units gC (or gN), hence, multiply with dt and veget_max. In most routines 
+    !  veget_max does not change and could be omitted but a general approach 
+    !  was prefered.
+
+    !! 4.1 Calculate pools at the end of the routine
+    pool_end = zero
+    DO ipar = 1,nparts
+       DO iele = 1,nelements
+          pool_end(:,:,iele) = pool_end(:,:,iele) + &
+               (biomass(:,:,ipar,iele) * veget_max(:,:)) + &
+               (bm_to_litter(:,:,ipar,iele) * veget_max(:,:))
+       ENDDO
+    ENDDO
+   
+    ! The biomass harvest pool shouldn't be multiplied by veget_max
+    ! its units are already in gC pixel-1
+    ! Right now the harvest pool is in gC.  We will divide by the
+    ! resolution to make it per pixel.
+    ! 
+    DO ipts = 1, npts
+       pool_end(ipts,:,icarbon) = pool_end(ipts,:,icarbon) + &
+            SUM(harvest_pool(ipts,:,:,icarbon),2) / &
+            (resolution(ipts,1) * resolution(ipts,2))
+    ENDDO
+
+    !! 4.2 Calculate components of the mass balance
+    check_intern(:,:,iatm2land,icarbon) = zero
+    check_intern(:,:,iland2atm,icarbon) = -un * zero
+    check_intern(:,:,ilat2out,icarbon) = zero
+    check_intern(:,:,ilat2in,icarbon) = -un * zero
+    check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - &
+         pool_start(:,:,icarbon))
+    closure_intern = zero
+    DO imbc = 1,nmbcomp
+       closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + &
+            check_intern(:,:,imbc,icarbon)
+    ENDDO
+ 
+    ! Write outcome
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          IF(ABS(closure_intern(ipts,ivm,icarbon)) .LE. min_stomate)THEN
+             IF (ld_massbal) WRITE(numout,*) 'Mass balance closure in sapiens_kill.f90'
+          ELSE
+             WRITE(numout,*) 'Error: mass balance is not closed in sapiens_kill.f90'
+             WRITE(numout,*) '   ipts,ivm; ', ipts,ivm
+             WRITE(numout,*) '   Difference is, ', closure_intern(ipts,ivm,icarbon)
+             WRITE(numout,*) '   pool_end,pool_start: ', pool_end(ipts,ivm,icarbon), pool_start(ipts,ivm,icarbon)
+             IF(ld_stop)THEN
+                CALL ipslerr_p (3,'gap_prog_sapiens', 'Mass balance error.','','')
+             ENDIF
+          ENDIF
+       ENDDO
+    ENDDO
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving gap_prog_sapiens'
+
+  END SUBROUTINE gap_prog_sapiens
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : thinning_harvest_aboveground_dead_roots
+!!
+!>\BRIEF        Transfer dead biomass to litter and update stand density due
+!!              to thinning operations
+!!
+!! DESCRIPTION  : Moves dead biomass to the litter pool and the harvest pool
+!!                where appropriate.  Since not all the trees are killed,
+!!                fewer counters have to be reset here than in the clearcut
+!!                case.  In addition, thinning will change the fraction of
+!!                trees killed by mortality, so we account for that as well.
+!!
+!!                NOTE: If harvest_fraction is 1, all the aboveground biomass is
+!!                      harvested.  If it's 1-branch_ratio, only stems are 
+!!                      harvested.  Belowground wood, roots, fruits, and
+!!                      leaves all become litter.  A portion of aboveground
+!!                      wood is put in the harvest pool.  Reserves and labile
+!!                      carbon are assumed to be distributed evenly across
+!!                      all non-heartwood components.
+!!
+!! RECENT CHANGE(S): 
+!!
+!! MAIN OUTPUT VARIABLE(S): ::circ_class_biomass; biomass, ::ind density of individuals, 
+!! ::circ_class_kill
+!!
+!! REFERENCE(S)   :
+!!
+!! FLOWCHART    : None
+!!\n
+!_ ================================================================================================================================
+ 
+  SUBROUTINE thinning_harvest_aboveground_dead_roots (npts, ipts, ivm, iele, &
+       ifm, icut, biomass, ind, bm_to_litter, &
+       circ_class_biomass, circ_class_kill, circ_class_n, harvest_pool, &
+       harvest_type, harvest_cut, harvest_area, &
+       harvest_pool_bound, resolution, veget_max, last_cut, harvest_fraction)
+
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables 
+    INTEGER(i_std), INTENT(in)                                   :: npts               !! Domain size (-)
+    INTEGER(i_std), INTENT(in)                                   :: ipts               !! current grid square
+    INTEGER(i_std), INTENT(in)                                   :: ivm                !! current PFT
+    INTEGER(i_std), INTENT(in)                                   :: iele               !! current element type
+    INTEGER(i_std), INTENT(in)                                   :: ifm                !! current fm strategy
+    INTEGER(i_std), INTENT(in)                                   :: icut               !! current cut time
+    REAL(r_std), DIMENSION(0:ndia_harvest+1), INTENT(in)         :: harvest_pool_bound !! The boundaries of the diameter classes
+                                                                                       !! in the wood harvest pools
+                                                                                       !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,2), INTENT(in)                    :: resolution         !! The length of each grid-box in X and Y
+                                                                                       !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)                   :: veget_max          !! Maximum fraction of vegetation type 
+    REAL(r_std),INTENT(in)                                       :: harvest_fraction   !! The fraction of the aboveground
+                                                                                       !! biomass that is harvested.  This is
+                                                                                       !! generally 1-branch_ratio if you only
+                                                                                       !! want to harvest the stems, and 1 if
+                                                                                       !! you want to harvest everything.
+
+
+    !! 0.2 Output variables
+
+
+    !! 0.3 Modified variables   
+
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                             INTENT(inout)       :: biomass            !! Biomass @tex $(gC m^{-2}) $@endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)              :: ind                !! Stand level number of individuals 
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements), &                         
+                                              INTENT(inout)      :: circ_class_biomass !! Biomass of the components of the model  
+                                                                                       !! tree within a circumference
+                                                                                       !! class @tex $(gC ind^{-1})$ @endtex  
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(inout)        :: circ_class_n       !! Number of individuals in each circ class
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nfm_types,ncut_times), &
+                                                  INTENT(inout)  :: circ_class_kill    !! Number of trees within a circ that needs
+                                                                                       !! to be killed @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                                  INTENT(inout)  :: bm_to_litter       !! Biomass transfer to litter 
+                                                                                       !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)               :: harvest_pool       !! The wood and biomass that have been
+                                                                                       !! havested by humans @tex $(gC)$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_type       !! Type of management that resulted
+                                                                                       !! in the harvest (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_cut        !! Type of cutting that was used for the harvest
+                                                                                       !! (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_area       !! Harvested area (m^{2})
+    INTEGER(i_std), DIMENSION(npts,nvm),INTENT(inout)            :: last_cut           !! Years since last thinning or clearcut (years)
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                               :: icir               !! Indices
+    REAL(r_std)                                                  :: total_bm
+    REAL(r_std)                                                  :: thinned_bm
+    REAL(r_std)                                                  :: dead_bm
+    REAL(r_std)                                                  :: bm_difference
+
+    !_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) &
+         'Entering thinning_harvest_aboveground_dead_roots sapiens_kill.f90'
+
+    IF( SUM(circ_class_kill(ipts,ivm,:,ifm,icut)) .GT. min_stomate ) THEN
+
+       CALL harvest_aboveground_dead_roots(npts, ipts, ivm, iele, &
+            ifm, icut, biomass, ind, bm_to_litter, &
+            circ_class_biomass, circ_class_kill, circ_class_n, harvest_pool, &
+            harvest_type, harvest_cut, harvest_area, &
+            harvest_pool_bound, resolution, veget_max, harvest_fraction)
+
+       ! thinning trees generally avoids natural mortality and self-thinning, so
+       ! let's remove all thinned trees from the pools.  This is tricky because
+       ! mortality depends on a fraction of the total biomass, which may be spread
+       ! out over different circ classes than what were killed by thinning.
+       thinned_bm = zero
+       dead_bm = zero
+       DO icir=1,ncirc
+          total_bm=SUM(circ_class_biomass(ipts,ivm,icir,:,iele))
+          thinned_bm=thinned_bm+circ_class_kill(ipts,ivm,icir,ifm,icut)*total_bm
+          dead_bm=dead_bm+circ_class_kill(ipts,ivm,icir,ifm_none,icut_thin)*total_bm
+       ENDDO
+       bm_difference = dead_bm - thinned_bm
+
+       ! if the thinned biomass is more than what would have died from natural causes,
+       ! we can just assume that thinning killed all these trees.
+       IF(bm_difference .LE. min_stomate)THEN
+
+          circ_class_kill(ipts,ivm,:,ifm_none,icut_thin)=zero
+
+       ELSE
+
+          ! if not, we have to reduce the amount of biomass that is killed naturally
+          ! by what was removed by thinning, redistributing the remainder properly
+          ! across all circ classes as we did in stomate_mark_kill.
+          circ_class_kill(ipts,ivm,:,ifm_none,icut_thin) = zero
+          CALL distribute_mortality_biomass( bm_difference, &
+               death_distribution_factor(ivm), &
+               circ_class_n(ipts,ivm,:), &
+               circ_class_biomass(ipts,ivm,:,:,icarbon), &
+               circ_class_kill(ipts,ivm,:,ifm_none,icut_thin) )
+       ENDIF ! bm_difference .LE. min_stomate
+
+
+       ! make sure nothing has gone negative
+       WHERE ( circ_class_kill(ipts,ivm,:,ifm_none,icut_thin) .LT. zero )
+          circ_class_kill(ipts,ivm,:,ifm_none,icut_thin)=zero
+       END WHERE
+
+       ! now zero out this circ_class_kill, since we should never try
+       ! to kill these same trees again.
+       circ_class_kill(ipts,ivm,:,ifm,icut)=zero
+
+       ! Reset the values for the time since the last operation
+       last_cut(ipts,ivm)=0
+       
+    ENDIF ! checking to see if we have biomass to thin
+
+
+    IF (bavard.GE.2) WRITE(numout,*) &
+         'Leaving thinning_harvest_aboveground_dead_roots sapiens_kill.f90'
+
+  END SUBROUTINE thinning_harvest_aboveground_dead_roots
+
+!! ================================================================================================================================
+!! SUBROUTINE   : harvest_aboveground_dead_roots
+!!
+!>\BRIEF        Transfer dead biomass to litter and wood to harvest pool.
+!!
+!! DESCRIPTION  : Moves dead biomass to the litter pool and the harvest pool
+!!                where appropriate.  
+!!
+!!                NOTE: If harvest_fraction is 1, all the aboveground biomass is
+!!                      harvested.  If it's 1-branch_ratio, only stems are 
+!!                      harvested.  Belowground wood, roots, fruits, and
+!!                      leaves all become litter.  A portion of aboveground
+!!                      wood is put in the harvest pool.  Reserves and labile
+!!                      carbon are assumed to be distributed evenly across
+!!                      all non-heartwood components.
+!!
+!! RECENT CHANGE(S): 
+!!
+!! MAIN OUTPUT VARIABLE(S): ::bm_to_litter, ::harvest_pool
+!!
+!! REFERENCE(S)   :
+!!
+!! FLOWCHART    : None
+!!\n
+!_ ================================================================================================================================
+ 
+  SUBROUTINE harvest_aboveground_dead_roots (npts, ipts, ivm, iele, &
+       ifm, icut, biomass, ind, bm_to_litter, &
+       circ_class_biomass, circ_class_kill, circ_class_n, harvest_pool, &
+       harvest_type, harvest_cut, harvest_area, &
+       harvest_pool_bound, resolution, veget_max, harvest_fraction)
+
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables 
+
+    INTEGER(i_std), INTENT(in)                                   :: npts               !! Domain size (-)
+    INTEGER(i_std), INTENT(in)                                   :: ipts               !! current grid square
+    INTEGER(i_std), INTENT(in)                                   :: ivm                !! current PFT
+    INTEGER(i_std), INTENT(in)                                   :: iele               !! current element type
+    INTEGER(i_std), INTENT(in)                                   :: ifm                !! current fm strategy
+    INTEGER(i_std), INTENT(in)                                   :: icut               !! current cut time
+    REAL(r_std), DIMENSION(0:ndia_harvest+1), INTENT(in)         :: harvest_pool_bound !! The boundaries of the diameter classes
+                                                                                       !! in the wood harvest pools
+                                                                                       !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,2), INTENT(in)                    :: resolution         !! The length of each grid-box in X and Y
+                                                                                       !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)                   :: veget_max          !! Maximum fraction of vegetation type 
+    REAL(r_std),INTENT(in)                                       :: harvest_fraction   !! The fraction of the aboveground
+                                                                                       !! biomass that is harvested.  This is
+                                                                                       !! generally 1-branch_ratio if you only
+                                                                                       !! want to harvest the stems, and 1 if
+                                                                                       !! you want to harvest everything.
+
+    !! 0.2 Output variables
+
+
+    !! 0.3 Modified variables   
+
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                             INTENT(inout)       :: biomass            !! Biomass @tex $(gC m^{-2}) $@endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)              :: ind                !! Stand level number of individuals 
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements), &                         
+                                              INTENT(inout)      :: circ_class_biomass !! Biomass of the components of the model  
+                                                                                       !! tree within a circumference
+                                                                                       !! class @tex $(gC ind^{-1})$ @endtex  
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(inout)        :: circ_class_n       !! Number of individuals in each circ class
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nfm_types,ncut_times), &
+                                                  INTENT(inout)  :: circ_class_kill    !! Number of trees within a circ that needs
+                                                                                       !! to be killed @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                                  INTENT(inout)  :: bm_to_litter       !! Biomass transfer to litter 
+                                                                                       !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)               :: harvest_pool       !! The wood and biomass that have been
+                                                                                       !! havested by humans @tex $(gC)$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_type       !! Type of management that resulted
+                                                                                       !! in the harvest (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_cut        !! Type of cutting that was used for the harvest
+                                                                                       !! (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_area       !! Harvested area (m^{2})
+
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                               :: idia, icir         !! Indices
+    REAL(r_std)                                                  :: total_nonheart_biomass_harvest
+    REAL(r_std)                                                  :: total_nonheart_biomass_kill
+    REAL(r_std)                                                  :: harvest_ratio
+    REAL(r_std), DIMENSION(ncirc)                                :: diameters_temp
+
+    !_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) &
+         'Entering harvest_aboveground_dead_roots sapiens_kill.f90'
+
+    ! we will need the trunk diameters for all the circ classes in order to figure
+    ! out which harvest pool to put them in.
+    diameters_temp(:)=wood_to_dia(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm) 
+
+    DO icir=1,ncirc
+
+       ! It's possible that we only kill individuals in certain circ classes.
+       ! In this case, we need to check for each circ class to make sure
+       ! we don't divide by zero.
+       IF(circ_class_kill(ipts,ivm,icir,ifm,icut) .LT. min_stomate) CYCLE
+
+       ! The decision of what to do with the carboyhydrate reserves and the
+       ! labile carbon pool are tricky.  In turnover, they are not touched
+       ! when leaves/roots/fruits die, which implies that they are stored
+       ! primarily in the above and belowground sapwood (heartwood is dead). 
+       ! However, here a tree does not know thinning is coming, so it cannot
+       ! move this carbon around.  We will therefore determine where is goes
+       ! based on the total amount of non-heartwood pools and where they go.
+       total_nonheart_biomass_kill=circ_class_kill(ipts,ivm,icir,ifm,icut)*&
+            (circ_class_biomass(ipts,ivm,icir,isapbelow,iele)+&
+            circ_class_biomass(ipts,ivm,icir,iroot,iele)+&
+            circ_class_biomass(ipts,ivm,icir,ileaf,iele)+&
+            circ_class_biomass(ipts,ivm,icir,ifruit,iele)+&
+            circ_class_biomass(ipts,ivm,icir,isapabove,iele))
+
+       total_nonheart_biomass_harvest=harvest_fraction*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)*&
+            circ_class_biomass(ipts,ivm,icir,isapabove,iele)
+
+       ! This is now the fraction of the nonheartwood biomass that will go
+       ! into the harvest pool.  We will use this to partition the carbohydrate
+       ! reserve and labile pools into litter and harvest.
+       harvest_ratio=total_nonheart_biomass_harvest/total_nonheart_biomass_kill
+
+       ! all of the following biomass becomes litter
+       bm_to_litter(ipts,ivm,isapbelow,iele) = &
+            bm_to_litter(ipts,ivm,isapbelow,iele) + &
+            circ_class_biomass(ipts,ivm,icir,isapbelow,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+       bm_to_litter(ipts,ivm,iheartbelow,iele) = &
+            bm_to_litter(ipts,ivm,iheartbelow,iele) + &
+            circ_class_biomass(ipts,ivm,icir,iheartbelow,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+       bm_to_litter(ipts,ivm,iroot,iele) = bm_to_litter(ipts,ivm,iroot,iele) + &
+            circ_class_biomass(ipts,ivm,icir,iroot,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+       bm_to_litter(ipts,ivm,ileaf,iele) = bm_to_litter(ipts,ivm,ileaf,iele) + &
+            circ_class_biomass(ipts,ivm,icir,ileaf,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+       bm_to_litter(ipts,ivm,ifruit,iele) = bm_to_litter(ipts,ivm,ifruit,iele) + &
+            circ_class_biomass(ipts,ivm,icir,ifruit,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+
+       ! Include the branches as litter, if necessary.
+       bm_to_litter(ipts,ivm,isapabove,iele) = &
+            bm_to_litter(ipts,ivm,isapabove,iele) + &
+            (un - harvest_fraction)*circ_class_biomass(ipts,ivm,icir,isapabove,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+       bm_to_litter(ipts,ivm,iheartabove,iele) = &
+            bm_to_litter(ipts,ivm,iheartabove,iele) + &
+            (un - harvest_fraction)*circ_class_biomass(ipts,ivm,icir,iheartabove,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+
+       ! Don't forget to include the proper proportion of the labile and
+       ! carbres pools.
+       bm_to_litter(ipts,ivm,icarbres,iele) = &
+            bm_to_litter(ipts,ivm,icarbres,iele) + &
+            (un - harvest_ratio )*circ_class_biomass(ipts,ivm,icir,icarbres,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+       bm_to_litter(ipts,ivm,ilabile,iele) = &
+            bm_to_litter(ipts,ivm,ilabile,iele) + &
+            (un - harvest_ratio )*circ_class_biomass(ipts,ivm,icir,ilabile,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+
+       ! now we have the stems.  These are what we want to save, and we are
+       ! going to classify them by PFT type, location, and diameter so that
+       ! we can compare to FAO statistics and do some more interesting
+       ! post-treatment.
+
+       ! UNITS: The units of the biomass pools are per meter squared.
+       ! It seems to make more sense to store the harvest pool in absolute
+       ! units, which means we have to multiple the result by the fraction of
+       ! this grid cell covered by this PFT (veget_max) and the size of the 
+       ! grid cell.  It seems that the fraction of nobio land does not need 
+       ! to be used here, since frac_nobio and veget_max are summed together 
+       ! in slowproc and they must equal one.  This gives
+       ! us the grams of carbon harvest, which is a big number but that's
+       ! why people invented scientific notation.
+
+       dia_loop:DO idia=1,ndia_harvest
+
+          IF(diameters_temp(icir) .LE. harvest_pool_bound(idia))THEN
+
+             ! this is the correct diameter class 
+             harvest_pool(ipts,ivm,idia,icarbon) = &
+                  harvest_pool(ipts,ivm,idia,icarbon) + &
+                  harvest_fraction*circ_class_kill(ipts,ivm,icir,ifm,icut)*&
+                  (circ_class_biomass(ipts,ivm,icir,isapabove,iele)+&
+                  circ_class_biomass(ipts,ivm,icir,iheartabove,iele)) * &
+                  veget_max(ipts,ivm) * &
+                  resolution(ipts,1) * resolution(ipts,2)
+
+             ! also add the proper fractions of the labile and carbres pools
+             harvest_pool(ipts,ivm,idia,icarbon) = &
+                  harvest_pool(ipts,ivm,idia,icarbon)+ &
+                  harvest_ratio * circ_class_kill(ipts,ivm,icir,ifm,icut)*&
+                  ( circ_class_biomass(ipts,ivm,icir,ilabile,iele) + &
+                  circ_class_biomass(ipts,ivm,icir,icarbres,iele) )* &
+                  veget_max(ipts,ivm) * &
+                  resolution(ipts,1) * resolution(ipts,2)
+             
+             ! Associated harvest variables
+             harvest_type(ipts,ivm) = ifm
+             harvest_cut(ipts,ivm) = icut
+             harvest_area(ipts,ivm) = veget_max(ipts,ivm) * &
+                  resolution(ipts,1) * resolution(ipts,2)
+                
+             EXIT dia_loop
+
+          ELSEIF ( (diameters_temp(icir) .GT. harvest_pool_bound(idia)) .AND. &
+               (diameters_temp(icir) .LT. harvest_pool_bound(idia+1)) .AND. &
+               (idia == ndia_harvest) ) THEN
+             
+             ! Store in largest diameter class 
+             harvest_pool(ipts,ivm,idia,icarbon) = &
+                  harvest_pool(ipts,ivm,idia,icarbon) + &
+                  harvest_fraction*circ_class_kill(ipts,ivm,icir,ifm,icut)*&
+                  (circ_class_biomass(ipts,ivm,icir,isapabove,iele)+&
+                  circ_class_biomass(ipts,ivm,icir,iheartabove,iele)) * &
+                  veget_max(ipts,ivm) * &
+                  resolution(ipts,1) * resolution(ipts,2)
+
+             ! also add the proper fractions of the labile and carbres pools
+             harvest_pool(ipts,ivm,idia,icarbon) = &
+                  harvest_pool(ipts,ivm,idia,icarbon)+ &
+                  harvest_ratio * circ_class_kill(ipts,ivm,icir,ifm,icut)*&
+                  ( circ_class_biomass(ipts,ivm,icir,ilabile,iele) + &
+                  circ_class_biomass(ipts,ivm,icir,icarbres,iele) )* &
+                  veget_max(ipts,ivm) * &
+                  resolution(ipts,1) * resolution(ipts,2)
+             
+             ! Associated harvest variables
+             harvest_type(ipts,ivm) = ifm
+             harvest_cut(ipts,ivm) = icut
+             harvest_area(ipts,ivm) = veget_max(ipts,ivm) * &
+                  resolution(ipts,1) * resolution(ipts,2)
+                
+             EXIT dia_loop
+
+          ENDIF ! diameters_temp(icir) .LE. harvest_pool_bound(idia)
+
+          ! If we are here, it means the diameter of this trunk is larger
+          ! than the upper boundary of our harvest bins.  Considering the
+          ! upper boundary is set to be 99999 meters in constants.f90,
+          ! something has gone wrong!
+          IF (diameters_temp(icir) .GT. harvest_pool_bound(ndia_harvest+1)) THEN
+
+             WRITE(numout,*) 'Our tree is too big to fit into the harvest pools.'
+             WRITE(numout,*) 'ipts, ivm, icir: ',ipts, ivm, icir
+             WRITE(numout,*) 'diameters_temp(icir), harvest_pool_bound(idia)',&
+                  diameters_temp(icir),harvest_pool_bound(idia)
+             STOP
+
+          ENDIF
+
+       ENDDO dia_loop
+
+
+       ! remove the number of individuals that died
+       circ_class_n(ipts,ivm,icir) = circ_class_n(ipts,ivm,icir) - &
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+
+       ! remove the dead biomass
+       biomass(ipts,ivm,:,iele) = biomass(ipts,ivm,:,iele) - &
+            circ_class_biomass(ipts,ivm,icir,:,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+
+       ! adjust the number of individuals
+       ind(ipts,ivm)=ind(ipts,ivm)-circ_class_kill(ipts,ivm,icir,ifm,icut)
+
+    ENDDO ! loop over circ classes
+
+    ! We should not have negative numbers.  I don't want to zero out all
+    ! of them, because it could be sign of a real problem, but if they
+    ! are a very small negative number it's just a numerical issue.
+    WHERE( ABS(biomass(ipts,ivm,:,iele)) .LE. min_stomate)
+       biomass(ipts,ivm,:,iele) = zero
+    END WHERE
+    WHERE( ABS(circ_class_biomass(ipts,ivm,:,:,iele)) .LE. min_stomate)
+      circ_class_biomass(ipts,ivm,:,:,iele) = zero
+    END WHERE
+    WHERE( ABS(circ_class_n(ipts,ivm,:)) .LE. min_stomate)
+       circ_class_n(ipts,ivm,:) = zero
+    END WHERE
+
+    IF (bavard.GE.2) WRITE(numout,*) &
+         'Leaving harvest_aboveground_dead_roots sapiens_kill.f90'
+
+  END SUBROUTINE harvest_aboveground_dead_roots
+
+!! ================================================================================================================================
+!! SUBROUTINE   : harvest_aboveground_wood_living_roots
+!!
+!>\BRIEF        Transfer dead biomass to litter and wood to harvest pool.
+!!
+!! DESCRIPTION  : Moves dead biomass to the litter pool and the harvest pool
+!!                where appropriate.  
+!!
+!!                NOTE: All branches and stems are harvested.  Basically, this means
+!!                      all aboveground woody biomass.  The fine roots
+!!                      are killed and left to litter.  The sapwood and heartwood
+!!                      belowground is left alive.  The leaves are killed, and the
+!!                      labile and carbres pools are left untouched in the living
+!!                      biomass.
+!!
+!! RECENT CHANGE(S): 
+!!
+!! MAIN OUTPUT VARIABLE(S): ::bm_to_litter, ::harvest_pool
+!!
+!! REFERENCE(S)   :
+!! - Bellassen, V., Le Maire, G., Dhote, J.F., Viovy, N., Ciais, P., 2010. 
+!! Modeling forest management within a global vegetation model â Part 1: 
+!! model structure and general behaviour. Ecological Modelling 221, 2458â2474.
+!!
+!! FLOWCHART    : None
+!!\n
+!_ ================================================================================================================================
+ 
+  SUBROUTINE harvest_aboveground_wood_living_roots (npts, ipts, ivm, iele, &
+       ifm, icut, biomass, bm_to_litter, &
+       circ_class_biomass, circ_class_kill, harvest_pool, &
+       harvest_type, harvest_cut, harvest_area, &
+       harvest_pool_bound, resolution, veget_max)
+
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables 
+    INTEGER(i_std), INTENT(in)                                   :: npts               !! Domain size (-)
+    INTEGER(i_std), INTENT(in)                                   :: ipts               !! current grid square
+    INTEGER(i_std), INTENT(in)                                   :: ivm                !! current PFT
+    INTEGER(i_std), INTENT(in)                                   :: iele               !! current element type
+    INTEGER(i_std), INTENT(in)                                   :: ifm                !! current fm strategy
+    INTEGER(i_std), INTENT(in)                                   :: icut               !! current cut time
+    REAL(r_std), DIMENSION(0:ndia_harvest+1), INTENT(in)         :: harvest_pool_bound !! The boundaries of the diameter classes
+                                                                                       !! in the wood harvest pools
+                                                                                       !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,2), INTENT(in)                    :: resolution         !! The length of each grid-box in X and Y
+                                                                                       !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)                   :: veget_max          !! Maximum fraction of vegetation type 
+
+
+    !! 0.2 Output variables
+
+
+    !! 0.3 Modified variables   
+
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                             INTENT(inout)       :: biomass            !! Biomass @tex $(gC m^{-2}) $@endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements), &                         
+                                              INTENT(inout)      :: circ_class_biomass !! Biomass of the components of the model  
+                                                                                       !! tree within a circumference
+                                                                                       !! class @tex $(gC ind^{-1})$ @endtex  
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nfm_types,ncut_times), &
+                                                  INTENT(inout)  :: circ_class_kill    !! Number of trees within a circ that needs
+                                                                                       !! to be killed @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                                  INTENT(inout)  :: bm_to_litter       !! Biomass transfer to litter 
+                                                                                       !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)               :: harvest_pool       !! The wood and biomass that have been
+                                                                                       !! havested by humans @tex $(gC)$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_type       !! Type of management that resulted
+                                                                                       !! in the harvest (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_cut        !! Type of cutting that was used for the harvest
+                                                                                       !! (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_area       !! Harvested area (m^{2})
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                               :: idia, icir         !! Indices
+    REAL(r_std)                                                  :: total_nonheart_biomass_harvest
+    REAL(r_std)                                                  :: total_nonheart_biomass_living
+    REAL(r_std)                                                  :: total_nonheart_biomass_kill
+    REAL(r_std)                                                  :: harvest_ratio
+    REAL(r_std)                                                  :: living_ratio
+    REAL(r_std)                                                  :: litter_ratio
+    REAL(r_std), DIMENSION(ncirc)                                :: diameters_temp
+
+    !_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) &
+         'Entering harvest_aboveground_wood_living_roots sapiens_kill.f90'
+
+    ! we will need the trunk diameters for all the circ classes in order to figure
+    ! out which harvest pool to put them in.
+    diameters_temp(:)=wood_to_dia(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm) 
+
+    DO icir=1,ncirc
+
+       ! It's possible that we only kill individuals in certain circ classes.
+       ! In this case, we need to check for each circ class to make sure
+       ! we don't divide by zero.
+       IF(circ_class_kill(ipts,ivm,icir,ifm,icut) .LT. min_stomate) CYCLE
+
+       ! The decision of what to do with the carboyhydrate reserves and the
+       ! labile carbon pool are tricky.  In turnover, they are not touched
+       ! when leaves/roots/fruits die, which implies that they are stored
+       ! primarily in the above and belowground sapwood (heartwood is dead). 
+       ! However, here a tree does not know thinning is coming, so it cannot
+       ! move this carbon around.  In theory, we should remove part of the
+       ! labile and reserve pools to the different product pools, but
+       ! these pools are very sensitive for the allocation.  Therefore
+       ! we don't touch them, which is equivalent to saying the reserve
+       ! and labile carbon are all found in the roots.
+
+       total_nonheart_biomass_kill=circ_class_kill(ipts,ivm,icir,ifm,icut)*&
+            (circ_class_biomass(ipts,ivm,icir,isapbelow,iele)+&
+            circ_class_biomass(ipts,ivm,icir,iroot,iele)+&
+            circ_class_biomass(ipts,ivm,icir,ileaf,iele)+&
+            circ_class_biomass(ipts,ivm,icir,ifruit,iele)+&
+            circ_class_biomass(ipts,ivm,icir,isapabove,iele))
+
+       total_nonheart_biomass_harvest=&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)*&
+            (circ_class_biomass(ipts,ivm,icir,isapabove,iele))
+
+       total_nonheart_biomass_living=&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)*&
+            (circ_class_biomass(ipts,ivm,icir,isapbelow,iele))
+
+       ! This is now the fraction of the nonheartwood biomass that will go
+       ! into the harvest pool.  We will use this to partition the carbohydrate
+       ! reserve and labile pools into litter and harvest.
+       harvest_ratio=total_nonheart_biomass_harvest/total_nonheart_biomass_kill
+       living_ratio=total_nonheart_biomass_living/total_nonheart_biomass_kill
+       litter_ratio=un-harvest_ratio-living_ratio
+       IF(litter_ratio .LT. -min_stomate)THEN
+          WRITE(numout,*) 'We have a problem with coppicing!'
+          WRITE(numout,*) 'ipts,ivm,icir,ifm,icut ',ipts,ivm,icir,ifm,icut
+          WRITE(numout,*) 'harvest_ratio, living_ratio, litter_ratio ',&
+               harvest_ratio, living_ratio, litter_ratio
+          STOP
+       ELSEIF(litter_ratio .LT. -min_stomate)THEN
+          litter_ratio=zero
+       ENDIF
+
+       ! all of the following biomass becomes litter
+       bm_to_litter(ipts,ivm,iroot,iele) = bm_to_litter(ipts,ivm,iroot,iele) + &
+            circ_class_biomass(ipts,ivm,icir,iroot,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+       bm_to_litter(ipts,ivm,ileaf,iele) = bm_to_litter(ipts,ivm,ileaf,iele) + &
+            circ_class_biomass(ipts,ivm,icir,ileaf,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+       bm_to_litter(ipts,ivm,ifruit,iele) = bm_to_litter(ipts,ivm,ifruit,iele) + &
+            circ_class_biomass(ipts,ivm,icir,ifruit,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+
+       ! now we have the stems.  These are what we want to save, and we are
+       ! going to classify them by PFT type, location, and diameter so that
+       ! we can compare to FAO statistics and do some more interesting
+       ! post-treatment.
+
+       ! UNITS: The units of the biomass pools are per meter squared.
+       ! It seems to make more sense to store the harvest pool in absolute
+       ! units, which means we have to multiple the result by the fraction of
+       ! this grid cell covered by this PFT (veget_max) and the size of the 
+       ! grid cell.  It seems that the fraction of nobio land does not need 
+       ! to be used here, since frac_nobio and veget_max are summed together 
+       ! in slowproc and they must equal one.  This gives
+       ! us the grams of carbon harvest, which is a big number but that's
+       ! why people invented scientific notation.
+
+       dia_loop:DO idia=1,ndia_harvest
+
+          IF(diameters_temp(icir) .LE. harvest_pool_bound(idia))THEN
+
+             ! this is the correct diameter class 
+             harvest_pool(ipts,ivm,idia,icarbon)=&
+                  harvest_pool(ipts,ivm,idia,icarbon)+ &
+                  circ_class_kill(ipts,ivm,icir,ifm,icut)*&
+                  (circ_class_biomass(ipts,ivm,icir,isapabove,iele)+&
+                  circ_class_biomass(ipts,ivm,icir,iheartabove,iele)) * &
+                  veget_max(ipts,ivm) * &
+                  resolution(ipts,1) * resolution(ipts,2)
+             
+             ! Associated harvest variables
+             harvest_type(ipts,ivm) = ifm
+             harvest_cut(ipts,ivm) = icut
+             harvest_area(ipts,ivm) = veget_max(ipts,ivm) * &
+                  resolution(ipts,1) * resolution(ipts,2)
+
+             EXIT dia_loop
+
+          ENDIF ! diameters_temp(icir) .LE. harvest_pool_bound(idia)
+
+          ! If we are here, it means the diameter of this trunk is larger
+          ! than the upper boundary of our harvest bins.  Considering the
+          ! upper boundary is set to be 99999 meters in constants.f90,
+          ! something has gone wrong!
+          IF(idia == ndia_harvest)THEN
+
+             WRITE(numout,*) 'Our tree is too big to fit into the harvest pools.'
+             WRITE(numout,*) 'ipts, ivm, icir: ',ipts, ivm, icir
+             WRITE(numout,*) 'diameters_temp(icir), harvest_pool_bound(idia)',&
+                  diameters_temp(icir),harvest_pool_bound(idia)
+             STOP
+
+          ENDIF
+
+       ENDDO dia_loop
+
+
+       ! No individuals die here since the roots are still alive.
+
+       ! Remove the dead biomass.  This includes everything except
+       ! the belowground biomass.  
+       biomass(ipts,ivm,ileaf,iele) = biomass(ipts,ivm,ileaf,iele) - &
+            circ_class_biomass(ipts,ivm,icir,ileaf,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+       biomass(ipts,ivm,isapabove,iele) = biomass(ipts,ivm,isapabove,iele) - &
+            circ_class_biomass(ipts,ivm,icir,isapabove,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+       biomass(ipts,ivm,iheartabove,iele) = biomass(ipts,ivm,iheartabove,iele) - &
+            circ_class_biomass(ipts,ivm,icir,iheartabove,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+       biomass(ipts,ivm,iroot,iele) = biomass(ipts,ivm,iroot,iele) - &
+            circ_class_biomass(ipts,ivm,icir,iroot,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+       biomass(ipts,ivm,ifruit,iele) = biomass(ipts,ivm,ifruit,iele) - &
+            circ_class_biomass(ipts,ivm,icir,ifruit,iele)*&
+            circ_class_kill(ipts,ivm,icir,ifm,icut)
+
+       ! Remove the dead biomass.  This includes everything except
+       ! the belowground biomass.  
+       circ_class_biomass(ipts,ivm,icir,ileaf,iele)=zero
+       circ_class_biomass(ipts,ivm,icir,isapabove,iele)=zero
+       circ_class_biomass(ipts,ivm,icir,iheartabove,iele)=zero
+       circ_class_biomass(ipts,ivm,icir,iroot,iele)=zero
+       circ_class_biomass(ipts,ivm,icir,ifruit,iele)=zero
+
+    ENDDO ! loop over circ classes
+
+
+    IF (bavard.GE.2) WRITE(numout,*) &
+         'Leaving harvest_aboveground_wood_living_roots sapiens_kill.f90'
+
+  END SUBROUTINE harvest_aboveground_wood_living_roots
+
+!! ================================================================================================================================
+!! SUBROUTINE   : second_coppice_cut
+!!
+!>\BRIEF        Simulates cutting a coppice between the first cut and the
+!!              final cut.
+!!
+!! DESCRIPTION  : Moves dead biomass to the litter pool and the harvest pool
+!!                where appropriate.  A few counters are reset.  The leftover
+!!                biomass (the woody root system) is patitioned among enough
+!!                individuals to give the same density as is found in coppice_dens,
+!!                which is the density of stumps left after the first cut.
+!!
+!!                NOTE: All branches and stems are harvested.  Basically, this means
+!!                      all aboveground woody biomass.  The fine roots
+!!                      are killed and left to litter.  The sapwood and heartwood
+!!                      belowground is left alive.  The leaves are killed, and the
+!!                      labile and carbres pools are left untouched in the living
+!!                      biomass.
+!!
+!! RECENT CHANGE(S): 
+!!
+!! MAIN OUTPUT VARIABLE(S): ::bm_to_litter, ::harvest_pool
+!!
+!! REFERENCE(S)   :
+!! - Bellassen, V., Le Maire, G., Dhote, J.F., Viovy, N., Ciais, P., 2010. 
+!! Modeling forest management within a global vegetation model â Part 1: 
+!! model structure and general behaviour. Ecological Modelling 221, 2458â2474.
+!!
+!! FLOWCHART    : None
+!!\n
+!_ ================================================================================================================================
+ 
+  SUBROUTINE second_coppice_cut (npts, ipts, ivm, iele, ifm, &
+       icut, harvest_pool_bound, resolution, veget_max, biomass, &
+       ind, circ_class_biomass, circ_class_n, circ_class_kill, &
+       bm_to_litter, harvest_pool, harvest_type, harvest_cut, &
+       harvest_area, circ_class_dist, last_cut, coppice_dens)
+
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables 
+    INTEGER(i_std), INTENT(in)                                   :: npts               !! Domain size (-)
+    INTEGER(i_std), INTENT(in)                                   :: ipts               !! current grid square
+    INTEGER(i_std), INTENT(in)                                   :: ivm                !! current PFT
+    INTEGER(i_std), INTENT(in)                                   :: iele               !! current element type
+    INTEGER(i_std), INTENT(in)                                   :: ifm                !! current fm strategy
+    INTEGER(i_std), INTENT(in)                                   :: icut               !! current cut time
+    REAL(r_std), DIMENSION(0:ndia_harvest+1), INTENT(in)         :: harvest_pool_bound !! The boundaries of the diameter classes
+                                                                                       !! in the wood harvest pools
+                                                                                       !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,2), INTENT(in)                    :: resolution         !! The length of each grid-box in X and Y
+                                                                                       !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)                   :: veget_max          !! Maximum fraction of vegetation type 
+    REAL(r_std), DIMENSION(ncirc), INTENT(in)                    :: circ_class_dist    !! The probability distribution of trees 
+                                                                                       !! in a circ class in case of a 
+                                                                                       !! redistribution (unitless).
+    REAL(r_std), DIMENSION(npts,nvm),INTENT(in)                  :: coppice_dens       !! The density of a coppice at the first
+                                                                                       !! cutting.
+                                                                                       !! @tex $( 1 / m**2 )$ @endtex 
+
+    !! 0.2 Output variables
+
+
+    !! 0.3 Modified variables   
+    
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                             INTENT(inout)       :: biomass            !! Biomass @tex $(gC m^{-2}) $@endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)              :: ind                !! Stand level number of individuals 
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements), &                         
+                                              INTENT(inout)      :: circ_class_biomass !! Biomass of the components of the model  
+                                                                                       !! tree within a circumference
+                                                                                       !! class @tex $(gC ind^{-1})$ @endtex  
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(inout)        :: circ_class_n       !! Number of individuals in each circ class
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nfm_types,ncut_times), &
+                                                  INTENT(inout)  :: circ_class_kill    !! Number of trees within a circ that needs
+                                                                                       !! to be killed @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                                  INTENT(inout)  :: bm_to_litter       !! Biomass transfer to litter 
+                                                                                       !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)               :: harvest_pool       !! The wood and biomass that have been
+                                                                                       !! havested by humans @tex $(gC)$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_type       !! Type of management that resulted
+                                                                                       !! in the harvest (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_cut        !! Type of cutting that was used for the harvest
+                                                                                       !! (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_area       !! Harvested area (m^{2})
+    INTEGER(i_std), DIMENSION(npts,nvm),INTENT(inout)            :: last_cut           !! Years since last thinning or clearcut (years)
+
+
+    !! 0.4 Local variables
+
+    REAL(r_std), DIMENSION(ncirc,nparts)                         :: circ_class_biomass_new !! Biomass of the components of the model  
+                                                                                       !! tree within a circumference
+                                                                                       !! class @tex $(gC ind^{-1})$ @endtex  
+    REAL(r_std), DIMENSION(ncirc)                                :: circ_class_n_new   !! Number of individuals in each circ class
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                                :: old_trees_left
+    REAL(r_std)                                                  :: trees_needed
+    REAL(r_std)                                                  :: scale_factor
+    INTEGER                                                      :: icir, jcir
+    !_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) &
+         'Entering second_coppice_cut sapiens_kill.f90'
+
+    IF( SUM(circ_class_kill(ipts,ivm,:,ifm, icut))&
+         .GT. min_stomate ) THEN
+
+       IF(ld_forestry)THEN
+          WRITE(numout,*) 'Doing a second coppice cut'
+          WRITE(numout,*) 'ipts,ivm,ifm,icut ',ipts,ivm,ifm,icut
+       ENDIF
+
+       ! Again, we harvest all aboveground biomass and leave the roots
+       CALL harvest_aboveground_wood_living_roots(npts, ipts, ivm, iele, &
+            ifm, icut, biomass, bm_to_litter, &
+            circ_class_biomass, circ_class_kill, harvest_pool, &
+            harvest_type, harvest_cut, harvest_area, &
+            harvest_pool_bound, resolution, veget_max)
+
+       ! reset the time since the last cut
+       last_cut(ipts,ivm)=0
+
+       ! We also reset circ_class_kill for this grid square, since
+       ! we clearly don't need to do mortality if we have no more
+       ! aboveground biomass left.
+       circ_class_kill(ipts,ivm,:,:,:)=zero
+
+       ! Now we have a certain number density and a certain amount of
+       ! biomass.  We want to have the same number of trees that we had
+       ! during the first cut, since the stumps from the first part aren't
+       ! going to change (maybe a couple will die, but not a large difference).
+
+       ! This code is copied from lpj_gap.f90.
+       circ_class_n_new(:)=circ_class_dist(:)*ind(ipts,ivm)
+       circ_class_biomass_new(:,:)=zero
+
+       ! now we populate the new classes
+       old_trees_left(:)=circ_class_n(ipts,ivm,:)
+       DO icir=1,ncirc
+
+          trees_needed=circ_class_n_new(icir)
+          DO jcir=1,ncirc
+
+             IF(trees_needed .LE. zero)EXIT
+
+             IF(old_trees_left(jcir) .GE. trees_needed )THEN
+                ! we can get all the trees we need from this class
+                ! and don't have to continue searching
+                circ_class_biomass_new(icir,:)=circ_class_biomass_new(icir,:)+&
+                     circ_class_biomass(ipts,ivm,jcir,:,icarbon)*trees_needed
+                old_trees_left(jcir)=old_trees_left(jcir)-trees_needed
+                trees_needed = zero
+                EXIT
+             ELSE
+
+                ! the trees in this class are not sufficient, so we
+                ! need to move all of them to the new class.
+                circ_class_biomass_new(icir,:)=circ_class_biomass_new(icir,:)+&
+                     circ_class_biomass(ipts,ivm,jcir,:,icarbon)*&
+                     old_trees_left(jcir)
+                trees_needed = trees_needed -old_trees_left(jcir)
+                old_trees_left(jcir)=zero
+
+             ENDIF ! checking if we have enough trees
+
+          ENDDO ! jcir=1,ncirc
+
+       ENDDO ! icir=1,ncirc
+
+       ! right now, circ_class_biomass_new gives the total biomass
+       ! in each class, but it should only be for a model tree. 
+       ! So let's normalize it.
+       DO icir=1,ncirc
+          circ_class_biomass_new(icir,:)=circ_class_biomass_new(icir,:)&
+               /circ_class_n_new(icir)
+       ENDDO
+
+       ! now update the variables that pass this information around
+       DO icir=1,ncirc
+          circ_class_biomass(ipts,ivm,icir,:,icarbon)=circ_class_biomass_new(icir,:)
+          circ_class_n(ipts,ivm,icir)=circ_class_n_new(icir)
+       ENDDO
+
+       !----- end of copied code..make a subroutine?
+
+
+       ! reset the time since the last cut
+       last_cut(ipts,ivm)=0
+
+       ! We also reset circ_class_kill for this grid square, since
+       ! we clearly don't need to do mortality if we have no more
+       ! aboveground biomass left.
+       circ_class_kill(ipts,ivm,:,:,:)=zero
+
+       ! After a first coppicing, we will regrow a certain number
+       ! of shoots per stool.  For a second coppice cut, our starting
+       ! density is exactly the same as the first cut.
+       
+       scale_factor=coppice_dens(ipts,ivm)/SUM(circ_class_n(ipts,ivm,:))*&
+            REAL(shoots_per_stool(ivm),r_std)
+
+       circ_class_n(ipts,ivm,:)=circ_class_n(ipts,ivm,:)*&
+            scale_factor
+       ind(ipts,ivm)=ind(ipts,ivm)*&
+            scale_factor
+
+       ! in order not to change the total biomass, we need to
+       ! make all our model trees smaller.
+       circ_class_biomass(ipts,ivm,:,:,:)=circ_class_biomass(ipts,ivm,:,:,:)/&
+            scale_factor
+
+    ENDIF ! any individuals to second cut coppice?
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving second_coppice_cut sapiens_kill.f90'
+
+  END SUBROUTINE second_coppice_cut
+
+!! ================================================================================================================================
+!! SUBROUTINE   : first_coppice_cut
+!!
+!>\BRIEF        Transfer dead biomass to litter and wood to harvest pool.
+!!
+!! DESCRIPTION  : This is a total harvest of the aboveground biomass of a
+!!                stand in such a way that the belowground wood continues to
+!!                live.  This results in a sprouting in the following year of
+!!                several shoots per stump.  Biomass is turned to litter, harvested,
+!!                and left alive, depending on the pool.  The number of individuals
+!!                goes up and the size of the model tree goes down.
+!!
+!!                NOTE: All branches and stems are harvested.  Basically, 
+!!                      this means all aboveground woody biomass.  The fine roots
+!!                      are killed and left to litter.  The sapwood and heartwood
+!!                      belowground is left alive.  The leaves are killed, and the
+!!                      labile and carbres pools are left untouched in the living
+!!                      biomass.
+!!
+!! RECENT CHANGE(S): 
+!!
+!! MAIN OUTPUT VARIABLE(S): ::bm_to_litter, ::harvest_pool
+!!
+!! REFERENCE(S)   :
+!!
+!! FLOWCHART    : None
+!!\n
+!_ ================================================================================================================================
+ 
+  SUBROUTINE first_coppice_cut (npts, ipts, ivm, iele, ifm, &
+       icut, harvest_pool_bound, resolution, veget_max, biomass, &
+       ind, circ_class_biomass, circ_class_n, circ_class_kill, &
+       bm_to_litter, harvest_pool, harvest_type, harvest_cut, &
+       harvest_area, last_cut)
+
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables 
+
+    INTEGER(i_std), INTENT(in)                                   :: npts               !! Domain size (-)
+    INTEGER(i_std), INTENT(in)                                   :: ipts               !! current grid square
+    INTEGER(i_std), INTENT(in)                                   :: ivm                !! current PFT
+    INTEGER(i_std), INTENT(in)                                   :: iele               !! current element type
+    INTEGER(i_std), INTENT(in)                                   :: ifm                !! current fm strategy
+    INTEGER(i_std), INTENT(in)                                   :: icut               !! current cut time
+    REAL(r_std), DIMENSION(0:ndia_harvest+1), INTENT(in)         :: harvest_pool_bound !! The boundaries of the diameter classes
+                                                                                       !! in the wood harvest pools
+                                                                                       !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,2), INTENT(in)                    :: resolution         !! The length of each grid-box in X and Y
+                                                                                       !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)                   :: veget_max          !! Maximum fraction of vegetation type 
+
+
+    !! 0.2 Output variables
+
+
+    !! 0.3 Modified variables   
+
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                             INTENT(inout)       :: biomass            !! Biomass @tex $(gC m^{-2}) $@endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)              :: ind                !! Stand level number of individuals 
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements), &                         
+                                              INTENT(inout)      :: circ_class_biomass !! Biomass of the components of the model  
+                                                                                       !! tree within a circumference
+                                                                                       !! class @tex $(gC ind^{-1})$ @endtex  
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(inout)        :: circ_class_n       !! Number of individuals in each circ class
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nfm_types,ncut_times), &
+                                                  INTENT(inout)  :: circ_class_kill    !! Number of trees within a circ that needs
+                                                                                       !! to be killed @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                                  INTENT(inout)  :: bm_to_litter       !! Biomass transfer to litter 
+                                                                                       !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)               :: harvest_pool       !! The wood and biomass that have been
+                                                                                       !! havested by humans @tex $(gC)$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_type       !! Type of management that resulted
+                                                                                       !! in the harvest (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_cut        !! Type of cutting that was used for the harvest
+                                                                                       !! (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_area       !! Harvested area (m^{2})
+    INTEGER(i_std), DIMENSION(npts,nvm),INTENT(inout)            :: last_cut           !! Years since last thinning or clearcut (years)
+
+    !! 0.4 Local variables
+
+    !_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering first_coppice_cut sapiens_kill.f90'
+
+    ! What if we coppice for the first cut?
+    IF( SUM(circ_class_kill(ipts,ivm,:,ifm, icut))&
+         .GT. min_stomate ) THEN
+
+       IF(ld_forestry)THEN
+          WRITE(numout,*) 'Doing a first coppice cut'
+          WRITE(numout,*) 'ipts,ivm,ifm,icut ',ipts,ivm,ifm,icut
+       ENDIF
+
+       CALL harvest_aboveground_wood_living_roots(npts, ipts, ivm, iele, &
+            ifm, icut, biomass, bm_to_litter, &
+            circ_class_biomass, circ_class_kill, harvest_pool, &
+            harvest_type, harvest_cut, harvest_area, &
+            harvest_pool_bound, resolution, veget_max)
+
+       ! reset the time since the last cut
+       last_cut(ipts,ivm)=0
+
+       ! We also reset circ_class_kill for this grid square, since
+       ! we clearly don't need to do mortality if we have no more
+       ! aboveground biomass left.
+       circ_class_kill(ipts,ivm,:,:,:)=zero
+
+       ! After a first coppicing, we will regrow a certain number
+       ! of shoots per stool.  Therefore, our density starting
+       ! next year will be much higher.
+       circ_class_n(ipts,ivm,:)=circ_class_n(ipts,ivm,:)*&
+            REAL(shoots_per_stool(ivm),r_std)
+       ind(ipts,ivm)=ind(ipts,ivm)*&
+            REAL(shoots_per_stool(ivm),r_std)
+
+       ! in order not to change the total biomass, we need to
+       ! make all our model trees smaller.
+       circ_class_biomass(ipts,ivm,:,:,:)=circ_class_biomass(ipts,ivm,:,:,:)/&
+            REAL(shoots_per_stool(ivm),r_std)
+
+    ENDIF ! any trees to first cut coppice?
+
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving first_coppice_cut sapiens_kill.f90'
+
+  END SUBROUTINE first_coppice_cut
+
+!! ================================================================================================================================
+!! SUBROUTINE   : clearcut_harvest_aboveground_dead_roots
+!!
+!>\BRIEF        Transfer dead biomass to litter and wood to harvest pool 
+!!              for a whole stand.
+!!
+!! DESCRIPTION  : Moves dead biomass to the litter pool and the harvest pool
+!!                where appropriate, assuming the whole stand is harvested.  Various
+!!                counters are reset.
+!!
+!!                NOTE: If harvest_fraction is 1, all the aboveground biomass is
+!!                      harvested.  If it's 1-branch_ratio, only stems are 
+!!                      harvested.  Belowground wood, roots, fruits, and
+!!                      leaves all become litter.  A portion of aboveground
+!!                      wood is put in the harvest pool.  Reserves and labile
+!!                      carbon are assumed to be distributed evenly across
+!!                      all non-heartwood components.
+!!
+!! RECENT CHANGE(S): 
+!!
+!! MAIN OUTPUT VARIABLE(S): ::bm_to_litter, ::harvest_pool
+!!
+!! REFERENCE(S)   :
+!!
+!! FLOWCHART    : None
+!!\n
+!_ ================================================================================================================================
+ 
+  SUBROUTINE clearcut_harvest_aboveground_dead_roots (npts, ipts, ivm, iele, &
+       ifm, icut, biomass, ind, bm_to_litter, &
+       circ_class_biomass, circ_class_kill, circ_class_n, harvest_pool, &
+       harvest_type, harvest_cut, harvest_area, &
+       harvest_pool_bound, resolution, veget_max, last_cut, age_stand, &
+       mai_count, harvest_fraction)
+
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables 
+    INTEGER(i_std), INTENT(in)                                   :: npts               !! Domain size (-)
+    INTEGER(i_std), INTENT(in)                                   :: ipts               !! current grid square
+    INTEGER(i_std), INTENT(in)                                   :: ivm                !! current PFT
+    INTEGER(i_std), INTENT(in)                                   :: iele               !! current element type
+    INTEGER(i_std), INTENT(in)                                   :: ifm                !! current fm strategy
+    INTEGER(i_std), INTENT(in)                                   :: icut               !! current cut time
+    REAL(r_std), DIMENSION(0:ndia_harvest+1), INTENT(in)         :: harvest_pool_bound !! The boundaries of the diameter classes
+                                                                                       !! in the wood harvest pools
+                                                                                       !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,2), INTENT(in)                    :: resolution         !! The length of each grid-box in X and Y
+                                                                                       !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)                   :: veget_max          !! Maximum fraction of vegetation type 
+    REAL(r_std),INTENT(in)                                       :: harvest_fraction   !! The fraction of the aboveground
+                                                                                       !! biomass that is harvested.  This is
+                                                                                       !! generally 1-branch_ratio if you only
+                                                                                       !! want to harvest the stems, and 1 if
+                                                                                       !! you want to harvest everything.
+
+
+    !! 0.2 Output variables
+
+
+    !! 0.3 Modified variables   
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                             INTENT(inout)       :: biomass            !! Biomass @tex $(gC m^{-2}) $@endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)              :: ind                !! Stand level number of individuals 
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements), &                         
+                                              INTENT(inout)      :: circ_class_biomass !! Biomass of the components of the model  
+                                                                                       !! tree within a circumference
+                                                                                       !! class @tex $(gC ind^{-1})$ @endtex  
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(inout)        :: circ_class_n       !! Number of individuals in each circ class
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nfm_types,ncut_times), &
+                                                  INTENT(inout)  :: circ_class_kill    !! Number of trees within a circ that needs
+                                                                                       !! to be killed @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                                  INTENT(inout)  :: bm_to_litter       !! Biomass transfer to litter 
+                                                                                       !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)               :: harvest_pool       !! The wood and biomass that have been
+                                                                                       !! havested by humans @tex $(gC)$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_type       !! Type of management that reulted
+                                                                                       !! in the harvest (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_cut        !! Type of cutting that was used for the harvest
+                                                                                       !! (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)                   :: harvest_area       !! Harvested area (m^{2})
+    INTEGER(i_std), DIMENSION(npts,nvm),INTENT(inout)            :: last_cut           !! Years since last thinning or clearcut (years)
+    INTEGER(i_std), DIMENSION(npts,nvm),INTENT(inout)            :: age_stand          !! Age of stand (years)
+    INTEGER(i_std), DIMENSION(npts,nvm),INTENT(inout)            :: mai_count          !! The number of times we've
+                                                                                       !! calculated the volume increment
+                                                                                       !! for a stand
+    !! 0.4 Local variables
+
+    !_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) &
+         'Entering clearcut_harvest_aboveground_dead_roots sapiens_kill.f90'
+
+    IF( SUM(circ_class_kill(ipts,ivm,:,ifm, icut))&
+         .GT. min_stomate ) THEN
+
+       CALL harvest_aboveground_dead_roots(npts, ipts, ivm, iele, &
+            ifm, icut, biomass, ind, bm_to_litter, &
+            circ_class_biomass, circ_class_kill, circ_class_n, harvest_pool, &
+            harvest_type, harvest_cut, harvest_area, &
+            harvest_pool_bound, resolution, veget_max, &
+            harvest_fraction)
+
+       ! We have to reset the age of the stand and the time since the
+       ! last human intervention.
+       age_stand(ipts,ivm)=0
+       last_cut(ipts,ivm)=0
+       mai_count(ipts,ivm)=0
+
+       ! We also reset circ_class_kill for this grid square, since
+       ! we clearly don't need to do mortality if we have no more
+       ! trees left.
+       circ_class_kill(ipts,ivm,:,:,:)=zero
+
+    ENDIF
+
+    IF (bavard.GE.2) WRITE(numout,*) &
+         'Leaving clearcut_harvest_aboveground_dead_roots sapiens_kill.f90'
+
+  END SUBROUTINE clearcut_harvest_aboveground_dead_roots
+
+END MODULE sapiens_kill
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/sapiens_lcchange.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/sapiens_lcchange.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/sapiens_lcchange.f90	(revision 7236)
@@ -0,0 +1,3571 @@
+! =================================================================================================================================
+! MODULE       : sapiens_lcchange
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Impact of land cover change on carbon stocks
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	: None
+!!
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_stomate/stomate_lcchange.f90 $
+!! $Date: 2013-07-03 10:16:15 +0200 (Wed, 03 Jul 2013) $
+!! $Revision: 1356 $
+!! \n
+!_ ================================================================================================================================
+
+
+MODULE sapiens_lcchange
+
+  ! modules used:
+  
+  USE ioipsl_para
+  USE stomate_data
+  USE pft_parameters
+  USE constantes
+  USE stomate_prescribe
+  USE function_library, only: wood_to_dia, wood_to_ba, check_biomass_sync 
+  
+  IMPLICIT NONE
+  
+  PRIVATE
+  PUBLIC lcchange_main, land_cover_change_main, age_class_distr, merge_biomass_pfts
+  
+CONTAINS
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : lcchange_main
+!!
+!>\BRIEF        Impact of land cover change on carbon stocks
+!!
+!! DESCRIPTION  : This subroutine is activated by 'LAND_COVER_CHANGE = y' in configuration file.
+!! In the case of 'LAND_COVER_CHANGE = y', the impact of land cover change on 
+!! carbon stocks is computed in this subroutine. The land cover change is written
+!! by the difference of new and previous "maximal" coverage fraction of a PFT. 
+!! On the basis of this difference, the amount of 'new establishment'/'biomass export',
+!! and increase/decrease of each component, are estimated.\n
+!!
+!! Main structure of stomate_lcchange.f90 is:
+!! 1. Initialization
+!! 2. Calculation of changes in carbon stocks and biomass by land cover change
+!! 3. Update 10 year- and 100 year-turnover pool contents
+!! 4. History
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : ::prod10, ::prod100, ::flux10, ::flux100,
+!!   :: cflux_prod10 and :: cflux_prod100 
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : 
+!! \latexonly 
+!!     \includegraphics[scale=0.5]{lcchange.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  
+  SUBROUTINE lcchange_main ( npts, dt_days, veget_max, veget_max_new,&
+       biomass, ind, age, PFTpresent, &
+       senescence, when_growthinit, everywhere, co2_to_bm, &
+       bm_to_litter, turnover_daily, cn_ind, flux10, &
+       flux100, prod10, prod100, convflux, &
+       cflux_prod10, cflux_prod100, leaf_frac, npp_longterm, &
+       lm_lastyearmax, litter, carbon, lignin_struc, &
+       lignin_wood )
+    
+    IMPLICIT NONE
+    
+  !! 0. Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+    
+    INTEGER, INTENT(in)                                       :: npts             !! Domain size - number of pixels (unitless)
+    REAL(r_std), INTENT(in)                                   :: dt_days          !! Time step of vegetation dynamics for stomate
+                                                                                  !! (days)
+ 
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(npts), INTENT(out)                 :: convflux         !! release during first year following land 
+                                                                                  !! cover change
+    REAL(r_std), DIMENSION(npts), INTENT(out)                 :: cflux_prod10     !! total annual release from the 10 year 
+                                                                                  !! turnover pool @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(npts), INTENT(out)                 :: cflux_prod100    !! total annual release from the 100 year-
+                                                                                  !! turnover pool @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                               INTENT(inout)  :: turnover_daily   !! Turnover rates 
+                                                                                  !! @tex ($gC m^{-2} day^{-1}$) @endtex
+
+    !! 0.3 Modified variables   
+    
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: veget_max        !! "maximal" coverage fraction of a PFT (LAI ->
+                                                                                  !! infinity) on ground.  (unitless) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: veget_max_new    !! new "maximal" coverage fraction of a PFT (LAI
+                                                                                  !! -> infinity) on ground. 
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                               INTENT(inout)  :: biomass          !! biomass @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: ind              !! Number of individuals @tex ($m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: age              !! mean age (years)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)               :: senescence       !! plant senescent (only for deciduous trees) Set
+                                                                                  !! to .FALSE. if PFT is introduced or killed
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)               :: PFTpresent       !! Is pft there (unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: everywhere       !! is the PFT everywhere in the grid box or very 
+                                                                                  !! localized (unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: when_growthinit  !! how many days ago was the beginning of the 
+                                                                                  !! growing season (days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: co2_to_bm        !! biomass uptaken 
+                                                                                  !! @tex ($gC m^{-2} day^{-1}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                              INTENT(inout)   :: bm_to_litter     !! conversion of biomass to litter 
+                                                                                  !! @tex ($gC m^{-2} day^{-1}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: cn_ind           !! crown area of individuals 
+                                                                                  !! @tex ($m^{2}$) @endtex
+    REAL(r_std), DIMENSION(npts,0:10), INTENT(inout)          :: prod10           !! products remaining in the 10 year-turnover
+                                                                                  !! pool after the annual release for each 
+                                                                                  !! compartment (10 + 1 : input from year of land
+                                                                                  !! cover change)
+    REAL(r_std), DIMENSION(npts,0:100), INTENT(inout)         :: prod100          !! products remaining in the 100 year-turnover
+                                                                                  !! pool after the annual release for each 
+                                                                                  !! compartment (100 + 1 : input from year of land
+                                                                                  !! cover change)
+    REAL(r_std), DIMENSION(npts,10), INTENT(inout)            :: flux10           !! annual release from the 10/100 year-turnover 
+                                                                                  !! pool compartments
+    REAL(r_std), DIMENSION(npts,100), INTENT(inout)           :: flux100          !! annual release from the 10/100 year-turnover
+                                                                                  !! pool compartments
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout) :: leaf_frac        !! fraction of leaves in leaf age class 
+                                                                                  !! (unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: lm_lastyearmax   !! last year's maximum leaf mass for each PFT 
+                                                                                  !! @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: npp_longterm     !! "long term" net primary productivity 
+                                                                                  !! @tex ($gC m^{-2} year^{-1}$) @endtex
+    REAL(r_std),DIMENSION(npts,nlitt,nvm,nlevs,nelements), &
+                                              INTENT(inout)   :: litter           !! metabolic and structural litter, above and 
+                                                                                  !! below ground @tex ($gC m^{-2}$) @endtex
+    REAL(r_std),DIMENSION(npts,ncarb,nvm), INTENT(inout)      :: carbon           !! carbon pool: active, slow, or passive 
+                                                                                  !! @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(inout)     :: lignin_struc     !! ratio Lignine/Carbon in structural litter,
+                                                                                  !! above and below ground
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(inout)     :: lignin_wood      !! ratio Lignine/Carbon in woody litter,
+                                                                                  !! above and below ground
+
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                            :: i, j, k, l, m    !! indices (unitless)
+    REAL(r_std),DIMENSION(npts,nelements)                     :: bm_new           !! biomass increase @tex ($gC m^{-2}$) @endtex
+    REAL(r_std),DIMENSION(npts,nparts,nelements)              :: biomass_loss     !! biomass loss @tex ($gC m^{-2}$) @endtex
+    REAL(r_std)                                               :: above            !! aboveground biomass @tex ($gC m^{-2}$) @endtex
+    REAL(r_std),DIMENSION(npts,nlitt,nlevs,nelements)         :: dilu_lit         !! Litter dilution @tex ($gC m^{-2}$) @endtex
+    REAL(r_std),DIMENSION(npts,ncarb)                         :: dilu_soil_carbon !! Soil Carbondilution @tex ($gC m^{-2}$) @endtex
+    REAL(r_std),DIMENSION(npts,nlevs)                         :: dilu_lf_struc    !! fraction of structural litter that is lignin
+                                                                                  !! (0-1,unitless)
+    REAL(r_std),DIMENSION(npts,nlevs)                         :: dilu_lf_wood     !! fraction of woody litter that is lignin
+                                                                                  !! (0-1,unitless)
+    REAL(r_std),DIMENSION(nvm)                                :: delta_veg        !! changes in "maximal" coverage fraction of PFT 
+    REAL(r_std)                                               :: delta_veg_sum    !! sum of delta_veg
+    REAL(r_std),DIMENSION(npts,nvm)                           :: delta_ind        !! change in number of individuals  
+!_ ================================================================================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering lcchange_main'
+    
+  !! 1. initialization
+    
+    prod10(:,0)         = zero
+    prod100(:,0)        = zero   
+    above               = zero
+    convflux(:)         = zero
+    cflux_prod10(:)     = zero
+    cflux_prod100(:)    = zero
+    delta_ind(:,:)      = zero
+    delta_veg(:)        = zero
+    
+  !! 2. calculation of changes in carbon stocks and biomass by land cover change\n
+    
+    DO i = 1, npts ! Loop over # pixels - domain size
+       
+       !! 2.1 initialization of carbon stocks\n
+       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
+       dilu_lf_struc(i,:) = zero
+       dilu_lf_wood(i,:) = zero
+       
+       !! 2.2 if vegetation coverage decreases, compute dilution of litter, soil carbon, and biomass.\n
+       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
+             dilu_lf_struc(i,:) = dilu_lf_struc(i,:) + &
+                  delta_veg(j) * lignin_struc(i,j,:)* litter(i,istructural,j,:,icarbon) / delta_veg_sum
+             dilu_lf_wood(i,:) = dilu_lf_wood(i,:) + &
+                  delta_veg(j) * lignin_wood(i,j,:)*litter(i,iwoody,j,:,icarbon) / delta_veg_sum
+             biomass_loss(i,:,:) = biomass_loss(i,:,:) + biomass(i,j,:,:)*delta_veg(j) / delta_veg_sum
+          ENDIF
+       ENDDO
+       
+       !! 2.3 
+       DO j=2, nvm ! Loop over # PFTs
+
+          !! 2.3.1 The case that vegetation coverage of PFTj increases
+          IF ( delta_veg(j) > min_stomate) THEN
+
+             !! 2.3.1.1 Initial setting of new establishment
+             IF (veget_max(i,j) .LT. min_stomate) THEN 
+                IF (is_tree(j)) THEN
+
+                   ! cn_sapl(j)=0.5; stomate_data.f90
+                   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) = 1.
+                senescence(i,j) = .FALSE.
+                age(i,j) = zero
+
+                ! large_value = 1.E33_r_std
+                when_growthinit(i,j) = large_value 
+                leaf_frac(i,j,1) = 1.0
+                npp_longterm(i,j) = npp_longterm_init
+                !+++CHECK+++
+                ! restore link with bm_sapl - prescribed something as a quick fix
+                !lm_lastyearmax(i,j) = bm_sapl(j,ileaf,icarbon) * ind(i,j)
+                lm_lastyearmax(i,j) = 5 * ind(i,j)
+                !+++++++++++
+                
+             ENDIF
+             IF ( cn_ind(i,j) > min_stomate ) THEN
+                delta_ind(i,j) = delta_veg(j) / cn_ind(i,j) 
+             ENDIF
+             
+             !! 2.3.1.2 Update of biomass in each each carbon stock component 
+             !!         Update of biomass in each each carbon stock component (leaf, sapabove, sapbelow,
+             !>         heartabove, heartbelow, root, fruit, and carbres)\n
+             DO k = 1, nparts ! loop over # carbon stock components, nparts = 8; stomate_constant.f90 
+                DO l = 1,nelements ! loop over # elements
+               
+                   !+++CHECK+++
+                   ! restore link with bm_sapl - prescribed something as a quick fix
+                   ! bm_new(i,l) = delta_ind(i,j) * bm_sapl(j,k,l)
+                   bm_new(i,l) = delta_ind(i,j) * 5
+                   !+++++++++++
+
+                   IF (veget_max(i,j) .GT. min_stomate) THEN
+
+                      ! in the case that bm_new is overestimated compared with biomass?
+                      IF ((bm_new(i,l)/delta_veg(j)) > biomass(i,j,k,l)) THEN
+                         bm_new(i,l) = biomass(i,j,k,l)*delta_veg(j)
+                      ENDIF
+                   ENDIF
+                   biomass(i,j,k,l) = ( biomass(i,j,k,l) * veget_max(i,j) + bm_new(i,l) ) / veget_max_new(i,j)
+                   co2_to_bm(i,j) = co2_to_bm(i,j) + (bm_new(i,icarbon)* dt_days) / (one_year * veget_max_new(i,j))
+                END DO ! loop over # elements
+             ENDDO ! loop over # carbon stock components
+
+             !! 2.3.1.3 Calculation of dilution in litter, soil carbon, and  input of litter
+             !!        In this 'IF statement', dilu_* is zero. Formulas for litter and soil carbon
+             !!         could be shortend?? Are the following formulas correct?
+
+            
+             ! Lignin fraction of structural litter
+             lignin_struc(i,j,:)=(lignin_struc(i,j,:) * veget_max(i,j)* litter(i,istructural,j,:,icarbon) + & 
+                  dilu_lf_struc(i,:) * delta_veg(j)) / veget_max_new(i,j) 
+
+             ! Lignin fraction of woody litter
+             lignin_wood(i,j,:)=(lignin_wood(i,j,:) * veget_max(i,j)* litter(i,iwoody,j,:,icarbon) + & 
+                  dilu_lf_wood(i,:) * delta_veg(j)) / veget_max_new(i,j)
+
+             ! Litter
+             litter(i,:,j,:,:)=(litter(i,:,j,:,:) * veget_max(i,j) + &
+                  dilu_lit(i,:,:,:) * delta_veg(j)) / veget_max_new(i,j)
+
+             WHERE ( litter(i,istructural,j,:,icarbon) > min_stomate )
+                lignin_struc(i,j,:) = lignin_struc(i,j,:)/litter(i,istructural,j,:,icarbon)
+             ELSEWHERE
+                lignin_struc(i,j,:) = LC(ileaf)
+             ENDWHERE
+
+             WHERE ( litter(i,iwoody,j,:,icarbon) > min_stomate )
+                lignin_struc(i,j,:) = lignin_struc(i,j,:)/litter(i,iwoody,j,:,icarbon)
+             ELSEWHERE
+                lignin_struc(i,j,:) = LC(iheartabove)
+             ENDWHERE
+
+             ! Soil carbon
+             carbon(i,:,j)=(carbon(i,:,j) * veget_max(i,j) + dilu_soil_carbon(i,:) * delta_veg(j)) / veget_max_new(i,j)
+
+             DO l = 1,nelements
+
+                ! Litter input
+                bm_to_litter(i,j,isapbelow,l) = bm_to_litter(i,j,isapbelow,l) + &
+                     biomass_loss(i,isapbelow,l)*delta_veg(j) / veget_max_new(i,j)
+
+                bm_to_litter(i,j,iheartbelow,l) = bm_to_litter(i,j,iheartbelow,l) + & 
+                     biomass_loss(i,iheartbelow,l) *delta_veg(j) / veget_max_new(i,j)
+
+                bm_to_litter(i,j,iroot,l) = bm_to_litter(i,j,iroot,l) + &
+                     biomass_loss(i,iroot,l)*delta_veg(j) / veget_max_new(i,j)
+
+                bm_to_litter(i,j,ifruit,l) = bm_to_litter(i,j,ifruit,l) + & 
+                     biomass_loss(i,ifruit,l)*delta_veg(j) / veget_max_new(i,j)
+
+                bm_to_litter(i,j,icarbres,l) = bm_to_litter(i,j,icarbres,l) + &
+                     biomass_loss(i,icarbres,l)   *delta_veg(j) / veget_max_new(i,j)
+
+                bm_to_litter(i,j,ileaf,l) = bm_to_litter(i,j,ileaf,l) + &
+                     biomass_loss(i,ileaf,l)*delta_veg(j) / veget_max_new(i,j)
+
+             END DO
+
+             age(i,j)=age(i,j)*veget_max(i,j)/veget_max_new(i,j)
+             
+          !! 2.3.2 The case that vegetation coverage of PFTj is no change or decreases
+          ELSE 
+ 
+             !! 2.3.2.1 Biomass export
+             ! coeff_lcchange_*:  Coeff of biomass export for the year, decade, and century
+             above = biomass(i,j,isapabove,icarbon) + biomass(i,j,iheartabove,icarbon)
+             convflux(i)  = convflux(i)  - ( coeff_lcchange_s(j) * above * delta_veg(j) ) 
+             prod10(i,0)  = prod10(i,0)  - ( coeff_lcchange_m(j) * above * delta_veg(j) )
+             prod100(i,0) = prod100(i,0) - ( coeff_lcchange_l(j) * above * delta_veg(j) )
+             
+             !! 2.3.2.2 Total reduction
+             IF ( veget_max_new(i,j) .LT. min_stomate ) THEN 
+                
+                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 ! Loop over # PFTs
+       
+       !! 2.4 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)
+          flux10(i,m)     =  flux10(i,m-1)
+          
+          IF (prod10(i,m) .LT. 1.0) prod10(i,m) = zero
+       ENDDO
+       
+       cflux_prod10(i) = cflux_prod10(i) + flux10(i,1) 
+       flux10(i,1)     = 0.1 * prod10(i,0)
+       prod10(i,1)     = prod10(i,0)
+       
+       !! 2.5 update 100 year-turnover pool content following flux emission\n
+       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)
+          flux100(i,m)      =  flux100(i,m-1)
+          
+          IF (prod100(i,m).LT.1.0) prod100(i,m) = zero
+       ENDDO
+       
+       cflux_prod100(i)  = cflux_prod100(i) + flux100(i,1) 
+       flux100(i,1)      = 0.01 * prod100(i,0)
+       prod100(i,1)      = prod100(i,0)
+       prod10(i,0)        = zero
+       prod100(i,0)       = zero 
+       
+    ENDDO ! Loop over # pixels - domain size
+    
+  !! 3. history
+    
+    veget_max(:,:) = veget_max_new(:,:)
+    convflux        = convflux/one_year*dt_days
+    cflux_prod10    = cflux_prod10/one_year*dt_days
+    cflux_prod100   = cflux_prod100/one_year*dt_days
+    
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving lcchange_main'
+    
+  END SUBROUTINE lcchange_main
+
+
+! ================================================================================================================================
+!! SUBROUTINE   : land_cover_change_main
+!!
+!>\BRIEF        Impact of land cover change on carbon stocks
+!!
+!! DESCRIPTION  : This subroutine is activated by setting LAND_COVER_CHANGE to  y 
+!! in the run.def file. This sets the flag ::control%ok_land_cover_change.
+!! In the case of 'LAND_COVER_CHANGE = y', the impact of land cover change on 
+!! in-situ carbon stocks is computed in this subroutine. Fluxes from products are
+!! now dealt with in a separate subroutine CHECK. The land cover change is read from
+!! driver maps containing the new "maximal" coverage fraction of a PFT (::veget_max). 
+!! On the basis of this difference, the amount of 'new establishment'/'biomass export',
+!! and increase/decrease of each component, are estimated. The soil carbon from the
+!! PFT which experienced a decrease in ::veget_max is pooled and used as the initial
+!! soil carbon for the PFTs that experienced an increase in ::veget_max.\n
+!!
+!! RECENT CHANGE(S) : (1) Age-classes were introduced and (2) product use was moved 
+!! to a separate module
+!!
+!! MAIN OUTPUT VARIABLE(S) :  
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : 
+!! \n
+!_ ================================================================================================================================
+
+  
+  SUBROUTINE land_cover_change_main (npts, dt_days, veget_max, veget, harvest_pool, &
+                     harvest_type, harvest_cut, harvest_area, &
+                     litter, carbon, lignin_struc, lignin_wood, &
+                     biomass, PFTpresent, everywhere, when_growthinit, & 
+                     leaf_frac, ind, circ_class_n, circ_class_biomass, &
+                     co2_to_bm, forest_managed, &
+                     KF, wstress_season, wstress_month, senescence, npp_longterm, &
+                     age, lm_lastyearmax, harvest_pool_bound, resolution, &
+                     bm_to_litter, leaf_age, circ_class_dist, orphan_flux, &
+                     bm_sync, vir_wstress_fac, tau_eff_leaf, tau_eff_sap, &
+                     tau_eff_root, veget_max_new, age_stand, last_cut, &
+                     c_buried, mb_lcc_error, k_latosa_adapt)
+
+    IMPLICIT NONE
+    
+ !! 0. Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+    
+    INTEGER, INTENT(in)                              :: npts                   !! Domain size - number of pixels (unitless)
+    INTEGER(i_std), DIMENSION (:,:), INTENT(in)      :: forest_managed         !! forest management flag
+    REAL(r_std), INTENT(in)                          :: dt_days                !! Time step of vegetation dynamics for stomate (days)
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: circ_class_dist        !! The probability distribution of trees in a circ
+                                                                               !! class in case of a redistribution (unitless).
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: veget                  !! Fraction of vegetation type including 
+                                                                               !! non-biological fraction (unitless)   
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)       :: resolution             !! Resolution at each grid point (m) [1=E-W, 2=N-S]
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: harvest_pool_bound     !! The boundaries of the diameter classes
+                                                                               !! in the wood harvest pools @tex $(m)$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: tau_eff_root           !! Effective root turnover time that accounts
+                                                                               !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: tau_eff_sap            !! Effective sapwood turnover time that accounts
+                                                                               !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: tau_eff_leaf           !! Effective leaf turnover time that accounts
+                                                                               !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: vir_wstress_fac        !! Water stress factor, based on hum_rel_daily
+                                                                               !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,nvm),INTENT(in)      :: veget_max_new          !! new "maximal" coverage fraction of a PFT on the  
+                                                                               !! ground.  May sum to
+                                                                               !! less than unity if the pixel has
+                                                                               !! nobio area. (unitless, 0-1)
+
+    !! 0.2 Output variables
+    REAL(r_std), DIMENSION(npts) ,INTENT(out)        :: mb_lcc_error            !! 
+
+
+    !! 0.3 Modified variables   
+    
+    LOGICAL, DIMENSION(:,:), INTENT(inout)           :: PFTpresent             !! PFT present (0 or 1)
+    LOGICAL, DIMENSION(:,:), INTENT(inout)           :: senescence             !! Flag for setting senescence stage (only 
+                                                                               !! for deciduous trees)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: KF                     !! Scaling factor to convert sapwood mass into leaf 
+                                                                               !! mass (m)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: k_latosa_adapt         !! Leaf to sapwood area adapted for long 
+                                                                               !! term water stress (m)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: veget_max              !! "maximal" coverage fraction of a PFT on the ground
+                                                                               !! May sum to
+                                                                               !! less than unity if the pixel has
+                                                                               !! nobio area. (unitless, 0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: co2_to_bm              !! CO2 taken from the atmosphere to get C to create  
+                                                                               !! the seedlings @tex (gC.m^{-2}dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: everywhere             !! is the PFT everywhere in the grid box or 
+                                                                               !! very localized (after its introduction) (?)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: when_growthinit        !! how many days ago was the beginning of 
+                                                                               !! the growing season (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: ind                    !! Density of individuals at the stand level 
+                                                                               !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: wstress_season         !! Water stress factor, based on hum_rel_daily
+                                                                               !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: wstress_month          !! Water stress factor, based on hum_rel_daily
+                                                                               !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: npp_longterm           !! "long term" net primary productivity
+                                                                               !! @tex ($gC m^{-2} year^{-1}$) @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: age                    !! mean age (years)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: lm_lastyearmax         !! last year's maximum leaf mass for each PFT 
+                                                                               !! @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: lignin_struc           !! ratio Lignine/Carbon in structural litter,
+                                                                               !! above and below ground
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: lignin_wood            !! ratio Lignine/Carbon in woody litter,
+                                                                               !! above and below ground
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: carbon                 !! carbon pool: active, slow, or passive 
+                                                                               !! @tex ($gC m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: litter                 !! metabolic and structural litter, above and 
+                                                                               !! below ground @tex ($gC m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: circ_class_n           !! Number of individuals in each circ class
+                                                                               !! @tex $(ind m^{-2})$ @endtex   
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: leaf_frac              !! fraction of leaves in leaf age class (unitless;0-1)
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: leaf_age               !! Leaf age (days)
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: biomass                !! Stand level biomass @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: bm_to_litter           !! Transfer of biomass to litter 
+                                                                               !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: circ_class_biomass     !! Biomass components of the model tree within a 
+                                                                               !! circumference class @tex $(g C ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: harvest_pool           !! The wood and biomass that have been
+                                                                               !! havested by humans @tex $(gC)$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: harvest_type           !! Type of management that resulted
+                                                                               !! in the harvest (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: harvest_cut            !! Type of cutting that was used for the harvest
+                                                                               !! (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: harvest_area           !! Harvested area (m^{2})
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: orphan_flux            !! Storage for fluxes of PFTs that no longer exist. 
+                                                                               !! Following the total destruction of a PFT in LCC 
+                                                                               !! (veget_max_new = 0), a flux from before LCC needs a 
+                                                                               !! storage @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:),INTENT(inout)      :: bm_sync                !! The difference betweeen the biomass in the 
+                                                                               !! circ_classes and the total biomass 
+                                                                               !! @tex $(gC m^{-2})$ @endtex
+    INTEGER(i_std), DIMENSION(npts,nvm), INTENT(inout) :: age_stand            !! Age of the forest stand (years)  
+    INTEGER(i_std), DIMENSION(npts,nvm), INTENT(inout) :: last_cut             !! Years since last thinning (years)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: c_buried               !! Carbon buried during a land cover change to
+                                                                               !! a nobio land type (urban/ice).
+                                                                               !!  @tex (gC dt^{-1})$ @endtex
+    !! 0.4 Local variables
+
+
+    REAL(r_std), DIMENSION(npts,nvm,norphans,nelements) &
+                                                     :: orphan_flux_local      !! Storage for fluxes of PFTs that no longer exist. 
+                                                                               !! Following the total destruction of a PFT in LCC 
+                                                                               !! (veget_max_new = 0), a flux from before LCC needs a 
+                                                                               !! storage @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+    INTEGER(i_std)                                   :: ipts,ivm, imbc         !! Indices (unitless)
+    INTEGER(i_std)                                   :: igroup,ifm             !! Indices (unitless)
+    INTEGER(i_std)                                   :: idia,icir,ilage        !! Indices (unitless)
+    INTEGER(i_std)                                   :: jcir,ilit,ilev         !! Indices (unitless)
+    INTEGER(i_std)                                   :: ipar,iele,icarb        !! Indices (unitless)
+    INTEGER(i_std)                                   :: ivma,iyoung,jvma       !! Indices (unitless)
+    INTEGER(i_std)                                   :: nagec_temp             !! Temporary counter
+    LOGICAL                                          :: lsync                  !! returns false if the biomass is not synced
+    REAL(r_std)                                      :: total_losses           !! Sum of losses only in delta_veget (unitless, 0-1)
+    REAL(r_std)                                      :: share_expanded         !! Share of the veget_max of the existing vegetation
+                                                                               !! within a PFT over the total veget_max following 
+                                                                               !! expansion of that PFT (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts)                     :: pixel_area             !! surface area of the pixel @tex ($m^{2}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvmap)               :: veget_max_group        !! Total veget_max of all age clases within a PFT group 
+                                                                               !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,nvmap)               :: veget_max_new_group    !! Total veget_max_new of all age clases within a PFT group 
+                                                                               !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,nvmap)               :: delta_veget            !! Change in veget_max due to LCC restricted to the
+                                                                               !! PFT groups thus not accounting for the age-classes
+                                                                               !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: loss_gain              !! The same as delta_veget but distributed of all
+                                                                               !! age classes and thus taking the age-classes into 
+                                                                               !! account (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts)                     :: loss_gain_nobio        !! The change in nobio fraction during the LCC.  Right
+                                                                               !! now we only take into account a single nobio type.
+                                                                               !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(nlitt,nlevs,nelements)    :: litter_bank            !! Bank to store the litter that becomes available when
+                                                                               !! part of a PFT is removed @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(ncarb)                    :: soil_bank              !! Bank to store soil carbon that becomes available when
+                                                                               !! part of a PFT is removed  @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(nlevs)                    :: struct_ltr_bank        !! Bank to store the lignin in structural litter that 
+                                                                               !! becomes available when part of a PFT is removed 
+                                                                               !! (0-1,unitless)
+    REAL(r_std),DIMENSION(nlevs)                     :: woody_ltr_bank         !! Bank to store the lignin in woody litter that 
+                                                                               !! becomes available when part of a PFT is removed 
+                                                                               !! (0-1,unitless)
+    REAL(r_std),DIMENSION(nvm,nparts,nelements)      :: fresh_litter           !! Pool of fresh litter that is being released during 
+                                                                               !! LCC @tex ($gC m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION(nparts,nelements)          :: fresh_ltr_bank         !! Bank to store all the fresh litter from site 
+                                                                               !! clearing during LCC. Weighted value of fresh_litter
+                                                                               !! @tex ($gC m^{-2}$) @endtex
+    REAL(r_std)                                      :: moi_bank               !! bank to store moiavail_growingseason of the cleared
+                                                                               !! PFT's (unitless; 0-1)
+    REAL(r_std)                                      :: trees_needed           !! Number of trees leftthat should be present in a 
+                                                                               !! circumference class when merging the available and 
+                                                                               !! newly established vegetation
+                                                                               !! @tex $(ind m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(ncirc)                    :: diameters_temp         !! Temporary variable to store the diameters of the
+                                                                               !! different diameter classes (m)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements):: new_biomass            !! Temporary variable for biomass 
+                                                                               !! @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nleafages)       :: new_leaf_frac          !! Temporary variable for leaf_frac (unitless;0-1)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: new_ind                !! Temporary variable for ind @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                    :: est_circ_class_n       !! Temporary variable for circ_class_n of the 
+                                                                               !! established vegetation @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                    :: tmp_circ_class_n       !! Temporary variable for circ_class_n of the 
+                                                                               !! established vegetation @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc)           :: new_circ_class_n       !! Temporary variable for circ_class_n of the
+                                                                               !! new vegetation
+                                                                               !! @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(ncirc,nparts,nelements)   :: est_circ_class_biomass !! Temporary variable for circ_class_biomass of the
+                                                                               !! established vegetation @tex $(g C ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc,nparts,nelements)   :: tmp_circ_class_biomass !! Temporary variable for circ_class_biomass of the
+                                                                               !! established vegetation @tex $(g C ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements) &
+                                                     :: new_circ_class_biomass !! Temporary variable for circ_class_biomass of the
+                                                                               !! new vegetation @tex $(g C ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                    :: est_circ_class_dia     !! Variable to store temporary values for 
+                                                                               !! circ_class (m)
+    REAL(r_std), DIMENSION(ncirc)                    :: tmp_circ_class_dia     !! Variable to store temporary values for 
+                                                                               !! circ_class (m)
+    REAL(r_std), DIMENSION(npts,nvm,ncirc)           :: new_circ               !! Temporary variable for circ (m)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: new_co2_to_bm          !! Temporary variable for co2_to_bm 
+                                                                               !! @tex (gC.m^{-2}dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                 :: new_age                !! Temporary variable for age (years)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: new_lm_lastyearmax     !! Temporary variable for lm_last_year 
+                                                                               !! @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                 :: new_everywhere         !! Temporary variable for everywhere (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: dum_when_growthinit    !! Dummy for when_growthinit (days)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: dum_npp_longterm       !! Dummy for npp_long_term
+                                                                               !! @tex ($gC m^{-2} year^{-1}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements) &
+                                                     :: check_intern           !! Contains the components of the internal
+                                                                               !! mass balance chech for this routine
+                                                                               !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)       :: closure_intern         !! Check closure of internal mass balance
+                                                                               !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)       :: pool_start             !! Start and end pool of this routine 
+                                                                               !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)       :: pool_end               !! Start and end pool of this routine 
+                                                                               !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    LOGICAL, DIMENSION(npts,nvm)                     :: dum_PFTpresent         !! Dummy for PFTpresent (0 or 1)
+    LOGICAL, DIMENSION(npts,nvm)                     :: dum_senescence         !! Dummy for senescence (true/false)
+    REAL(r_std)                                      :: harvest_ratio_stem     !! The fraction of the reserve pools which are
+                                                                               !! located in the stem (unitless, 0-1)
+    REAL(r_std)                                      :: harvest_ratio_branch   !! The fraction of the reserve pools which are
+                                                                               !! located in the branches/roots (unitless, 0-1)
+    REAL(r_std)                                      :: harvest_ratio_litter   !! The fraction of the reserve pools which are
+                                                                               !! moved to the litter (unitless, 0-1)
+    REAL(r_std)                                      :: total_nonheart_biomass !! The total amount of non-heartwood biomass
+                                                                               !! in a model tree
+                                                                               !! @tex $(gC tree^{-1})$ @endtex
+    REAL(r_std)                                      :: total_nonheart_biomass_stem !! The total amount of non-heartwood biomass
+                                                                               !! in a model tree stem
+                                                                               !! @tex $(gC tree^{-1})$ @endtex
+    REAL(r_std)                                      :: total_nonheart_biomass_branch !! The total amount of non-heartwood biomass
+                                                                               !! in a model tree branches/roots
+                                                                               !! @tex $(gC tree^{-1})$ @endtex
+    REAL(r_std) :: temp_sum,temp_total
+    REAL(r_std), DIMENSION(npts)                     :: change_bio             !! The overall change in vegetative fraction for
+                                                                               !! this pixel (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                     :: change_nobio           !! The overall change in non-vegetative fraction for
+                                                                               !! this pixel (0-1, unitless)
+    REAL(r_std), DIMENSION(nlitt,nlevs)              :: litter_weight_expanded !! The fraction of litter on the expanded
+                                                                               !! PFT.
+                                                                               !! @tex $-$ @endtex
+    REAL(r_std), DIMENSION(nlevs)                    :: litter_weight_struc    !! A weighting factor for the structural litter.
+                                                                               !! (unitless)
+    REAL(r_std), DIMENSION(nlevs)                    :: litter_weight_woody    !! A weighting factor for the woody litter.
+                                                                               !! (unitless)
+    LOGICAL                                          :: lconverged             !! A flag for loop convergence
+    INTEGER(i_std)                                   :: max_pft                !! The number of the PFT with the largest addition
+                                                                               !! in land area.
+    INTEGER(i_std)                                   :: min_pft                !! The number of the PFT with the largest reducation
+                                                                               !! in land area (most negative value).
+    INTEGER(i_std)                                   :: nsteps                 !! The number of convergence steps tried.
+    INTEGER(i_std)                                   :: ncount                 !! The number of PFTs with significant changes
+                                                                               !! in vegetation.
+    INTEGER(i_std)                                   :: nagec_local            !! The number of age classes in this map PFT.
+    REAL(r_std)                                      :: difference             !! How much leftover veget_max we have
+    REAL(r_std)                                      :: temp_sum_old           !! 
+    REAL(r_std)                                      :: temp_sum_new           !! 
+    REAL(r_std), DIMENSION(npts,nvm)                 :: veget_max_new_adj      !! new "maximal" coverage fraction of a PFT on the  
+                                                                               !! ground adjusted for numerical precision.  
+                                                                               !! May sum to
+                                                                               !! less than unity if the pixel has
+                                                                               !! nobio area. (unitless, 0-1)
+    !+++ TEMP++++
+    REAL(r_std), DIMENSION(npts,nnobio)    ::  frac_nobio_start,frac_nobio_end
+
+!_ ================================================================================================================================
+
+    !+++++++ TEMP +++++
+    frac_nobio_start(:,:)=zero
+    frac_nobio_end(:,:)=zero
+    DO ipts=1,npts
+       frac_nobio_start(ipts,1)=un-SUM(veget_max(ipts,:))
+       IF(frac_nobio_start(ipts,1) .GT. un)THEN
+          WRITE(numout,*) 'ERROR: nobio fraction greater than one in LCC!'
+          WRITE(numout,*) 'ipts, frac_nobio_start(ipts,1): ',ipts, frac_nobio_start(ipts,1)
+          DO ivm=1,nvm
+             WRITE(numout,*) ivm,veget_max(ipts,ivm)
+          ENDDO
+          STOP
+       ENDIF
+    ENDDO
+    !+++++++++++++++++++
+
+    !+++++++++++ TEMP
+
+!!$    veget_max_new_adj(1,1)=0.07098031
+!!$    veget_max_new_adj(1,2)=0.00000000
+!!$    veget_max_new_adj(1,3)=0.00000000
+!!$    veget_max_new_adj(1,4)=0.00000000
+!!$    veget_max_new_adj(1,5)=0.00023827
+!!$    veget_max_new_adj(1,6)=0.00000000
+!!$    veget_max_new_adj(1,7)= 0.00000000
+!!$    veget_max_new_adj(1,8)=  0.00000000
+!!$    veget_max_new_adj(1,9)= 0.00000
+!!$    veget_max_new_adj(1,10)=  0.00000000
+!!$    veget_max_new_adj(1,11)= 0.00000000
+!!$    veget_max_new_adj(1,12)= 0.00000000
+!!$    veget_max_new_adj(1,13)= 0.00196709
+!!$    veget_max_new_adj(1,14)= 0.00000000
+!!$    veget_max_new_adj(1,15)=  0.00000000
+!!$    veget_max_new_adj(1,16)=  0.00000000
+!!$    veget_max_new_adj(1,17)=  0.00040394
+!!$    veget_max_new_adj(1,18)=  0.00000000
+!!$    veget_max_new_adj(1,19)=   0.00000000
+!!$    veget_max_new_adj(1,20)=  0.00000000
+!!$    veget_max_new_adj(1,21)=   0.00000000
+!!$    veget_max_new_adj(1,22)=  0.00000000
+!!$    veget_max_new_adj(1,23)=  0.00000000
+!!$    veget_max_new_adj(1,24)=  0.00000000
+!!$    veget_max_new_adj(1,25)=  0.00000000
+!!$    veget_max_new_adj(1,26)=   0.00000000
+!!$    veget_max_new_adj(1,27)=   0.00000000
+!!$    veget_max_new_adj(1,28)=   0.00000000
+!!$    veget_max_new_adj(1,29)=  0.00000000
+!!$    veget_max_new_adj(1,30)=  0.00942447
+!!$    veget_max_new_adj(1,31)=   0.00000000
+!!$    veget_max_new_adj(1,32)=   0.00000000
+!!$    veget_max_new_adj(1,33)=  0.00000000
+!!$    veget_max_new_adj(1,34)=  0.04421792
+!!$    veget_max_new_adj(1,35)=  0.00000000
+!!$    veget_max_new_adj(1,36)=   0.00000000
+!!$    veget_max_new_adj(1,37)=   0.00000000
+!!$    veget_max_new_adj(1,38)=  0.04851483
+!!$    veget_max_new_adj(1,39)=   0.00000000
+!!$    veget_max_new_adj(1,40)=   0.00000000
+!!$    veget_max_new_adj(1,41)=  0.00000000
+!!$    veget_max_new_adj(1,42)=  0.00000000
+!!$    veget_max_new_adj(1,43)=  0.05385288
+!!$    veget_max_new_adj(1,44)=  0.00000000
+!!$    veget_max_new_adj(1,45)=  0.00000000
+!!$    veget_max_new_adj(1,46)=   0.00000000
+!!$    veget_max_new_adj(1,47)=  0.00000000
+!!$    veget_max_new_adj(1,48)=  0.00000000
+!!$    veget_max_new_adj(1,49)=  0.00000000
+!!$    veget_max_new_adj(1,50)=   0.00000000
+!!$    veget_max_new_adj(1,51)=  0.00000000
+!!$    veget_max_new_adj(1,52)=  0.00000000
+!!$    veget_max_new_adj(1,53)=  0.00000000
+!!$    veget_max_new_adj(1,54)=  0.00000000
+!!$    veget_max_new_adj(1,55)=  0.00000000
+!!$    veget_max_new_adj(1,56)=  0.00000000
+!!$    veget_max_new_adj(1,57)=  0.00000000
+!!$    veget_max_new_adj(1,58)=  0.00000000
+!!$    veget_max_new_adj(1,59)=  0.00000000
+!!$    veget_max_new_adj(1,60)=  0.00000000
+!!$    veget_max_new_adj(1,61)=  0.00000000
+!!$    veget_max_new_adj(1,62)=  0.35551621
+!!$    veget_max_new_adj(1,63)=  0.00000000
+!!$    veget_max_new_adj(1,64)=  0.41488408
+!!$    veget_max_new_adj(1,65)=  0.00000000
+
+!!$    veget_max_new_adj(1,1)=0.
+!!$    veget_max_new_adj(1,2)=0.00000000
+!!$    veget_max_new_adj(1,3)=0.00000000
+!!$    veget_max_new_adj(1,4)=0.00000000
+!!$    veget_max_new_adj(1,5)=0.5
+!!$    veget_max_new_adj(1,6)=0.00000000
+!!$    veget_max_new_adj(1,7)= 0.00000000
+!!$    veget_max_new_adj(1,8)=  0.00000000
+!!$    veget_max_new_adj(1,9)= 0.00
+!!$    veget_max_new_adj(1,10)=  0.00000000
+!!$    veget_max_new_adj(1,11)= 0.00000000
+!!$    veget_max_new_adj(1,12)= 0.00000000
+!!$    veget_max_new_adj(1,13)= 0.0
+!!$    veget_max_new_adj(1,14)= 0.00000000
+!!$    veget_max_new_adj(1,15)=  0.00000000
+!!$    veget_max_new_adj(1,16)=  0.00000000
+!!$    veget_max_new_adj(1,17)=  0.0
+!!$    veget_max_new_adj(1,18)=  0.00000000
+!!$    veget_max_new_adj(1,19)=   0.00000000
+!!$    veget_max_new_adj(1,20)=  0.00000000
+!!$    veget_max_new_adj(1,21)=   0.00000000
+!!$    veget_max_new_adj(1,22)=  0.00000000
+!!$    veget_max_new_adj(1,23)=  0.00000000
+!!$    veget_max_new_adj(1,24)=  0.00000000
+!!$    veget_max_new_adj(1,25)=  0.00
+!!$    veget_max_new_adj(1,26)=   0.00000000
+!!$    veget_max_new_adj(1,27)=   0.00000000
+!!$    veget_max_new_adj(1,28)=   0.00000000
+!!$    veget_max_new_adj(1,29)=  0.00000000
+!!$    veget_max_new_adj(1,30)=   0.00
+!!$    veget_max_new_adj(1,31)=   0.00000000
+!!$    veget_max_new_adj(1,32)=   0.00000000
+!!$    veget_max_new_adj(1,33)=  0.00000000
+!!$    veget_max_new_adj(1,34)=   0.0
+!!$    veget_max_new_adj(1,35)=  0.00000000
+!!$    veget_max_new_adj(1,36)=   0.00000000
+!!$    veget_max_new_adj(1,37)=   0.00000000
+!!$    veget_max_new_adj(1,38)=  0.0
+!!$    veget_max_new_adj(1,39)=   0.00000000
+!!$    veget_max_new_adj(1,40)=   0.00000000
+!!$    veget_max_new_adj(1,41)=  0.00000000
+!!$    veget_max_new_adj(1,42)=  0.00000000
+!!$    veget_max_new_adj(1,43)=   0.0
+!!$    veget_max_new_adj(1,44)=  0.00000000
+!!$    veget_max_new_adj(1,45)=  0.00000000
+!!$    veget_max_new_adj(1,46)=   0.00000000
+!!$    veget_max_new_adj(1,47)=  0.00000000
+!!$    veget_max_new_adj(1,48)=  0.00000000
+!!$    veget_max_new_adj(1,49)=  0.00000000
+!!$    veget_max_new_adj(1,50)=   0.00000000
+!!$    veget_max_new_adj(1,51)=  0.00000000
+!!$    veget_max_new_adj(1,52)=  0.00000000
+!!$    veget_max_new_adj(1,53)=  0.00000000
+!!$    veget_max_new_adj(1,54)=  0.00000000
+!!$    veget_max_new_adj(1,55)=  0.00000000
+!!$    veget_max_new_adj(1,56)=  0.00000000
+!!$    veget_max_new_adj(1,57)=  0.00000000
+!!$    veget_max_new_adj(1,58)=  0.00000000
+!!$    veget_max_new_adj(1,59)=  0.00000000
+!!$    veget_max_new_adj(1,60)=  0.00000000
+!!$    veget_max_new_adj(1,61)=  0.00000000
+!!$    veget_max_new_adj(1,62)=  0.5
+!!$    veget_max_new_adj(1,63)=  0.00000000
+!!$    veget_max_new_adj(1,64)=  0.
+!!$    veget_max_new_adj(1,65)=  0.00000000
+    !+++++++++++++++++++++
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering land cover change main'
+
+    ! Sometimes maps are read in which are created in single
+    ! precision.  Values in the code may be double precision,
+    ! however.  min_stomate is usually set to 1e-8, which is
+    ! similar to single precision.  Depending on the maps
+    ! used, this can frequently cause mass balance errors
+    ! on the order of 1e-5 to 1e-8 as the old veget_max
+    ! and the new veget max sum to a value just less
+    ! than min_stomate, which when multiplied by the pools
+    ! used gives a value greater than min_stomate of carbon
+    ! which is considered lost.  This first loop corrects for
+    ! that and closes the mass balance.
+    DO ipts=1,npts
+       temp_sum_new=zero
+       temp_sum_old=zero
+       DO ivm=1,nvm
+          temp_sum_new=temp_sum_new+veget_max_new(ipts,ivm)
+          temp_sum_old=temp_sum_old+veget_max(ipts,ivm)
+       ENDDO
+       IF(ld_lcc .AND. ipts == test_grid)THEN
+          WRITE(numout,*) 'temp_sum_old: ',temp_sum_old
+          WRITE(numout,*) 'temp_sum_new: ',temp_sum_new
+       ENDIF
+       difference=ABS(temp_sum_old-temp_sum_new)
+       ! If the difference is too big, there is a significant difference
+       ! in the nobio fraction, which has to be specially taken
+       ! care of.  We let a check below deal with that.
+       IF(difference .NE. zero .AND. difference .LT. min_stomate)THEN
+          DO ivm=1,nvm
+             veget_max_new_adj(ipts,ivm)=veget_max_new(ipts,ivm)*temp_sum_old/temp_sum_new
+          ENDDO
+       ELSE
+          ! Nothing to change.
+          DO ivm=1,nvm
+             veget_max_new_adj(ipts,ivm)=veget_max_new(ipts,ivm)
+          ENDDO
+       ENDIF
+    ENDDO
+    
+    !  +++COMMENT+++
+    !  This part is poorly coded as it uses the externalisation to
+    !  implement the age classes. The advanatage of this approach is
+    !  that is rather simple to implement. The alternative requires
+    !  that a dimension for age classes is added to almost all fluxes
+    !  and pool in sechiba and stomate. Also the externalisation would
+    !  need to be adjusted as the parameters are now be used for the
+    !  different age classes.
+    !
+    !  The coding is considered poor because it is : (1) sensitive to 
+    !  order in which the PFTs are defined and (2) inconsistent as
+    !  cohorts (within a stand got an own dimension) and age classes
+    !  (across stands) are implemented through the externalisation.
+    !  An example for 2 age classes and 8 tree PFTs
+    !  PFT_1: bare soil
+    !  PFT_2: PFT2_1 age class 1 (youngest)
+    !  PFT_3: PFT2_2 age class 2 (youngest + 1)
+    !  PFT_4: PFT3_1
+    !  PFT_5: PFT3_2
+    !  ...
+    !  PFT_18: PFT 10 agricultural PFTs don't have age classes
+    !  PFT_19: PFT 11 agricultural PFTs don't have age classes
+    !  PFT_20: PFT 11 agricultural PFTs don't have age classes
+    !  PFT_21: PFT 11 agricultural PFTs don't have age classes
+    !  
+    !  A PFT group are all age classes a a certain PFT/species
+    !
+    !  Some of this complexity could be avoided by preparing the maps
+    !  for the exact the number of age classes we want to deal with
+    !  but that just shifts the complexity. It also means that we have
+    !  to prescribe the age classes, which is not our goal. 
+    !  For now I assumed the maps only consider the PFTs without age classes.
+    !  +++++++++++
+   
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          IF(ipts == test_grid .AND. ivm == test_pft)THEN
+             WRITE(numout,*) 'orphan_flx at the beginning ',orphan_flux(ipts,ivm,:,:)
+          ENDIF
+       ENDDO
+    ENDDO
+     
+ !! 1. Initialization
+    
+    !! 1.1 Initialize variables
+    delta_veget(:,:) = zero 
+    loss_gain(:,:) = zero
+    veget_max_group(:,:) = zero
+    veget_max_new_group(:,:) = zero
+    ! There is a chance that the orphan fluxes will already have a value
+    ! at this point.  Store them in the local array for the calculation
+    ! of the subroutine.
+    ! There is also the chance that co2_to_bm will have something in it, for
+    ! example, if something was prescribed in this step.  We we do not save
+    ! that as an orphan flux, it will not be accounted for in the pool_end,
+    ! which means we get a mass balance error even if no LCC happens in this
+    ! step.
+    orphan_flux_local(:,:,:,:)=zero
+    !DO ipts=1,npts
+    !   DO ivm=1,nvm
+    !      IF(co2_to_bm(ipts,ivm) .GT. min_stomate)THEN
+    !         orphan_flux_local(ipts,ivm,ico2bm,icarbon) = co2_to_bm(ipts,ivm)
+    !      END IF
+    !   ENDDO
+    !ENDDO
+
+    ! Surface area (m2) of the pixel
+    pixel_area(:) = resolution(:,1) * resolution(:,2)
+
+    !! 1.2 Initialize check for mass balance closure
+    !  The mass balance is calculated at the end of this routine
+    !  in section 6. Initial biomass and harvest pool all other
+    !  relevant pools were just set to zero.
+    pool_start(:,:,:) = zero
+    DO iele = 1,nelements
+       
+       IF(test_grid > 0)THEN
+          IF(test_pft < nvm)THEN
+             WRITE(numout,'(A,10ES20.10)') 'Start pool 1 ',pool_start(test_grid,test_pft,iele)
+          ENDIF
+       ENDIF
+
+       ! co2_to_bm
+       ! We subtract any old flux here.  The reason is that this old flux will
+       ! not be accounted for at the end when the final pools are calculated,
+       ! so if we don't remove it now we get a mass imbalance.
+       pool_start(:,:,iele) = pool_start(:,:,iele) + co2_to_bm(:,:) &
+            - orphan_flux(:,:,ico2bm,icarbon) 
+
+       IF(test_grid > 0)THEN
+          IF(test_pft < nvm)THEN
+             WRITE(numout,'(A,10ES20.10)') 'Start pool 2 ',pool_start(test_grid,test_pft,iele),&
+                  orphan_flux(test_grid,test_pft,ico2bm,icarbon),&
+                  orphan_flux(test_grid,test_pft,ivegold,icarbon),&
+                  co2_to_bm(test_grid,test_pft)
+          ENDIF
+       ENDIF
+
+       ! Biomass pool + bm_to_litter
+       DO ipar = 1,nparts
+          pool_start(:,:,iele) = pool_start(:,:,iele) + &
+               (biomass(:,:,ipar,iele) + bm_to_litter(:,:,ipar,iele)) * &
+               veget_max(:,:)
+          IF(test_grid > 0)THEN
+             IF(test_pft < nvm)THEN
+                WRITE(numout,'(A,I5,10ES20.10)') 'Start biomass ',ipar,biomass(test_grid,test_pft,ipar,iele) , &
+                     bm_to_litter(test_grid,test_pft,ipar,iele), &
+                     veget_max(test_grid,test_pft)
+             ENDIF
+          ENDIF
+       ENDDO
+
+      IF(test_grid > 0)THEN
+          IF(test_pft < nvm)THEN
+             WRITE(numout,'(A,10ES20.10)') 'Start pool 3 ',pool_start(test_grid,test_pft,iele)
+          ENDIF
+       ENDIF
+
+       ! Litter pool (gC m-2) *  (m2 m-2) 
+       DO ilit = 1,nlitt
+          DO ilev = 1,nlevs
+             pool_start(:,:,iele) = pool_start(:,:,iele) + &
+                  litter(:,ilit,:,ilev,iele) * veget_max(:,:)
+          ENDDO
+       ENDDO
+
+      IF(test_grid > 0)THEN
+          IF(test_pft < nvm)THEN
+             WRITE(numout,'(A,10ES20.10)') 'Start pool 4 ',pool_start(test_grid,test_pft,iele)
+          ENDIF
+       ENDIF
+
+       ! Soil carbon (gC m-2) *  (m2 m-2)
+       DO icarb = 1,ncarb
+          pool_start(:,:,iele) = pool_start(:,:,iele) + &
+               carbon(:,icarb,:) * veget_max(:,:)
+       ENDDO
+
+      IF(test_grid > 0)THEN
+          IF(test_pft < nvm)THEN
+             WRITE(numout,'(A,10ES20.10)') 'Start pool 5 ',pool_start(test_grid,test_pft,iele)
+          ENDIF
+       ENDIF
+
+    ENDDO
+
+    ! The biomass harvest pool is expressed in gC pixel-1 So, it 
+    ! shouldn't be multiplied by veget_max but it should be divided
+    ! by pixel_area to obtain gC m-2.
+    DO ivm = 1,nvm
+       pool_start(:,ivm,icarbon) = pool_start(:,ivm,icarbon) + &
+            SUM(harvest_pool(:,ivm,:,icarbon),2) / &
+            pixel_area(:)
+    ENDDO
+    
+!! 2. Calculate common variables 
+ 
+    !  For several calculations the total cover of all age class within 
+    !  its group (::veget_max_group) is required.  We also need the
+    !  vegetation fraction of the PFT map arranged into groups.  Notice
+    !  that this number is already given in terms of groups, but it is
+    !  stored on a grid using all nvm pfts, i.e. only nvmap values of
+    !  veget_max_new(ipts,:) are non-zero.
+    
+    DO ipts = 1,npts
+ 
+       DO ivm=1,nvm
+
+          igroup=agec_group(ivm)
+          
+          veget_max_group(ipts,igroup) = veget_max_group(ipts,igroup) + &
+                        veget_max(ipts,ivm)
+          veget_max_new_group(ipts,igroup) = veget_max_new_group(ipts,igroup) + &
+                        veget_max_new_adj(ipts,ivm)
+
+       ENDDO ! loop over PFTs
+
+    ENDDO ! loop over #pixels - domain size
+
+    IF (ld_lcc) THEN
+       WRITE(numout,*) 'Finished computing veget_max_group.'
+       CALL print_lcc_error_message(npts,test_grid,veget_max_new_adj,veget_max,veget_max_new_group,&
+            veget_max_group,delta_veget,loss_gain,1)
+       CALL print_lcc_error_message(npts,test_grid,veget_max_new_adj,veget_max,veget_max_new_group,&
+            veget_max_group,delta_veget,loss_gain,2)
+       CALL print_lcc_error_message(npts,test_grid,veget_max_new_adj,veget_max,veget_max_new_group,&
+            veget_max_group,delta_veget,loss_gain,5)
+    ENDIF
+
+
+ !! 3. Check consistency of the LCC maps
+
+    ! Within each pixel the fraction of losses should equal the fraction of gains.
+    ! The soil carbon avaible from the losses is averaged and used as the initial 
+    ! soil carbon for the gains. This assumption is acceptable when the fraction of 
+    ! none biological land uses remains constant. If this fraction is changing i.e.
+    ! following glacier retreat, the current approach will need to be checked and
+    ! most likely adjusted. The same applies in case vegetation is removed for
+    ! urban sprawing. This routine will need to decide whether the soil carbon is 
+    ! simply buried under the hard surfaces or whether it decomposes?
+
+    !! 3.1 Calculate the change in vegetation cover
+    delta_veget(:,:) =  veget_max_new_group(:,:) - veget_max_group(:,:)
+
+    !---TEMP---
+    IF (ld_lcc) THEN
+       WRITE(numout,*) 'Before normalization of delta_veget'
+       CALL print_lcc_error_message(npts,test_grid,veget_max_new_adj,veget_max,veget_max_new_group,&
+            veget_max_group,delta_veget,loss_gain,3)
+    ENDIF
+    !----------
+
+    !! 3.2 Readjust the change in vegetation cover for the PFTs so that
+    !!     no change is less than min_vegfrac and that no change leads
+    !!     to PFTs values which are too high or too low.
+    CALL adjust_delta_veget(npts,veget_max,veget_max_group,veget_max_new_adj,&
+       veget_max_new_group,loss_gain,delta_veget)
+
+   !---TEMP---
+    IF (ld_lcc) THEN
+       WRITE(numout,*) 'After normalization of delta_veget and loss_gain'
+       CALL print_lcc_error_message(npts,test_grid,veget_max_new_adj,veget_max,veget_max_new_group,&
+            veget_max_group,delta_veget,loss_gain,3)
+       CALL print_lcc_error_message(npts,test_grid,veget_max_new_adj,veget_max,veget_max_new_group,&
+            veget_max_group,delta_veget,loss_gain,4)
+    ENDIF
+    !----------
+
+    ! Check whether gains equal losses. If not it is unlikely that the C-balance
+    ! will be closed.
+    DO ipts = 1,npts
+       change_bio(ipts)=SUM(delta_veget(ipts,:))
+       ! The nobio fractions are the leftover fractions when all the vegetation
+       ! fractions are summed up.
+       change_nobio(ipts)=(un-SUM(veget_max_new_group(ipts,:)))-&
+            (un-SUM(veget_max_group(ipts,:)))
+       IF ( ABS(change_bio(ipts)+change_nobio(ipts)) .GE. min_stomate) THEN
+          ! Losses and gains don't cancel each other out
+          WRITE(numout,*) "Error: LCC losses and gains don't cancel each other out in pixel, ", ipts
+          WRITE(numout,*) 'Mismatch: ',change_bio(ipts)+change_nobio(ipts)
+          WRITE(numout,*) 'change_bio: ',change_bio(ipts)
+          WRITE(numout,*) 'change_nobio: ',change_nobio(ipts)
+          WRITE(numout,*) 'sum of delta_veget: ',SUM(delta_veget(ipts,:))
+          WRITE(numout,*) 'sum of veget_max_new_group: ',SUM(veget_max_new_group(ipts,:))
+          WRITE(numout,*) 'sum of veget_max_new_adj: ',SUM(veget_max_new_adj(ipts,:))
+          WRITE(numout,*) 'sum of veget_max_group: ',SUM(veget_max_group(ipts,:))
+          CALL ipslerr_p (2,'land_cover_main', 'Losses and gains do not cancel in land_cover_change.',&
+               'Look for Error in out_orchidee file for details','')
+
+       ELSE
+
+          ! Losses and gains cancel each other out
+          !---TEMP---
+          IF (ld_lcc .AND. test_grid == ipts) THEN
+             WRITE(numout,*) "LCC losses and gains cancel each other out "
+             WRITE(numout,*) 'OK: ',change_bio(ipts),change_nobio(ipts)
+          ENDIF
+          !----------
+
+       ENDIF
+
+       ! Right now, we are only confident are accounting of nobio fraction
+       ! is reasonable if the changes are really, really small (basically
+       ! numerical issues).  If this is not the case, print a warning,
+       ! since someone should think this through more clearly.  This check should
+       ! be taken care of already in slowproc_update.
+       IF(ABS(change_nobio(ipts)) .GT. min_vegfrac)THEN
+          WRITE(numout,*) 'LCC1 WARNING: Large change in nobio fraction in LCC!'
+          WRITE(numout,*) 'ipts: ',ipts
+          WRITE(numout,*) 'change_nobio: ',change_nobio(ipts)
+          WRITE(numout,*) 'ivm veget_max_new_adj veget_max'
+          DO ivm=1,nvm
+             WRITE(numout,'(I7,2F12.8)') ivm,veget_max_new_adj(ipts,ivm),veget_max(ipts,ivm)
+          ENDDO
+          CALL ipslerr_p (2,'land_cover_main', 'Large change in nobio fraction',&
+               'Look for LCC1 WARNING in out_orchidee file for details','')
+       ENDIF
+
+    ENDDO ! npts
+
+ !! 5. Calculate in-situ land cover changes
+
+    !  NOTE: within the model framework there is large conceptual
+    !  difference between management and clear cuts on the one
+    !  hand and LCC on the other hand. Within the model LCC
+    !  DOES NOT change the biomass, ind, ... of the PFTs that
+    !  experience a loss (because we store those in gC m-2). LCC 
+    !  only changes the values of veget_max for those PFTs. For
+    !  this reason it was decided not to make use of lpj_kill.f90
+    !  and sapiens_gap.f90 (as is done for forest management) 
+    !  because this would be in conflict with the meaning of the 
+    !  variable ::circ_class_kill. It is not impossible to work 
+    !  around this issues but it could result in difficulties with
+    !  the order of code in more complex cases were part of the PFT 
+    !  experiences a surface loss and at the same time is ready to
+    !  get thinned or clear cut. It appears cleaner to deal with
+    !  LCC up front in a self-contained module.
+
+    !! 5.1 Land cover losses within a pixel
+    !  The losses need to be calculated first such that the soil
+    !  carbon (and other elements) can be put in the soil&litter-bank. 
+    !  Subsequently, the soil&litter-bank is used to initialize the 
+    !  soil carbon of the new PFTs. The biomass is moved into a 
+    !  harvest pool.
+    !  NOTE: make sure that all variables for PFT1 are initialized!
+    !  If not LCC won't properly work.
+    DO ipts = 1, npts ! Loop over # pixels - domain size    
+
+       !! 5.1.1 Initialize the soil&litter-bank
+       !  NOTE Some of these variables have a dimension for ::nelements
+       !  others don't. Make sure ::nelements is accounted for when 
+       !  N is added to the model.
+       soil_bank(:) = zero
+       litter_bank(:,:,:) = zero
+       struct_ltr_bank(:) = zero
+       woody_ltr_bank(:) = zero
+       fresh_litter(:,:,:) = zero
+       fresh_ltr_bank(:,:) = zero
+       moi_bank = zero
+        
+       !! 5.1.2 Loss in PFT cover, update harvest and soil&litter-C-bank
+
+       !  To calculate the relative change in cover fraction, PFT-specific 
+       !  changes need to be normalized by the total change which is in 
+       !  this case the total loss. Total losses includes losses in PFT1
+       total_losses = SUM(loss_gain(ipts,:), MASK = loss_gain(ipts,:) .LT. zero)
+
+       ! Calculate the factor to weight the lignin ratios by when merging.
+       ! This depends on the amount of litter on the PFTs where vegetation
+       ! is being cut.
+       litter_weight_struc(:)=zero
+       litter_weight_woody(:)=zero
+       DO ivm = 1, nvm
+          IF ( loss_gain(ipts,ivm) .LE. -min_stomate ) THEN
+             DO ilev=1,nlevs
+                litter_weight_struc(ilev)=litter_weight_struc(ilev)+&
+                     litter(ipts,istructural,ivm,ilev,icarbon) * ABS(loss_gain(ipts,ivm))
+                litter_weight_woody(ilev)=litter_weight_woody(ilev)+&
+                     litter(ipts,iwoody,ivm,ilev,icarbon) * ABS(loss_gain(ipts,ivm))
+             ENDDO
+          ENDIF
+       ENDDO
+
+       DO ivm = 1, nvm
+
+          ! The PFT cover decreases, move wood into the harvest pool, the 
+          ! stumps and branches are supposed to be exported from the site 
+          ! so they go into the harvest pool as well but a separated pool
+          ! was introduced for separate treatment in the product use module
+          ! Leaves, fine roots and fruits are deposited on the soil&litter
+          ! bank and will be attributed to the new PFT. This order of 
+          ! calculations ensures that the litter ends up in the right PFT
+          ! and that it is only decomposed once.         
+          IF ( loss_gain(ipts,ivm) .LE. -min_stomate ) THEN
+
+             !! 5.1.2.1 Biomass losses of trees
+             IF (is_tree(ivm)) THEN
+
+                ! We will need the trunk diameters for all the circ classes in 
+                ! order to figure out which harvest pool to put them in.
+                diameters_temp(:) = &
+                     wood_to_dia(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)
+
+                ! Store the management stategy of the pixel and PFT
+                ifm = forest_managed(ipts,ivm)
+
+                ! Now we have the stems diameters.  These are what we want to
+                ! save, and we are going to classify them by PFT type, location, 
+                ! and diameter so that we can compare to FAO statistics and do 
+                ! some more interesting post-treatment (sapiens_product_use.f90).
+                DO icir = 1,ncirc
+
+                   ! We want to make sure we divide up the labile and carbohydrate
+                   ! reserve pools in the same was as in other management.  We
+                   ! assume that when a tree is cut down, it cannot rearrange 
+                   ! these pools, and therefore the amount that is harvested
+                   ! is the ratio that is stored in the harvest wood.  We assume
+                   ! that the reserve pools are stored equally in all non-heart
+                   ! tissue.  The harvest right now goes into three different
+                   ! places: two harvest pools and litter.  We need the fractions
+                   ! for the reserve pools going into each place.
+                   total_nonheart_biomass = &
+                        circ_class_biomass(ipts,ivm,icir,isapbelow,icarbon)+&
+                        circ_class_biomass(ipts,ivm,icir,iroot,icarbon)+&
+                        circ_class_biomass(ipts,ivm,icir,ileaf,icarbon)+&
+                        circ_class_biomass(ipts,ivm,icir,ifruit,icarbon)+&
+                        circ_class_biomass(ipts,ivm,icir,isapabove,icarbon)
+                   ! This includes the roots and the branches, since it goes into
+                   ! a different pool.
+                   total_nonheart_biomass_branch=branch_ratio(ivm)*&
+                        circ_class_biomass(ipts,ivm,icir,isapabove,icarbon)+&
+                        circ_class_biomass(ipts,ivm,icir,isapbelow,icarbon)
+                   total_nonheart_biomass_stem=(un-branch_ratio(ivm))*&
+                        circ_class_biomass(ipts,ivm,icir,isapabove,icarbon)
+
+                   ! These are the three ratios we need to move the reserve pools around.
+                   harvest_ratio_branch=total_nonheart_biomass_branch/total_nonheart_biomass
+                   harvest_ratio_stem=total_nonheart_biomass_stem/total_nonheart_biomass
+                   harvest_ratio_litter=un - harvest_ratio_stem -  harvest_ratio_branch
+
+                   dia_loop:DO idia=1,ndia_harvest
+
+                      IF(diameters_temp(icir) .LE. harvest_pool_bound(idia))THEN
+
+                         ! This is the correct diameter class
+                         ! Move wood (excluding the branches) and the carbres and labile
+                         ! C contained in the wood into the harvest pool. Note that the 
+                         ! unit of circ_class_biomass is gC tree-1, so multiply with the 
+                         ! number of trees to obtain gC m-2. To avoid complexities when 
+                         ! dealing with the product pool multiply with the cover change 
+                         ! and the surface area of the pixel to obtain a weighted mean 
+                         ! expressed in gC.
+                         harvest_pool(ipts,ivm,idia,icarbon) = &
+                              harvest_pool(ipts,ivm,idia,icarbon) + &  
+                              ABS(loss_gain(ipts,ivm)) * pixel_area(ipts) * & 
+                              ( (un - branch_ratio(ivm)) * circ_class_n(ipts,ivm,icir) * &
+                              ( circ_class_biomass(ipts,ivm,icir,isapabove,icarbon) + &
+                              circ_class_biomass(ipts,ivm,icir,iheartabove,icarbon)) +&
+                              ! reserves
+                              harvest_ratio_stem * circ_class_n(ipts,ivm,icir) * &
+                              (circ_class_biomass(ipts,ivm,icir,icarbres,icarbon) + &
+                              circ_class_biomass(ipts,ivm,icir,ilabile,icarbon) ) )
+
+                         ! Associated harvest variables
+                         harvest_type(ipts,ivm) = ifm
+                         harvest_cut(ipts,ivm) = icut_lcc_wood
+                         harvest_area(ipts,ivm) = ABS(loss_gain(ipts,ivm) * pixel_area(ipts))
+
+                         ! Move stumps and branches and the carbres and labile C 
+                         ! contained in them into a separate harvest pool. Stumps 
+                         ! and branches are removed from the site but can now be 
+                         ! treated separately from stem wood in the product use 
+                         ! module (sapiens_product_use.f90)       
+                         harvest_pool(ipts,ivm,idia,icarbon) = &
+                              harvest_pool(ipts,ivm,idia,icarbon) + &
+                              ABS(loss_gain(ipts,ivm)) * pixel_area(ipts) * &
+                              ! branches
+                              ( branch_ratio(ivm) * circ_class_n(ipts,ivm,icir) * &
+                              ( circ_class_biomass(ipts,ivm,icir,isapabove,icarbon) + &
+                              circ_class_biomass(ipts,ivm,icir,iheartabove,icarbon)) + &
+                              ! reserves
+                              harvest_ratio_branch * circ_class_n(ipts,ivm,icir) * &
+                              (circ_class_biomass(ipts,ivm,icir,icarbres,icarbon) + &
+                              circ_class_biomass(ipts,ivm,icir,ilabile,icarbon) )  + &
+                              ! stumps (all icarbres and ilabile is distributed
+                              ! over the stems and branches)
+                              circ_class_n( ipts,ivm,icir) * &
+                              ( circ_class_biomass(ipts,ivm,icir,isapbelow,icarbon) + &
+                              circ_class_biomass(ipts,ivm,icir,iheartbelow,icarbon) ) )
+                         
+                         ! Associated harvest variables
+                         harvest_type(ipts,ivm) = ifm
+                         harvest_cut(ipts,ivm) = icut_lcc_res
+                         harvest_area(ipts,ivm) = ABS(loss_gain(ipts,ivm) * pixel_area(ipts))
+                        
+                         ! Deposit the leaves, roots and fruit into a temporary litter 
+                         ! pool and place it in the soil and litter bank
+                         fresh_litter(ivm,ileaf,icarbon) = &
+                              fresh_litter(ivm,ileaf,icarbon) + &
+                              circ_class_biomass(ipts,ivm,icir,ileaf,icarbon) * &
+                              circ_class_n(ipts,ivm,icir)
+                         fresh_litter(ivm,iroot,icarbon) = &
+                              fresh_litter(ivm,iroot,icarbon) + &
+                              circ_class_biomass(ipts,ivm,icir,iroot,icarbon) * &
+                              circ_class_n(ipts,ivm,icir)
+                         fresh_litter(ivm,ifruit,icarbon) = &
+                              fresh_litter(ivm,ifruit,icarbon) + &
+                              circ_class_biomass(ipts,ivm,icir,ifruit,icarbon) * &
+                              circ_class_n(ipts,ivm,icir)
+                         fresh_litter(ivm,icarbres,icarbon) = &
+                              fresh_litter(ivm,icarbres,icarbon) + &
+                              harvest_ratio_litter*&
+                              circ_class_biomass(ipts,ivm,icir,icarbres,icarbon) * &
+                              circ_class_n(ipts,ivm,icir)
+                         fresh_litter(ivm,ilabile,icarbon) = &
+                              fresh_litter(ivm,ilabile,icarbon) + &
+                              harvest_ratio_litter*&
+                              circ_class_biomass(ipts,ivm,icir,ilabile,icarbon) * &
+                              circ_class_n(ipts,ivm,icir)
+
+                         EXIT dia_loop
+
+                      ENDIF ! correct diameter class
+
+                      ! If we are here, it means the diameter of this trunk is larger 
+                      ! than the upper boundary of our harvest bins.  Considering the 
+                      ! upper boundary is set to be 99999 meters in constants.f90, 
+                      ! something has gone wrong!
+                      IF(idia == ndia_harvest)THEN
+
+                         WRITE(numout,*) 'Our tree is too big to fit into the harvest pools.'
+                         WRITE(numout,*) 'ipts, ivm, icir: ',ipts, ivm, icir
+                         WRITE(numout,*) 'diameters_temp(icir), harvest_pool_bound(idia)',&
+                              diameters_temp(icir),harvest_pool_bound(idia)
+                         CALL ipslerr_p (3,'land_cover_main', 'harvest pool error (see output file)','','')
+
+                      ENDIF
+
+                   ENDDO dia_loop
+
+                ENDDO ! ncirc
+
+             !! 5.1.2.2 Biomass losses of grasses and crops
+             !  During LCC grasses and crops are simply plowed under 
+             !  and should thus be move into ::fresh_litter which is
+             !  moved later on into the litter bank ::fresh_ltr_bank
+             !  and finally into ::bm_to_litter. The bank is needed
+             !  to take a weighted average.
+             ELSE
+
+                fresh_litter(ivm,:,icarbon) = fresh_litter(ivm,:,icarbon) + &
+                     biomass(ipts,ivm,:,icarbon)
+                
+             ENDIF ! is_tree(ivm)
+
+             !! 5.1.2.3 Deposit soil and litter and soil&litter bank
+             ! Deposit the released soil&litter pools on the soil&litter-bank. 
+             ! The units of the C-pools are in gC m-2, hence, they need to be 
+             ! weighted by their relative change in cover fraction to obtain 
+             ! the C-pool (gC pixel-2) of the soil&litter-C-bank.     
+             litter_bank(:,:,:) = litter_bank(:,:,:) + &
+                  loss_gain(ipts,ivm) * litter(ipts,:,ivm,:,:) / total_losses
+             soil_bank(:) =  soil_bank(:) + &
+                  loss_gain(ipts,ivm) * carbon(ipts,:,ivm) / total_losses
+             DO ilev=1,nlevs
+                IF(litter_weight_struc(ilev) .GE. min_stomate)THEN
+                   struct_ltr_bank(ilev) = struct_ltr_bank(ilev) + &
+                        lignin_struc(ipts,ivm,ilev) * &
+                        (litter(ipts,istructural,ivm,ilev,icarbon) * ABS(loss_gain(ipts,ivm))) / &
+                        litter_weight_struc(ilev)
+                ENDIF
+                IF(litter_weight_woody(ilev) .GE. min_stomate)THEN
+                   woody_ltr_bank(ilev) = woody_ltr_bank(ilev) + &
+                        lignin_wood(ipts,ivm,ilev) * &
+                        (litter(ipts,iwoody,ivm,ilev,icarbon) * ABS(loss_gain(ipts,ivm))) / &
+                        litter_weight_woody(ilev)
+                ENDIF
+             ENDDO
+
+             fresh_ltr_bank(:,:) = fresh_ltr_bank(:,:) + &
+                  loss_gain(ipts,ivm) * fresh_litter(ivm,:,:) / total_losses
+
+             ! In stomate_season.f90
+             ! this variable is only calculated if the biomass(ileaf) > 0. As long
+             ! as veget_max is 0, this variable does not get a value. We need a value
+             ! to calculate ::KF which in turn is needed to calculate the biomass
+             ! of the seedlings we will prescribe. At this point in the calculation
+             ! the moiavail_growingseason from PFT1 is still zero so it is not 
+             ! accounted for yet. Its exact value depends on the the PFT that will
+             ! be established on PFT1 and it will be accounted for later in the code
+             IF (ivm .GT. 1) THEN
+
+                moi_bank = moi_bank + loss_gain(ipts,ivm) / total_losses * &
+                     wstress_season(ipts,ivm)
+
+             ENDIF
+             
+          ENDIF ! IF (loss_gain(ivm,ipts) < -min_stomate)
+
+       ENDDO ! Loop over # PFT's
+
+       !! 5.2 Land cover gains within a pixel
+       !  The consequtive loops over nvm cannot be merged because we first
+       !  need to deposit all the available pools on the bank before we
+       !  can withdraw the deposits to initialize new PFTs with the weighted
+       !  mean of the deposits
+
+       !! 5.2.1 There is no land cover change or there is a loss      
+       DO ivm = 1,nvm
+
+          IF ( loss_gain(ipts,ivm) .LE. -min_stomate ) THEN
+             
+             !  There is no land cover change or there is a loss. In case there 
+             !  is no land cover change nothing should be done. The case in which 
+             !  there is a loss is already dealt with above - see comment below Â§5.2 
+             !  to read why the case of a loss is not integrated in this IF-statement
+
+             !  Update the orphan flux
+             IF (veget_max(ipts,ivm) + loss_gain(ipts,ivm) .GE. min_vegfrac) THEN
+                
+                ! The PFT was not entirely removed
+                orphan_flux_local(ipts,ivm,ivegnew,icarbon) = veget_max(ipts,ivm) + &
+                     loss_gain(ipts,ivm)
+                WRITE(numout,*) 'Giving an orphan flux here 3: ',ivm,ipts
+
+             ELSE
+                
+                ! The PFT was entirely removed. This is exactely the case for
+                ! which the orphan_flux was introduced. Do not manipulate it.
+                orphan_flux_local(ipts,ivm,ivegnew,icarbon) = veget_max(ipts,ivm)
+                WRITE(numout,*) 'Giving an orphan flux here 4: ',ivm,ipts
+
+             ENDIF
+
+             !---TEMP---
+             IF (ld_lcc .AND. test_grid == ipts) THEN
+                WRITE(numout,*) 'check biomass sync for losses ', ivm
+                WRITE(numout,*) 'biomass, ', SUM(biomass(ipts,ivm,:,icarbon))
+                WRITE(numout,*) 'circ_class_biomass, ',SUM(SUM(circ_class_biomass(ipts,ivm,:,:,icarbon),2)*&
+                     circ_class_n(ipts,ivm,:))
+             ENDIF
+             !---------
+ 
+          ! Increase in the extent of a PFT
+          ELSEIF ( loss_gain(ipts,ivm) .GE. min_stomate ) THEN
+
+             !! 5.2.1 Check wether this is the youngest age class
+             !  If the redistribution of the LCC map in age classes is correctly 
+             !  implemented a new age class should always be established in the 
+             !  youngest age class which should be the first of the group. This 
+             !  implies that in this case ::ivm is the first of the group and 
+             !  ivm + nagec - 1 is the last age class of the group
+             IF (is_tree(ivm)) THEN
+
+                igroup = INT(Agec_group(ivm))
+                nagec_temp = nagec_pft(igroup)
+
+                IF (agec_group(ivm+nagec_temp-1) .NE. igroup) THEN
+
+                   ! ::ivm and ivm+nagec-1 are in a different ::igroup 
+                   ! apparently ::ivm is not the youngest age class
+                   WRITE(numout,*) 'Error: problem with the redistribution of the LCC maps'
+                   WRITE(numout,*) 'ipts, ivm, nagec_temp:  ',ipts, ivm
+                   WRITE(numout,*) 'nagec_temp, igroup:  ',nagec_temp,igroup
+                   WRITE(numout,*) 'agec_group(ivm), agec_group(ivm+nagec_temp-1):  ',&
+                        agec_group(ivm), agec_group(ivm+nagec_temp-1)
+                   CALL ipslerr_p (3,'land_cover_main', 'Cannot find proper age classes! (see output file)','','')
+                ENDIF
+
+
+             ENDIF
+
+             !! 5.2.2 The new PFT does not exist yet
+             IF (veget_max(ipts,ivm) .LT. min_stomate) THEN
+
+                !! 5.2.2.1 Initialize new and dummy variables
+                new_biomass(:,:,:,:) = zero
+                new_circ_class_biomass(:,:,:,:,:) = zero
+                new_ind(:,:) = zero
+                new_circ_class_n(:,:,:) = zero
+                new_lm_lastyearmax(:,:) = zero
+                new_age(:,:) = zero
+                new_leaf_frac(:,:,:) = zero
+                new_co2_to_bm(:,:) = zero
+                new_everywhere(:,:) = zero 
+                dum_when_growthinit(:,:) = large_value
+                dum_npp_longterm(:,:) = zero
+                dum_PFTpresent(:,:) = .TRUE.
+                dum_senescence(:,:) = .FALSE.
+               
+                !! 5.2.2.2 Assign value to moiavail_growingseason
+                !  Remember to add the moisture from PFT1 that will be present 
+                !  if PFT1 is planted with PFT ivm. Note ::loss_gain is here for
+                !  PFT1 but ::vir_moiavail_growingseason is for PFT ivm.
+!!$                moiavail_growingseason(ipts,ivm) = moi_bank + &
+!!$                     vir_moiavail_growingseason(ipts,ivm) * &
+!!$                     loss_gain(ipts,1) / total_losses
+                ! k_latosa_adapt is adjusted every day. wstress is no longer
+                ! used in prescribe
+!!$                wstress_season(ipts,ivm) = moi_bank + &
+!!$                     vir_wstress_fac(ipts,ivm) * &
+!!$                     loss_gain(ipts,1) / total_losses 
+
+                !! 5.2.2.3 Prescribe values for newly established PFTs
+                ! Initialize density of individuals, biomass, allocation factors,
+                ! leaf age distribution, ... to some reasonable value
+                ! ::veget_max is not updated yet, therefore loss_gain is passed in 
+                ! the argument list. As ::veget_max is used in the IF-THEN-statements
+                ! we won't update it until the end of this routine. If we would
+                ! update before that, the same PFT may be subject to conflicting actions
+                ! i.e. prescribe a new PFT and then merge it with the other age-classes
+                ! in the PFT-group.
+                CALL prescribe_prognostic (npts, loss_gain, veget, dt_days, dum_PFTpresent, &
+                     new_everywhere, dum_when_growthinit, new_biomass, new_leaf_frac, &
+                     new_ind, new_circ_class_n, new_circ_class_biomass, new_co2_to_bm, &
+                     forest_managed, KF, &
+                     dum_senescence, new_age, dum_npp_longterm, new_lm_lastyearmax, &
+                     tau_eff_leaf, tau_eff_sap, tau_eff_root, k_latosa_adapt)
+
+                ! Prescribe the new values
+                biomass(ipts,ivm,:,:) = new_biomass(ipts,ivm,:,:)
+                ind(ipts,ivm) = new_ind(ipts,ivm)
+                circ_class_biomass(ipts,ivm,:,:,:) = new_circ_class_biomass(ipts,ivm,:,:,:)
+                circ_class_n(ipts,ivm,:) = new_circ_class_n(ipts,ivm,:)
+                lm_lastyearmax(ipts,ivm) = new_lm_lastyearmax(ipts,ivm)
+                age(ipts,ivm) = new_age(ipts,ivm)
+                leaf_frac(ipts,ivm,:) = new_leaf_frac(ipts,ivm,:)
+                co2_to_bm(ipts,ivm) = new_co2_to_bm(ipts,ivm)
+                everywhere(ipts,ivm) = new_everywhere(ipts,ivm)
+                PFTpresent(ipts,ivm) = .TRUE.
+
+                ! Update the orphan flux
+                orphan_flux_local(ipts,ivm,ivegnew,icarbon) = &
+                     veget_max(ipts,ivm) + loss_gain(ipts,ivm)
+                orphan_flux_local(ipts,ivm,ico2bm,icarbon) = co2_to_bm(ipts,ivm)
+                WRITE(numout,*) 'Giving an orphan flux here 2: ',ivm,ipts
+
+                ! Update a couple forestry parameters.  I initialize these to
+                ! one instead of zero since forestry is called after this
+                ! routine, and it looks at last_cut.  This is not a real
+                ! problem since the trees we prescribe generally are the height of
+                ! saplings and not seeds.
+                age_stand(ipts,ivm)=1
+                last_cut(ipts,ivm)=1
+
+                ! Initialize the soil and litter carbon pools. When PFTs were removed
+                ! their soil and litter carbon was deposited on the bank. It is assumed
+                ! that the newly established PFT are established uniformly on all the
+                ! removed PFTs. Hence there is no preferential LCC sequence. For example
+                ! we deforest a needle and broadleaved PFT and replace it by a crop and
+                ! a grassland the crop and grassland are both established on the former
+                ! needle and broadleaved PFT rather than the crop being entirely on the 
+                ! former needleleaved PFT and grassland on the former broadleaved PFT.
+                ! Further, the LCC-maps should guarantee that the losses equal the gains
+                ! which ensures mass preservation. For these reasons we can simply use the
+                ! mean soil and litter carbon on the bank (gC m-2) to initialize the soil
+                ! and litter crabon of the newly established PFT's. 
+                litter(ipts,:,ivm,:,:) = litter_bank(:,:,:)
+                carbon(ipts,:,ivm) =  soil_bank(:)
+                lignin_struc(ipts,ivm,:) = struct_ltr_bank(:)
+                lignin_wood(ipts,ivm,:) = woody_ltr_bank(:)
+                bm_to_litter(ipts,ivm,:,:) = fresh_ltr_bank(:,:) 
+
+             !! 5.2.3 The new PFT does already exist 
+             ELSEIF (veget_max(ipts,ivm) .GE. min_stomate) THEN
+                     
+                !  We want to make use of prescribe_prognostic but it should be noted
+                !  that this PFT already contains biomass. Therefore we will create a
+                !  temporary PFT without biomass which can be used to establish the
+                !  new vegetation within this PFT. For most of the INTENT(inout)
+                !  variables of prescribe_prognostic we receive temporary variables 
+                !  back this helps us to calculate the weighted mean of the newly 
+                !  established vegetation and the vegetation that is already there.
+                !  For some other variables we receive dummies as we are simply not
+                !  going to use these values but will continue using the values of the
+                !  vegetation that is already there.
+
+                !! 5.2.3.1 Initialize new and dummy variables
+                new_biomass(:,:,:,:) = zero
+                new_circ_class_biomass(:,:,:,:,:) = zero
+                new_ind(:,:) = zero
+                new_circ_class_n(:,:,:) = zero
+                new_lm_lastyearmax(:,:) = zero
+                new_age(:,:) = zero
+                new_leaf_frac(:,:,:) = zero
+                new_co2_to_bm(:,:) = zero
+                new_everywhere(:,:) = zero 
+                dum_when_growthinit(:,:) = large_value
+                dum_npp_longterm(:,:) = zero
+                dum_PFTpresent(:,:) = .TRUE.
+                dum_senescence(:,:) = .FALSE.
+                
+                !! 5.2.3.2 Merge the new and already available vegetation
+                !  Veget_max after PFT expansion. As ::veget_max is used in the 
+                !  IF-statements we won't update it until the end of this routine. If 
+                !  we would updatebefore that, the same PFT may be subject to 
+                !  conflicting actions.
+                share_expanded = veget_max(ipts,ivm) / &
+                     ( veget_max(ipts,ivm) + loss_gain(ipts,ivm) )
+
+                ! We also need a scaling factor which includes the litter.  This is for growing
+                ! a new PFT on the soil mixture left from all the land we cleared.
+                DO ilev=1,nlevs
+                   DO ilit=1,nlitt
+                      IF(litter(ipts,ilit,ivm,ilev,icarbon) .GE. min_stomate)THEN
+                         litter_weight_expanded(ilit,ilev) = litter(ipts,ilit,ivm,ilev,icarbon) * &
+                              veget_max(ipts,ivm)/ &
+                              (litter(ipts,ilit,ivm,ilev,icarbon) * veget_max(ipts,ivm) + &
+                              litter_bank(ilit,ilev,icarbon) * loss_gain(ipts,ivm))
+                      ELSE
+                         litter_weight_expanded(ilit,ilev)=zero
+                      ENDIF
+                   END DO
+                ENDDO
+
+                ! Remember to add the moisture from PFT1 that will be present 
+                ! if PFT1 is planted with PFT ivm. Note ::loss_gain is here for
+                ! PFT1 but ::vir_wstress_fac is for PFT ivm.
+                wstress_season(ipts,ivm) = wstress_season(ipts,ivm) * &
+                     share_expanded + (moi_bank + vir_wstress_fac(ipts,ivm) * &
+                     loss_gain(ipts,1) / total_losses ) * (un - share_expanded)
+                wstress_month(ipts,ivm) = wstress_month(ipts,ivm) * &
+                     share_expanded + (moi_bank + vir_wstress_fac(ipts,ivm) * &
+                     loss_gain(ipts,1) / total_losses ) * (un - share_expanded)
+
+                !! 5.2.3.3 Initialize the newly established vegetation: 
+                !  Initialize the newly established vegetation: density of 
+                !  individuals, biomass, allocation factors, leaf age distribution, 
+                !  etc to some reasonable value ::veget_max is not updated yet, 
+                !  therefore loss_gain is passed in the argument list.
+                CALL prescribe_prognostic (npts, loss_gain, veget, dt_days, dum_PFTpresent, &
+                     new_everywhere, dum_when_growthinit, new_biomass, new_leaf_frac, &
+                     new_ind, new_circ_class_n, new_circ_class_biomass, new_co2_to_bm, &
+                     forest_managed, KF, &
+                     dum_senescence, new_age, dum_npp_longterm, new_lm_lastyearmax, &
+                     tau_eff_leaf, tau_eff_sap, tau_eff_root, k_latosa_adapt)
+
+                !! 5.2.3.3.1 Merge biomass of new and already available trees
+                IF (is_tree(ivm)) THEN
+
+                   ! Copy the number of individuals and the biomass of the established 
+                   ! vegetation to a temporary variable. In the subroutine ::circ_class_n
+                   ! and ::circ_class_biomass will be overwritten with the characteristics
+                   ! of the merged vegetation
+                   est_circ_class_n(:) = circ_class_n(ipts,ivm,:)
+                   est_circ_class_biomass(:,:,:) = circ_class_biomass(ipts,ivm,:,:,:)
+                   tmp_circ_class_n(:) = new_circ_class_n(ipts,ivm,:)
+                   tmp_circ_class_biomass(:,:,:) = new_circ_class_biomass(ipts,ivm,:,:,:)
+
+                   ! Store circumference (m) in a temporary variable that can be 
+                   ! sorted from small to large - note that the dimension of these
+                   ! variables are 2*ncirc
+                   est_circ_class_dia(:) = wood_to_dia(est_circ_class_biomass(:,:,icarbon),ivm)
+                   tmp_circ_class_dia(:) = wood_to_dia(tmp_circ_class_biomass(:,:,icarbon),ivm)
+
+                   ! Merge the biomass        
+!!$                   CALL merge_biomass_pfts(npts, share_expanded, moiavail_growingseason, circ_class_n, &
+                   CALL merge_biomass_pfts(npts, share_expanded, circ_class_n, &
+                        est_circ_class_n, tmp_circ_class_n, circ_class_biomass, est_circ_class_biomass, &
+                        tmp_circ_class_biomass, ind, biomass, circ_class_dist, &
+                        ipts, ivm, est_circ_class_dia, tmp_circ_class_dia)
+
+                        
+                !! 5.2.3.3.2 Merge biomass of new and already available grass or cropland
+                ELSE
+                                  
+                   ! Dilute the existing biomass pools and number of individuals
+                   biomass(ipts,ivm,:,:) = share_expanded * biomass(ipts,ivm,:,:) + &
+                        (un - share_expanded) * new_biomass(ipts,ivm,:,:)
+                   ind(ipts,ivm) = share_expanded * ind(ipts,ivm) + &
+                        (un - share_expanded) * new_ind(ipts,ivm)
+                   
+                   ! Keep ::biomass and circ_class_biomass synchronized
+                   IF (ind(ipts,ivm) .GE. min_stomate) THEN
+
+                      circ_class_biomass(ipts,ivm,1,:,:) = biomass(ipts,ivm,:,:)/ind(ipts,ivm)
+                      circ_class_n(ipts,ivm,1) = ind(ipts,ivm)
+
+                   ELSE
+
+                      circ_class_biomass(ipts,ivm,1,:,:) = zero
+                      circ_class_n(ipts,ivm,1) = zero
+
+                   ENDIF                       
+
+                ENDIF
+               
+                !! 5.2.3.4 Calculate the PFT characteristics of the merged PFT
+                !  Take the weighted mean of the existing vegetation and the new 
+                !  vegetation in this PFT. Note that co2_to_bm is in gC. m-2 dt-1 
+                !  so we should also take the weighted mean (rather than sum if
+                !  this where absolute values).
+                lm_lastyearmax(ipts,ivm) = share_expanded * lm_lastyearmax(ipts,ivm) + &
+                     (un - share_expanded) * new_lm_lastyearmax(ipts,ivm)
+                age(ipts,ivm) = share_expanded * age(ipts,ivm) + &
+                     (un - share_expanded) * new_age(ipts,ivm)
+                leaf_frac(ipts,ivm,:) = share_expanded * leaf_frac(ipts,ivm,:) + &
+                     (un - share_expanded) * new_leaf_frac(ipts,ivm,:)
+                co2_to_bm(ipts,ivm) = share_expanded * co2_to_bm(ipts,ivm) + &
+                     (un - share_expanded) * new_co2_to_bm(ipts,ivm)
+
+                ! Update the orphan flux
+                orphan_flux_local(ipts,ivm,ivegnew,icarbon) = &
+                     veget_max(ipts,ivm) + loss_gain(ipts,ivm)
+                orphan_flux_local(ipts,ivm,ico2bm,icarbon) = co2_to_bm(ipts,ivm)
+                WRITE(numout,*) 'Giving an orphan flux here 1: ',ivm,ipts
+
+                ! Everywhere deals with the migration of vegetation. Copy the
+                ! status of the most migrated vegetation for the whole PFT
+                everywhere(ipts,ivm) = MAX(everywhere(ipts,ivm), new_everywhere(ipts,ivm))
+
+                ! The new soil&litter pools are the weighted mean of the newly 
+                ! established vegetation for that PFT (as deposited on the bank) 
+                ! and the vegetation that already exists in that PFT.
+                ! NOTE that in case veget_max of PFT1 (bare soil) is increasing
+                ! we will also move litter to the bare soil. stomate_litter.f90
+                ! was adjusted such that decomposition also happens in PFT
+                litter(ipts,:,ivm,:,:) = share_expanded * litter(ipts,:,ivm,:,:) + &
+                        (un - share_expanded) * litter_bank(:,:,:)
+                carbon(ipts,:,ivm) =  share_expanded * carbon(ipts,:,ivm) + &
+                     (un - share_expanded) * soil_bank(:)
+                lignin_struc(ipts,ivm,:) = litter_weight_expanded(istructural,:) * lignin_struc(ipts,ivm,:) + &
+                     (un - litter_weight_expanded(istructural,:)) * struct_ltr_bank(:)
+                lignin_wood(ipts,ivm,:) = litter_weight_expanded(iwoody,:) * lignin_wood(ipts,ivm,:) + &
+                     (un - litter_weight_expanded(iwoody,:)) * woody_ltr_bank(:)
+                bm_to_litter(ipts,ivm,:,:) = share_expanded * bm_to_litter(ipts,ivm,:,:) + & 
+                     (un - share_expanded) * fresh_ltr_bank(:,:)
+
+                ! These next two variables are integers, so we use CEILING to make sure
+                ! they stay integers.  FLOOR or INT would also be fine.  The use of
+                ! CEILING is arbitrary.
+                age_stand(ipts,ivm)  = CEILING(share_expanded * age_stand(ipts,ivm) + &
+                     (un - share_expanded) * 1)
+                last_cut(ipts,ivm)  = CEILING(share_expanded * last_cut(ipts,ivm) + &
+                     (un - share_expanded) * 1)
+
+             ELSE
+
+                WRITE(numout,*) 'Error 1: logic of the IF-statements in land_cover_change'
+   
+             ENDIF ! New PFT
+
+          ELSEIF(ABS(loss_gain(ipts,ivm)) .LE. 1e-15)THEN
+             ! Do nothing.  This is okay, as far as I can tell.
+             ! This seems to be the double precision limit.
+
+          ELSE
+
+             WRITE(numout,*) 'Error 2: logic of the IF-statements in land_cover_change'
+             WRITE(numout,*) 'ipts, ivm: ',ipts,ivm
+             WRITE(numout,*) 'loss_gain: ',loss_gain(ipts,ivm)
+
+          ENDIF ! Land cover change?
+
+       ENDDO  ! Loop over # PFT's
+
+    ENDDO ! Loop over npts
+    
+
+ !! 6. Calculate new veget_max values and update variables if PFT was removed 
+    
+    !  Calculate new veget_max    
+    veget_max(:,:) = veget_max(:,:) + loss_gain(:,:)
+
+    !  Update the variables if veget_max is below threshold
+    DO ipts = 1,npts
+       
+       DO ivm = 1,nvm
+          IF (veget_max(ipts,ivm) .LT. min_vegfrac) THEN
+
+             veget_max(ipts,ivm) = zero
+             lm_lastyearmax(ipts,ivm) = zero
+             age(ipts,ivm) = zero
+             leaf_frac(ipts,ivm,:) = zero
+             co2_to_bm(ipts,ivm) = zero
+             everywhere(ipts,ivm) = zero
+             litter(ipts,:,ivm,:,:) = zero
+             carbon(ipts,:,ivm) = zero
+             lignin_struc(ipts,ivm,:) = zero
+             lignin_wood(ipts,ivm,:) = zero
+             bm_to_litter(ipts,ivm,:,:) = zero
+             biomass(ipts,ivm,:,:) = zero
+             ind(ipts,ivm) = zero
+             PFTpresent(ipts,ivm) = .FALSE.
+             ! Keep ::biomass and circ_class_biomass synchronized
+             circ_class_biomass(ipts,ivm,:,:,:) = zero
+             circ_class_n(ipts,ivm,:) = zero
+
+             age_stand(ipts,ivm)=1
+             last_cut(ipts,ivm)=1
+
+          ENDIF
+
+       ENDDO
+
+    ENDDO
+
+    IF (ld_lcc) THEN
+       WRITE(numout,*) 'Final values before mass balance'
+       CALL print_lcc_error_message(npts,test_grid,veget_max_new_adj,veget_max,veget_max_new_group,&
+            veget_max_group,delta_veget,loss_gain,4)
+    ENDIF
+
+!! 6. Mass balance closure
+    
+    !! 6.1 Calculate components of the mass balance
+    pool_end(:,:,:) = zero
+    DO iele = 1,nelements
+
+       IF(test_grid > 0)THEN
+          IF(test_pft < nvm)THEN
+             WRITE(numout,'(A,10ES20.10)') 'Final pool 2 ',pool_start(test_grid,test_pft,iele)
+          ENDIF
+       ENDIF
+
+       ! Biomass pool + bm_to_litter
+       DO ipar = 1,nparts
+          pool_end(:,:,iele) = pool_end(:,:,iele) + &
+               (biomass(:,:,ipar,iele) + bm_to_litter(:,:,ipar,iele)) * &
+               veget_max(:,:)
+          IF(test_grid > 0)THEN
+             IF(test_pft < nvm)THEN
+                WRITE(numout,'(A,I5,10ES20.10)') 'Final biomass ',ipar,biomass(test_grid,test_pft,ipar,iele) , &
+                     bm_to_litter(test_grid,test_pft,ipar,iele), &
+                     veget_max(test_grid,test_pft)
+             ENDIF
+          ENDIF
+       ENDDO
+
+       IF(test_grid > 0)THEN
+          IF(test_pft < nvm)THEN
+             WRITE(numout,'(A,10ES20.10)') 'Final pool 3 ',pool_end(test_grid,test_pft,iele)
+          ENDIF
+       ENDIF
+
+       ! Litter pool (gC m-2) *  (m2 m-2) 
+       DO ilit = 1,nlitt
+          DO ilev = 1,nlevs
+             pool_end(:,:,iele) = pool_end(:,:,iele) + &
+                  litter(:,ilit,:,ilev,iele) * veget_max(:,:)
+          ENDDO
+       ENDDO
+
+       IF(test_grid > 0)THEN
+          IF(test_pft < nvm)THEN
+             WRITE(numout,'(A,10ES20.10)') 'Final pool 4 ',pool_end(test_grid,test_pft,iele)
+          ENDIF
+       ENDIF
+
+       ! Soil carbon (gC m-2) *  (m2 m-2)
+       DO icarb = 1,ncarb
+          pool_end(:,:,iele) = pool_end(:,:,iele) + &
+               carbon(:,icarb,:) * veget_max(:,:)
+       ENDDO      
+
+       IF(test_grid > 0)THEN
+          IF(test_pft < nvm)THEN
+             WRITE(numout,'(A,10ES20.10)') 'Final pool 5 ',pool_end(test_grid,test_pft,iele)
+          ENDIF
+       ENDIF
+
+    ENDDO
+
+    ! The biomass harvest pool is expressed in gC pixel-1 So, it 
+    ! shouldn't be multiplied by veget_max but it should be divided
+    ! by pixel_area to obtain gC m-2. The difference between 
+    ! pool_start and pool_end was accumulated over dt, therefore, 
+    ! the units of ipoolchange are gC m-2 dt-1.
+    DO ivm = 1,nvm
+       pool_end(:,ivm,icarbon) = pool_end(:,ivm,icarbon) + &
+            SUM(harvest_pool(:,ivm,:,icarbon),2) / &
+            pixel_area(:)
+    ENDDO
+
+    !! 6.2 Calculate mass balance
+    check_intern(:,:,iatm2land,icarbon) = orphan_flux_local(:,:,ico2bm,icarbon) * orphan_flux_local(:,:,ivegnew,icarbon)
+    check_intern(:,:,iland2atm,icarbon) = -un * zero
+    check_intern(:,:,ilat2out,icarbon) = zero
+    check_intern(:,:,ilat2in,icarbon) = -un * zero
+    check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - pool_start(:,:,icarbon))
+    closure_intern = zero
+    DO imbc = 1,nmbcomp
+       closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + check_intern(:,:,imbc,icarbon)
+    ENDDO
+    mb_lcc_error(:)=SUM(closure_intern(:,:,icarbon),2)
+
+    !! 6.3 Write outcome of the check
+    !  Sum over ivm because of LCC
+    DO ipts=1,npts
+       IF(ABS(SUM(closure_intern(ipts,:,icarbon))) .LE. min_stomate)THEN
+          IF (ld_massbal) WRITE(numout,*) 'Mass balance closure in land_cover_main'
+       ELSE
+          WRITE(numout,*) 'Error: mass balance is not closed in land_cover_main',&
+               ABS(SUM(closure_intern(ipts,:,icarbon)))
+          DO ivm=1,nvm
+             WRITE(numout,*) '   ipts,ivm; ', ipts,ivm
+             WRITE(numout,*) '   Difference is, ', closure_intern(ipts,ivm,icarbon)
+             WRITE(numout,*) '   pool_end,pool_start: ', pool_end(ipts,ivm,icarbon), &
+                  pool_start(ipts,ivm,icarbon)
+             WRITE(numout,*) '   orphan_fluxes: ', orphan_flux_local(ipts,ivm,ico2bm,icarbon),&
+                  orphan_flux_local(ipts,ivm,ivegnew,icarbon)
+             WRITE(numout,*) '   veget_max: ', veget_max(ipts,ivm)
+             
+          ENDDO
+          IF(ld_stop)THEN
+             CALL ipslerr_p (3,'land_cover_main', 'Mass balance error.','','')
+          ENDIF
+       ENDIF
+    ENDDO
+
+    ! Here we recombine the orphan fluxes calculated in this subroutine with
+    ! the values which exist outside this subroutine.
+    orphan_flux(:,:,:,:)=orphan_flux(:,:,:,:)+orphan_flux_local(:,:,:,:)
+
+
+    !+++++++++++++++++++++++++ TEMP ++++++++++++++++++
+    !+++++++ TEMP +++++
+    ! Check to see if the nobio fraction has changed
+    DO ipts=1,npts
+       frac_nobio_end(ipts,1)=un-SUM(veget_max(ipts,:))
+       IF(abs(frac_nobio_start(ipts,1) - frac_nobio_end(ipts,1)) .GT. min_stomate)THEN
+          WRITE(numout,*) 'ERROR: nobio fraction changed during LCC!'
+          WRITE(numout,*) 'ipts, frac_nobio_start(ipts,1): ',ipts, frac_nobio_start(ipts,1)
+          WRITE(numout,*) 'ipts, frac_nobio_end(ipts,1): ',ipts, frac_nobio_end(ipts,1)
+          IF(.NOT. lignore_lcc_stops) STOP
+       ENDIF
+    ENDDO
+    !+++++++++++++++++++
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving land_cover_change_main'
+
+  END SUBROUTINE land_cover_change_main
+
+
+! ================================================================================================================================
+!! SUBROUTINE   : age_class_distr
+!!
+!>\BRIEF        Redistribute biomass, litter, soilcarbon and water across
+!!              the age classes
+!!
+!! DESCRIPTION  : Following growth, the trees from an age class may have become
+!! too big to belong to this age class. The biomass, litter, soilcarbon and
+!! soil water then need to be moved from one age class to the next age class.
+!!
+!! RECENT CHANGE(S) : 
+!!
+!! MAIN OUTPUT VARIABLE(S) :  
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : 
+!! \n
+!_ ================================================================================================================================
+
+  
+  SUBROUTINE age_class_distr(npts, circ_class_n, biomass, circ_class_biomass, &
+       veget_max, ind, circ_class_dist, wstress_season, &
+       lm_lastyearmax, age, leaf_frac, co2_to_bm, &
+       everywhere, litter, carbon, lignin_struc, &
+       lignin_wood, bm_to_litter, PFTpresent, when_growthinit,&
+       forest_managed, KF, senescence, &
+       npp_longterm, gpp_daily, leaf_age, lab_fac, &
+       gdd_from_growthinit, gdd_midwinter, time_hum_min, gdd_m5_dormance, &
+       ncd_dormance, moiavail_month, moiavail_week, ngd_minus5, &
+       gpp_week, resp_maint, resp_growth, npp_daily, &
+       use_reserve, t_photo_stress, rue_longterm, mai, pai, &
+       mai_count, previous_wood_volume, moiavail_growingseason, &
+       MatrixA, MatrixV, VectorB, VectorU, age_stand, last_cut, &
+       k_latosa_adapt)
+
+    IMPLICIT NONE
+    
+  !! 0. Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+
+    INTEGER, INTENT(in)                                :: npts                !! Domain size - number of pixels (unitless)
+    REAL(r_std), DIMENSION(:), INTENT(in)              :: circ_class_dist     !! The probability distribution of trees in a circ
+ 
+                                                                              !! class in case of a redistribution (unitless). 
+    !! 0.2 Output variables
+
+
+    !! 0.3 Modified variables
+
+    LOGICAL, DIMENSION(:,:), INTENT(inout)             :: PFTpresent          !! Tab indicating which PFTs are present in 
+                                                                              !! each pixel
+    LOGICAL, DIMENSION(:,:), INTENT(inout)             :: senescence          !! Flag for setting senescence stage (only 
+                                                                              !! for deciduous trees)
+    INTEGER(i_std), DIMENSION (:,:), INTENT(inout)     :: forest_managed      !! forest management flag (is the forest 
+                                                                              !! being managed?)
+     REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: moiavail_month      !! "Monthly" moisture availability (0 to 1, 
+                                                                              !! unitless) 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: moiavail_week       !! "Weekly" moisture availability 
+                                                                              !! (0 to 1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: gpp_week            !! Mean weekly gross primary productivity 
+                                                                              !! @tex $(gC m^{-2} day^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: ngd_minus5          !! Number of growing days (days), threshold 
+                                                                              !! -5 deg C (for phenology)   
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: resp_maint          !! Maintenance respiration  
+                                                                              !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: resp_growth         !! Growth respiration  
+                                                                              !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: npp_daily           !! Net primary productivity 
+                                                                              !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: use_reserve         !! Mass taken from carbohydrate reserve 
+                                                                              !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: t_photo_stress      !! Temperature stress for CEXCHANGE 
+                                                                              !! photosynthesis (0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: rue_longterm        !! Longterm radiation use efficiency 
+                                                                              !! (??units??) 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: when_growthinit     !! How many days ago was the beginning of 
+                                                                              !! the growing season (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: lab_fac             !! Activity of labile pool factor (??units??)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: KF                  !! Scaling factor to convert sapwood mass
+                                                                              !! into leaf mass (m)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: k_latosa_adapt      !! Leaf to sapwood area adapted for long 
+                                                                              !! term water stress (m)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: npp_longterm        !! "Long term" mean yearly primary productivity 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: ind                 !! Number of individuals at the stand level
+                                                                              !! @tex $(m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: veget_max           !! "maximal" coverage fraction of a PFT on the ground
+                                                                              !! May sum to
+                                                                              !! less than unity if the pixel has
+                                                                              !! nobio area. (unitless, 0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: wstress_season      !! Water stress factor, based on hum_rel_daily
+                                                                              !! (unitless, 0-1)   
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: lm_lastyearmax      !! last year's maximum leaf mass for each PFT 
+                                                                              !! @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: everywhere          !! is the PFT everywhere in the grid box or 
+                                                                              !! very localized (after its introduction) (?)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: age                 !! mean age (years)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: co2_to_bm           !! CO2 taken from the atmosphere to get C to create  
+                                                                              !! the seedlings @tex (gC.m^{-2}dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: gpp_daily           !! Daily gross primary productivity  
+                                                                              !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: time_hum_min        !! Time elapsed since strongest moisture 
+                                                                              !! availability (days) 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: gdd_midwinter       !! Growing degree days (K), since midwinter 
+                                                                              !! (for phenology) - this is written to the
+                                                                              !!  history files 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: gdd_from_growthinit !! growing degree days, since growthinit 
+                                                                              !! for crops
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: gdd_m5_dormance     !! Growing degree days (K), threshold -5 deg 
+                                                                              !! C (for phenology)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: ncd_dormance        !! Number of chilling days (days), since 
+                                                                              !! leaves were lost (for phenology) 
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)       :: circ_class_n        !! Number of individuals in each circ class
+                                                                              !! @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)       :: lignin_struc        !! ratio Lignine/Carbon in structural litter,
+                                                                              !! above and below ground
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)       :: lignin_wood         !! ratio Lignine/Carbon in woody litter,
+                                                                              !! above and below ground
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)       :: carbon              !! carbon pool: active, slow, or passive 
+                                                                              !! @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)       :: leaf_frac           !! fraction of leaves in leaf age class (unitless;0-1)
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)       :: leaf_age            !! Leaf age (days)
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)     :: bm_to_litter        !! Transfer of biomass to litter 
+                                                                              !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)     :: biomass             !! Stand level biomass @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout)   :: circ_class_biomass  !! Biomass components of the model tree within a 
+                                                                              !! circumference class
+                                                                              !! class @tex $(g C ind^{-1})$ @endtex  
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout)   :: litter              !! metabolic and structural litter, above and 
+                                                                              !! below ground @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)    :: mai                 !! The mean annual increment
+                                                                              !! @tex $(m**3 / m**2 / year)$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)    :: pai                 !! The period annual increment
+                                                                              !! @tex $(m**3 / m**2 / year)$ @endtex          
+    INTEGER(i_std), DIMENSION(npts,nvm),INTENT(inout)  :: mai_count           !! The number of times we've
+                                                                              !! calculated the volume increment
+                                                                              !! for a stand 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)    :: previous_wood_volume!! The volume of the tree trunks
+                                                                              !! in a stand for the previous year.
+                                                                              !! @tex $(m**3 / m**2 )$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: moiavail_growingseason  !! Mean growingseason moisture 
+                                                                              !! availability (0 to 1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm,nbpools,nbpools), &
+                                         INTENT(inout) :: MatrixA             !! Matrix containing the fluxes between the
+                                                                              !! carbon pools per sechiba time step 
+                                                                              !! @tex $(gC.m^2.day^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nbpools), &
+                                         INTENT(inout) :: VectorB             !! Vector containing the litter increase per
+                                                                              !! sechiba time step
+                                                                              !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nbpools,nbpools), &
+                                         INTENT(inout) :: MatrixV             !!
+    REAL(r_std), DIMENSION(npts,nvm,nbpools), &
+                                         INTENT(inout) :: VectorU             !!
+    INTEGER(i_std), DIMENSION(npts,nvm), INTENT(inout) :: age_stand           !! Age of the forest stand (years)  
+    INTEGER(i_std), DIMENSION(npts,nvm), INTENT(inout) :: last_cut            !! Years since last thinning (years)
+
+    !! 0.4 Local variables
+
+    ! +++CHECK+++
+    ! Externalize
+     REAL(r_std), DIMENSION(nagec)                     :: age_class_bound     !! Boundaries of the age classes (m)
+    ! +++++++++++
+
+    INTEGER(i_std)                                     :: ipts,ivm,igroup     !! Indeces(unitless)
+    INTEGER(i_std)                                     :: iele,ipar,ipft      !! Indeces(unitless)
+    INTEGER(i_std)                                     :: iagec,imbc,icirc    !! Indeces(unitless)
+    INTEGER(i_std)                                     :: ilit,ilev,icarb     !! Indeces(unitless)
+    INTEGER(i_std)                                     :: ivma                !! Indeces(unitless)
+    REAL(r_std)                                        :: share_expanded      !! Share of the veget_max of the existing vegetation
+                                                                              !! within a PFT over the total veget_max following 
+                                                                              !! expansion of that PFT (unitless, 0-1)
+    REAL(r_std), DIMENSION(ncirc)                      :: circ_class_ba       !! basal area of the model tree in each
+                                                                              !! circ class @tex $(m^{2} m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm)                   :: qm_dia              !! Quadratic mean diameter of the stand (m)
+    REAL(r_std), DIMENSION(ncirc)                      :: est_circ_class_n    !! Temporary variable for circ_class_n of the 
+                                                                              !! established vegetation 
+                                                                              !! @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                      :: tmp_circ_class_n    !! Temporary variable for circ_class_n of the 
+                                                                              !! established vegetation 
+                                                                              !! @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(ncirc,nparts,nelements)     :: est_circ_class_biomass !! Temporary variable for circ_class_biomass 
+                                                                              !! of the established vegetation 
+                                                                              !! @tex $(g C ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc,nparts,nelements)     :: tmp_circ_class_biomass !! Temporary variable for circ_class_biomass 
+                                                                              !! of the established vegetation
+                                                                              !! @tex $(g C ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                      :: est_circ_class_dia  !! Variable to store temporary values for 
+                                                                              !! circ_class (m)
+    REAL(r_std), DIMENSION(ncirc)                      :: tmp_circ_class_dia  !! Variable to store temporary values for 
+                                                                              !! circ_class (m)
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements) :: check_intern        !! Contains the components of the internal
+                                                                              !! mass balance chech for this routine
+                                                                              !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)         :: closure_intern      !! Check closure of internal mass balance
+                                                                              !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)         :: pool_start          !! Start and end pool of this routine 
+                                                                              !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)         :: pool_end            !! Start and end pool of this routine 
+                                                                              !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(nelements)                  :: temp_start          !! Start and end pool of this routine 
+                                                                              !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(nelements)                  :: temp_end            !! Start and end pool of this routine 
+                                                                              !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(nlitt,nlevs)                :: litter_weight_expanded !! The fraction of litter on the expanded
+                                                                              !! PFT.
+                                                                              !! @tex $-$ @endtex
+!_ ================================================================================================================================
+  
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering age class distribution'
+
+
+ !! 1. Initialize
+
+    !! 1.1 Initialize variables
+    !+++CHECK++++
+    !Externalize
+    IF(nagec == 4)THEN
+       age_class_bound(1) = 0.07
+       age_class_bound(2) = 0.20
+       age_class_bound(3) = 0.40
+       age_class_bound(4) = 5.
+    ELSEIF(nagec == 1)THEN
+       age_class_bound(1) = 5.0
+    ELSE
+       WRITE(numout,*) 'You need to externalize age_class_bound, or come up with a case '
+       WRITE(numout,*) 'for this number of age classes.'
+       WRITE(numout,*) 'nagec = ',nagec
+       STOP
+    ENDIF
+    !++++++++++++
+
+    !! 1.2 Initialize check for mass balance closure
+    !  The mass balance is calculated at the end of this routine
+    !  in section 3. Initial biomass and harvest pool all other
+    !  relevant pools were just set to zero.
+    pool_start(:,:,:) = zero
+    DO iele = 1,nelements
+       
+       ! co2_to_bm
+       pool_start(:,:,iele) = pool_start(:,:,iele) + co2_to_bm(:,:)
+
+       ! Biomass pool + bm_to_litter
+       DO ipar = 1,nparts
+          pool_start(:,:,iele) = pool_start(:,:,iele) + &
+               (biomass(:,:,ipar,iele) + bm_to_litter(:,:,ipar,iele)) * &
+               veget_max(:,:)
+       ENDDO
+
+       ! Litter pool (gC m-2) *  (m2 m-2) 
+       DO ilit = 1,nlitt
+          DO ilev = 1,nlevs
+             pool_start(:,:,iele) = pool_start(:,:,iele) + &
+                  litter(:,ilit,:,ilev,iele) * veget_max(:,:)
+          ENDDO
+       ENDDO
+
+       ! Soil carbon (gC m-2) *  (m2 m-2)
+       DO icarb = 1,ncarb
+          pool_start(:,:,iele) = pool_start(:,:,iele) + &
+               carbon(:,icarb,:) * veget_max(:,:)
+       ENDDO
+
+    ENDDO
+
+
+ !! 2. Redistribute the biomass across the age classes
+
+    !  Following growth, the trees from an age class may have become too big to 
+    !  belong to this age class. The biomass, litter, soilcarbon and soil
+    !  water then need to be moved from one age class to the next age class.
+    DO ipts = 1,npts
+
+       ! The agec_group lets us know which PFTs belong in which age class groups.
+       !  I assume that the structure is linear, that is, if PFTs 16, 17, and 18 all
+       ! below to group 10, PFT 16 is the youngest, PFT 17 is the second-younest, and
+       ! PFT 18 is the oldest (largest diameter).  I also assume that all PFTs in 
+       ! an age class are grouped together in the input file.  In the example above,
+       ! this means that PFT 19 cannot be in group 10 unless PFT 18 is also in group 10.
+       
+
+       ! This loops over all the PFTs that we have ignoring age classes
+       DO ivma=1,nvmap
+
+          ivm=start_index(ivma)
+
+          ! If we only have a single age class for this
+          ! PFT, we can skip it.
+          IF(nagec_pft(ivma) .EQ. 1)CYCLE
+
+          ! Only forest PFTs have age classes
+          IF (is_tree(ivm)) THEN
+
+             !! 2.1 Check if the trees still belong to this age class
+             !  Note that the term age class is used but that the classes used in the
+             !  code are not defined on an age criterion. Instead a diameter criterion
+             !  is used. The reason to do so is that growth depends on the rule of
+             !  Deleuze and Dhote that in turn is based on basal area. More stable
+             !  model behaiour is therefore expected when the diameter range within an
+             !  age class is controled. Also different PFTs grow at a different speeds.
+             !  If age would have been used to define the classes, the diameter range
+             !  within the first age class would have been much larger in the 
+             !  tropics compared to the boreal zone. When Deleuze and Dhote is then
+             !  applied the model could start to behave differently in the tropics and
+             !  boreal zone. These differences in behaviour are thought to be better 
+             !  controled by implementing a diameter criterion.
+             !  As a reminder age classes (::nagec) control the diameter/height
+             !  variation across stands, ::ncirc controls the diameter/height variation
+             !  within a stand 
+             DO iagec = nagec_pft(ivma),1,-1
+
+                ipft = ivm+iagec-1
+
+                !! 2.1.1 Basal area at the tree level (m2 tree-1)
+                circ_class_ba(:) = &
+                     wood_to_ba(circ_class_biomass(ipts,ipft,:,:,icarbon),ipft)
+
+                ! Convert basal area in quadratic mean stand diameter (m)
+                IF (ind(ipts,ipft) .NE. zero) THEN
+
+                   qm_dia(ipts,ipft) = SQRT( 4/pi * SUM(circ_class_ba(:) * &
+                        circ_class_n(ipts,ipft,:)) / ind(ipts,ipft) )
+
+                ELSE
+
+                   qm_dia(ipts,ipft) = zero
+
+                ENDIF
+
+                !! 2.2.2 Check whether quadratic mean diameter exceeds boundaries 
+                !  Check whether quadratic mean diameter exceeds boundaries of
+                !  the age class.
+                IF(ld_agec)THEN
+                   WRITE(numout,*) 'Checking to merge for: '
+                   WRITE(numout,*) 'ipft,ivm,iagec,ipts: ',ipft,ivm,iagec,ipts
+                   WRITE(numout,*) 'nagec_pft,qm_dia,age_class_bound: ',nagec_pft(ivma),&
+                        qm_dia(ipts,ipft),age_class_bound(iagec)
+                ENDIF
+
+                IF ( (iagec .EQ. nagec_pft(ivma)) .AND. &
+                     qm_dia(ipts,ipft) .GT. age_class_bound(iagec) ) THEN
+                 
+                   ! If these conditions are satisfied our tree diameter is
+                   ! very unrealist
+                   WRITE(numout,*) 'WARNING: tree diameter exceeds (m): ', &
+                        age_class_bound(iagec) 
+  
+                ELSEIF ( (iagec .NE. nagec_pft(ivma)) .AND. &
+                     qm_dia(ipts,ipft) .GT. age_class_bound(iagec)) THEN
+
+                   IF(ld_agec)THEN
+                      WRITE(numout,*) 'Merging biomass'
+                      WRITE(numout,*) 'ipts,ipft,iagec: ',ipts,ipft,iagec
+                      WRITE(numout,*) 'age_class_bound(:): ',age_class_bound(:)
+                      WRITE(numout,*) 'qm_dia: ',qm_dia(ipts,ipft)
+
+                   ENDIF
+
+                   !! 2.2.3 Merge biomass
+                   !  Biomass of two age classes needs to be merged. The established
+                   !  vegetation is stored in ipft+1, the new vegetation is stored in
+                   !  ipft
+                   share_expanded = veget_max(ipts,ipft+1) / &
+                        ( veget_max(ipts,ipft+1) + veget_max(ipts,ipft) )
+                   ! We also need a scaling factor which includes the litter
+                   DO ilev=1,nlevs
+                      DO ilit=1,nlitt
+                         IF(litter(ipts,ilit,ipft,ilev,icarbon) .GE. min_stomate)THEN
+                            litter_weight_expanded(ilit,ilev)=litter(ipts,ilit,ipft+1,ilev,icarbon) * veget_max(ipts,ipft+1)/ &
+                                 (litter(ipts,ilit,ipft+1,ilev,icarbon) * veget_max(ipts,ipft+1) + &
+                                 litter(ipts,ilit,ipft,ilev,icarbon) * veget_max(ipts,ipft))
+                         ELSE
+                            litter_weight_expanded(ilit,ilev)=zero
+                         ENDIF
+                      END DO
+                   ENDDO
+                      
+                   ! Assign value to moiavail_growingseason, this value needs to be 
+                   ! copied because it is only calculated when there is leaf mass present 
+                   moiavail_growingseason(ipts,ipft+1) = moiavail_growingseason(ipts,ipft+1) * &
+                        share_expanded + moiavail_growingseason(ipts,ipft) * (un - share_expanded)
+                   ! I'm not sure if wstress_season needs to be here since it is recalculated from
+                   ! moiavail_growingseason every day.
+                   wstress_season(ipts,ipft+1) = wstress_season(ipts,ipft+1) * &
+                          share_expanded + wstress_season(ipts,ipft) * (un - share_expanded)
+
+                   ! Copy the number of individuals and the biomass of the established 
+                   ! vegetation to a temporary variable. In the subroutine ::circ_class_n
+                   ! and ::circ_class_biomass will be overwritten with the characteristics
+                   ! of the merged vegetation
+                   est_circ_class_n(:) = circ_class_n(ipts,ipft+1,:)
+                   est_circ_class_biomass(:,:,:) = circ_class_biomass(ipts,ipft+1,:,:,:)                 
+                   tmp_circ_class_n(:) = circ_class_n(ipts,ipft,:)
+                   tmp_circ_class_biomass(:,:,:) = circ_class_biomass(ipts,ipft,:,:,:)
+ 
+                   ! Store circumference (m) in a temporary variable that can be 
+                   ! sorted from small to large - note that the dimension of these
+                   ! variables are 2*ncirc
+                   est_circ_class_dia(:) = wood_to_dia(est_circ_class_biomass(:,:,icarbon),ipft+1)
+                   tmp_circ_class_dia(:) = wood_to_dia(tmp_circ_class_biomass(:,:,icarbon),ivm)
+
+                   ! Initiliaze mass balance of the merging procedure
+                   ! MB was calculated outside the subroutine merge_biomass_pfts
+                   ! because veget_max needs to be updated. Veget_max cannot be 
+                   ! updated in the subroutine because the way it is called from 
+                   ! the subroutine land_cover_change (where veget_max can only be
+                   ! updated at the end of the whole subroutine. Therefore, this
+                   ! check was included here.
+                   temp_start(:) = zero
+                   DO ipar = 1,nparts
+                      DO iele = 1,nelements
+                         DO icirc = 1,ncirc
+                            temp_start(iele) = temp_start(iele) + &
+                                 SUM(circ_class_biomass(ipts,:,icirc,ipar,iele) * &
+                                 circ_class_n(ipts,:,icirc) * veget_max(ipts,:))
+                         ENDDO
+                      ENDDO
+                   ENDDO
+
+                   ! Merge the biomass of the two age classes
+                   CALL merge_biomass_pfts(npts, share_expanded, circ_class_n, &
+                        est_circ_class_n, tmp_circ_class_n, circ_class_biomass, est_circ_class_biomass, &
+                        tmp_circ_class_biomass, ind, biomass, circ_class_dist, ipts, &
+                        ipft+1, est_circ_class_dia, tmp_circ_class_dia)
+
+                   !! 2.2.4 Empty the age class that was merged and update veget_max
+                   circ_class_n(ipts,ipft,:) = zero
+                   ind(ipts,ipft) = zero
+                   circ_class_biomass(ipts,ipft,:,:,:) = zero
+                   biomass(ipts,ipft,:,:) = zero
+                   veget_max(ipts,ipft+1) = veget_max(ipts,ipft+1) + veget_max(ipts,ipft)
+                   veget_max(ipts,ipft) = zero
+
+                   ! Mass balance of the merging procedure
+                   temp_end(:) = zero
+                   DO ipar = 1,nparts
+                      DO iele = 1,nelements
+                         DO icirc = 1,ncirc
+                            temp_end(iele) = temp_end(iele) + &
+                                 SUM(circ_class_biomass(ipts,:,icirc,ipar,iele) * &
+                                 circ_class_n(ipts,:,icirc) * veget_max(ipts,:))
+                         ENDDO
+                      ENDDO
+                   ENDDO
+ 
+                   IF (temp_end(icarbon) - temp_start(icarbon) .LT. min_stomate .AND. &
+                        temp_end(icarbon) - temp_start(icarbon) .GT. -min_stomate) THEN
+                      IF (ld_massbal) WRITE(numout,*) 'Mass balance closure merge_biomass_pfts'
+                   ELSE
+                      WRITE(numout,*) 'Error: mass balance is not closed in merge_biomass_pfts'
+                      WRITE(numout,*) '   Difference is, ',temp_end(icarbon) - temp_start(icarbon) 
+                   ENDIF
+
+                   !! 2.3 Calculate the PFT characteristics of the merged PFT
+                   !  Take the weighted mean of the existing vegetation and the new 
+                   !  vegetation in this PFT. Note that co2_to_bm is in gC. m-2 dt-1 
+                   !  so we should also take the weighted mean (rather than sum if
+                   !  this where absolute values).
+                   lm_lastyearmax(ipts,ipft+1) = share_expanded * lm_lastyearmax(ipts,ipft+1) + &
+                        (un - share_expanded) * lm_lastyearmax(ipts,ipft)
+                   lm_lastyearmax(ipts,ipft) = zero
+                   age(ipts,ipft+1) = share_expanded * age(ipts,ipft+1) + &
+                        (un - share_expanded) * age(ipts,ipft)
+                   age(ipts,ipft) = zero
+                   leaf_frac(ipts,ipft+1,:) = share_expanded * leaf_frac(ipts,ipft+1,:) + &
+                        (un - share_expanded) * leaf_frac(ipts,ipft,:)
+                   leaf_frac(ipts,ipft,:) = zero
+                   leaf_age(ipts,ipft+1,:) = share_expanded * leaf_age(ipts,ipft+1,:) + &
+                        (un - share_expanded) * leaf_age(ipts,ipft,:)
+                   leaf_age(ipts,ipft,:) = zero
+                   lab_fac(ipts,ipft+1) = share_expanded * lab_fac(ipts,ipft+1) + &
+                        (un - share_expanded) * lab_fac(ipts,ipft)
+                   lab_fac(ipts,ipft) = zero
+                   co2_to_bm(ipts,ipft+1) = share_expanded * co2_to_bm(ipts,ipft+1) + &
+                        (un - share_expanded) * co2_to_bm(ipts,ipft)
+                   co2_to_bm(ipts,ipft) = zero
+
+                   ! Everywhere deals with the migration of vegetation. Copy the
+                   ! status of the most migrated vegetation for the whole PFT
+                   everywhere(ipts,ipft+1) = MAX(everywhere(ipts,ipft), everywhere(ipts,ipft+1))
+                   everywhere(ipts,ipft) = zero
+
+                   ! The new soil&litter pools are the weighted mean of the newly 
+                   ! established vegetation for that PFT and the soil&litter pools
+                   ! of the vegetation that already exists in that PFT.
+                   ! Since it is not only the amount of vegetation present (veget_max) but also
+                   ! the amount of structural litter (litter) that is important, we have to 
+                   ! weight by both items here.
+                   DO ilev=1,nlevs
+                      lignin_struc(ipts,ipft+1,ilev) = litter_weight_expanded(istructural,ilev) * lignin_struc(ipts,ipft+1,ilev) + &
+                           (un - litter_weight_expanded(istructural,ilev)) * lignin_struc(ipts,ipft,ilev) 
+                      lignin_struc(ipts,ipft,ilev) = zero
+                      lignin_wood(ipts,ipft+1,ilev) = &
+                           litter_weight_expanded(iwoody,ilev) * lignin_wood(ipts,ipft+1,ilev) + &
+                           (un - litter_weight_expanded(iwoody,ilev) ) * lignin_wood(ipts,ipft,ilev) 
+                      lignin_wood(ipts,ipft,ilev) = zero 
+                   ENDDO
+                   litter(ipts,:,ipft+1,:,:) = share_expanded * litter(ipts,:,ipft+1,:,:) + &
+                        (un - share_expanded) * litter(ipts,:,ipft,:,:)
+                   litter(ipts,:,ipft,:,:) = zero
+                   carbon(ipts,:,ipft+1) =  share_expanded * carbon(ipts,:,ipft+1) + &
+                        (un - share_expanded) * carbon(ipts,:,ipft)
+                   carbon(ipts,:,ipft) = zero 
+                   bm_to_litter(ipts,ipft+1,:,:) = share_expanded * bm_to_litter(ipts,ipft+1,:,:) + & 
+                        (un - share_expanded) * bm_to_litter(ipts,ipft,:,:)
+                   bm_to_litter(ipts,ipft,:,:) = zero
+
+                   ! Copy variables that depend on ::when_growthinit
+                   when_growthinit(ipts,ipft+1) = share_expanded * when_growthinit(ipts,ipft+1) + &
+                        (un - share_expanded) * when_growthinit(ipts,ipft)
+                   when_growthinit(ipts,ipft) = zero
+                   gdd_from_growthinit(ipts,ipft+1) = share_expanded * &
+                        gdd_from_growthinit(ipts,ipft+1) + &
+                        (un - share_expanded) * gdd_from_growthinit(ipts,ipft)
+                   gdd_from_growthinit(ipts,ipft) = zero
+                   gdd_midwinter(ipts,ipft+1) = share_expanded * gdd_midwinter(ipts,ipft+1) + &
+                        (un - share_expanded) * gdd_midwinter(ipts,ipft)
+                   gdd_midwinter(ipts,ipft) = zero
+                   time_hum_min(ipts,ipft+1) = share_expanded * time_hum_min(ipts,ipft+1) + &
+                        (un - share_expanded) * time_hum_min(ipts,ipft)
+                   time_hum_min(ipts,ipft) = zero
+                   gdd_m5_dormance(ipts,ipft+1) = share_expanded * gdd_m5_dormance(ipts,ipft+1) + &
+                        (un - share_expanded) * gdd_m5_dormance(ipts,ipft)
+                   gdd_m5_dormance(ipts,ipft) = zero
+                   ncd_dormance(ipts,ipft+1) = share_expanded * ncd_dormance(ipts,ipft+1) + &
+                        (un - share_expanded) * ncd_dormance(ipts,ipft)
+                   ncd_dormance(ipts,ipft) = zero
+                   moiavail_month(ipts,ipft+1) = share_expanded * moiavail_month(ipts,ipft+1) + &
+                        (un - share_expanded) * moiavail_month(ipts,ipft)
+                   moiavail_month(ipts,ipft) = zero
+                   moiavail_week(ipts,ipft+1) = share_expanded * moiavail_week(ipts,ipft+1) + &
+                        (un - share_expanded) * moiavail_week(ipts,ipft)
+                   moiavail_week(ipts,ipft) = zero
+                   ngd_minus5(ipts,ipft+1) = share_expanded * ngd_minus5(ipts,ipft+1) + &
+                        (un - share_expanded) * ngd_minus5(ipts,ipft)
+                   ngd_minus5(ipts,ipft) = zero
+            
+                   ! Copy remaining properties 
+                   PFTpresent(ipts,ipft+1) = PFTpresent(ipts,ipft)
+                   PFTpresent(ipts,ipft) = .FALSE.
+                   forest_managed(ipts,ipft+1) = forest_managed(ipts,ipft)
+                   forest_managed(ipts,ipft) = 1
+                   KF(ipts,ipft+1) = share_expanded * KF(ipts,ipft+1) + &
+                        (un - share_expanded) * KF(ipts,ipft)
+                   KF(ipts,ipft) = zero
+                   k_latosa_adapt(ipts,ipft+1) = share_expanded * k_latosa_adapt(ipts,ipft+1) + &
+                        (un - share_expanded) * k_latosa_adapt(ipts,ipft)
+                   k_latosa_adapt(ipts,ipft) = zero
+                   senescence(ipts,ipft+1) = senescence(ipts,ipft)
+                   senescence(ipts,ipft) = .FALSE.
+                   npp_longterm(ipts,ipft+1) = share_expanded * npp_longterm(ipts,ipft+1) + &
+                        (un - share_expanded) * npp_longterm(ipts,ipft)
+                   npp_longterm(ipts,ipft) = zero
+                   gpp_daily(ipts,ipft+1) = share_expanded * gpp_daily(ipts,ipft+1) + &
+                        (un - share_expanded) * gpp_daily(ipts,ipft)
+                   gpp_daily(ipts,ipft) = zero 
+                   gpp_week(ipts,ipft+1) = share_expanded * gpp_week(ipts,ipft+1) + &
+                        (un - share_expanded) * gpp_week(ipts,ipft)
+                   gpp_week(ipts,ipft) = zero
+                   resp_maint(ipts,ipft+1) = share_expanded * resp_maint(ipts,ipft+1) + &
+                        (un - share_expanded) * resp_maint(ipts,ipft) 
+                   resp_maint(ipts,ipft) = zero
+                   resp_growth(ipts,ipft+1) = share_expanded * resp_growth(ipts,ipft+1) + &
+                        (un - share_expanded) * resp_growth(ipts,ipft) 
+                   resp_growth(ipts,ipft) = zero
+                   npp_daily(ipts,ipft+1) = share_expanded * npp_daily(ipts,ipft+1) + &
+                        (un - share_expanded) * npp_daily(ipts,ipft) 
+                   npp_daily(ipts,ipft) = zero
+                   use_reserve(ipts,ipft+1) = share_expanded * use_reserve(ipts,ipft+1) + &
+                        (un - share_expanded) * use_reserve(ipts,ipft) 
+                   use_reserve(ipts,ipft) = zero
+                   t_photo_stress(ipts,ipft+1) = share_expanded * t_photo_stress(ipts,ipft+1) + &
+                        (un - share_expanded) * t_photo_stress(ipts,ipft) 
+                   t_photo_stress(ipts,ipft) = zero
+!!$                   lai_target(ipts,ipft+1) = share_expanded * lai_target(ipts,ipft+1) + &
+!!$                        (un - share_expanded) * lai_target(ipts,ipft) 
+!!$                   lai_target(ipts,ipft) = zero
+                   rue_longterm(ipts,ipft+1)  = share_expanded * rue_longterm(ipts,ipft+1) + &
+                        (un - share_expanded) * rue_longterm(ipts,ipft)
+                   rue_longterm(ipts,ipft) = zero
+
+                   ! Some things for forestry
+                   mai(ipts,ipft+1)  = share_expanded * mai(ipts,ipft+1) + &
+                        (un - share_expanded) * mai(ipts,ipft)
+                   mai(ipts,ipft) = zero
+                   pai(ipts,ipft+1)  = share_expanded * pai(ipts,ipft+1) + &
+                        (un - share_expanded) * pai(ipts,ipft)
+                   pai(ipts,ipft) = zero
+                   ! We need an integer for mai_count.  The use of CEILING here is
+                   ! arbitrary.  Maybe FLOOR would work better in some cases.
+                   mai_count(ipts,ipft+1)  = CEILING(share_expanded * mai_count(ipts,ipft+1) + &
+                        (un - share_expanded) * mai_count(ipts,ipft))
+                   mai_count(ipts,ipft) = 0
+                   previous_wood_volume(ipts,ipft+1)  = share_expanded * previous_wood_volume(ipts,ipft+1) + &
+                        (un - share_expanded) * previous_wood_volume(ipts,ipft)
+                   previous_wood_volume(ipts,ipft) = zero
+                   ! These next two variables are integers, so we use CEILING to make sure
+                   ! they stay integers.  FLOOR or INT would also be fine.  The use of
+                   ! CEILING is arbitrary.
+                   age_stand(ipts,ipft+1)  = CEILING(share_expanded * age_stand(ipts,ipft+1) + &
+                        (un - share_expanded) * age_stand(ipts,ipft))
+                   age_stand(ipts,ipft) = zero
+                   last_cut(ipts,ipft+1)  = CEILING(share_expanded * last_cut(ipts,ipft+1) + &
+                        (un - share_expanded) * last_cut(ipts,ipft))
+                   last_cut(ipts,ipft) = zero
+
+                   ! If we are doing an analytical spinup, we need to merge
+                   ! the matrices.  During our spinup, only one age class in a given
+                   ! PFT will be populated.  Therefore, we just need to move
+                   ! the matrix from one PFT to the next.  If there is a chance that
+                   ! there is already biomass in the new PFT and things need to be merged,
+                   ! you should rethink this!
+                   IF (spinup_analytic) THEN
+                      IF(share_expanded .LT. min_stomate)THEN
+                         MatrixV(ipts,ipft+1,:,:)=MatrixV(ipts,ipft,:,:)
+                         MatrixA(ipts,ipft+1,:,:)=MatrixA(ipts,ipft,:,:)
+                         VectorU(ipts,ipft+1,:)=VectorU(ipts,ipft,:)
+                         VectorB(ipts,ipft+1,:)=VectorB(ipts,ipft,:)
+                         MatrixV(ipts,ipft,:,:)=zero
+                         MatrixA(ipts,ipft,:,:)=zero
+                         VectorU(ipts,ipft,:)=zero
+                         VectorB(ipts,ipft,:)=zero
+                      ELSE
+                         WRITE(numout,*) 'Merge problem with spinup.'
+                         WRITE(numout,*) 'ipts,ipft: ',ipts,ipft
+                         WRITE(numout,*) 'share_expanded: ',share_expanded
+                         CALL ipslerr_p (3,'age_class_distr', 'Trying to merge spinup matrices into a PFT with',&
+                              'existing biomass.  Stopping because we are not sure what to do.','')
+                      ENDIF
+                   ENDIF
+
+                ENDIF
+
+             ENDDO ! loop over nagec_pft(ivma)
+
+          ! Grasses and croplands
+          ELSE
+
+             ! Don't have to do anything
+             
+          ENDIF ! is_tree(ivm)
+
+       ENDDO ! Looping over real PFTs
+
+    ENDDO ! loop over #pixels - domain size
+
+
+!! 3. Mass balance closure
+    
+    !! 3.1 Calculate components of the mass balance
+    pool_end(:,:,:) = zero
+    DO iele = 1,nelements
+
+       ! co2_to_bm
+       pool_end(:,:,iele) = pool_end(:,:,iele) + co2_to_bm(:,:)
+
+       ! Biomass pool + bm_to_litter
+       DO ipar = 1,nparts
+          pool_end(:,:,iele) = pool_end(:,:,iele) + &
+               (biomass(:,:,ipar,iele) + bm_to_litter(:,:,ipar,iele)) * &
+               veget_max(:,:)
+       ENDDO
+
+       ! Litter pool (gC m-2) *  (m2 m-2) 
+       DO ilit = 1,nlitt
+          DO ilev = 1,nlevs
+             pool_end(:,:,iele) = pool_end(:,:,iele) + &
+                  litter(:,ilit,:,ilev,iele) * veget_max(:,:)
+          ENDDO
+       ENDDO
+
+       ! Soil carbon (gC m-2) *  (m2 m-2)
+       DO icarb = 1,ncarb
+          pool_end(:,:,iele) = pool_end(:,:,iele) + &
+               carbon(:,icarb,:) * veget_max(:,:)
+       ENDDO
+    ENDDO
+
+    !! 3.2 Calculate mass balance
+    check_intern(:,:,iatm2land,icarbon) = zero 
+    check_intern(:,:,iland2atm,icarbon) = -un * zero
+    check_intern(:,:,ilat2out,icarbon) = zero
+    check_intern(:,:,ilat2in,icarbon) = -un * zero
+    check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - pool_start(:,:,icarbon))
+    closure_intern = zero
+    DO imbc = 1,nmbcomp
+       closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + check_intern(:,:,imbc,icarbon)
+    ENDDO
+
+    !! 3.3 Write outcome of the check
+    !  Sum over ivm because of age class redistribution
+    DO ipts = 1,npts
+       IF (SUM(closure_intern(ipts,:,icarbon)) .LT. min_stomate .AND. &
+            SUM(closure_intern(ipts,:,icarbon)) .GT. -min_stomate) THEN
+          IF (ld_massbal) WRITE(numout,*) 'Mass balance closure: age_class_distr', ipts
+       ELSE
+          WRITE(numout,*) 'Error: mass balance is not closed in age_class_distr'
+          WRITE(numout,*) '   Difference, ipts, ', ipts, SUM(closure_intern(ipts,:,icarbon)) 
+       ENDIF
+    ENDDO
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving age class distribution'
+    
+  END SUBROUTINE age_class_distr
+
+
+
+! ================================================================================================================================
+!! SUBROUTINE   : merge_biomass_pfts
+!!
+!>\BRIEF        Redistribute biomass, litter, soilcarbon and water across
+!!              the age classes
+!!
+!! DESCRIPTION  : Following growth, the trees from an age class may have too
+!! big to still belong to this age class. The biomass, litter, soilcarbon and
+!! soil water then need to be moved from one age class to the next age class.
+!!
+!! RECENT CHANGE(S) : 
+!!
+!! MAIN OUTPUT VARIABLE(S) :  
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : 
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE merge_biomass_pfts(npts, share_expanded, circ_class_n, est_circ_class_n, &
+       tmp_circ_class_n, circ_class_biomass, est_circ_class_biomass, &
+       tmp_circ_class_biomass, ind, biomass, circ_class_dist, ipts, &
+       ivm, est_circ_class_dia, tmp_circ_class_dia)
+
+    IMPLICIT NONE
+    
+  !! 0. Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+    
+    INTEGER, INTENT(in)                              :: npts                  !! Domain size - number of pixels (unitless)
+    REAL(r_std), INTENT(in)                          :: share_expanded        !! Share of the veget_max of the existing vegetation
+                                                                              !! within a PFT over the total veget_max following 
+                                                                              !! expansion of that PFT (unitless, 0-1)
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: circ_class_dist       !! The probability distribution of trees in a circ
+                                                                              !! class in case of a redistribution (unitless). 
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)        :: est_circ_class_biomass!! Temporary variable for circ_class_biomass 
+                                                                              !! of the established vegetation
+                                                                              !! @tex $(g C ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)        :: tmp_circ_class_biomass!! Temporary variable for circ_class_biomass 
+                                                                              !! of the new vegetation 
+                                                                              !! @tex $(g C ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: est_circ_class_n      !! Temporary variable for circ_class_n
+                                                                              !! of the established vegetation
+                                                                              !! @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: tmp_circ_class_n      !! Temporary variable for circ_class_n
+                                                                              !! of the new vegetation
+                                                                              !! @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: est_circ_class_dia    !! Variable to store temporary values for 
+                                                                              !! circ_class (m)
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: tmp_circ_class_dia    !! Variable to store temporary values for 
+                                                                              !! circ_class (m)
+    INTEGER(i_std), INTENT(IN)                       :: ipts, ivm             !! Indices for point and PFT (unitless)
+
+    !! 0.2 Output variables
+
+
+    !! 0.3 Modified variables
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: ind                   !! Number of individuals at the stand level
+                                                                              !! @tex $(m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: biomass               !! Stand level biomass @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: circ_class_biomass    !! circ_class_biomass of the merged vegetation 
+                                                                              !! @tex $(g C ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: circ_class_n          !! circ_class_n of the merged vegetation
+                                                                              !! @tex $(ind m^{-2})$ @endtex
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                   :: ipart                 !! Indices (unitless)
+    INTEGER(i_std)                                   :: icir, jcir, iele      !! Indices (unitless)
+    REAL(r_std)                                      :: trees_needed          !! Number of trees leftthat should be present in a 
+                                                                              !! circumference class when merging the established
+                                                                              !! and newly established vegetation
+                                                                              !! @tex $(ind m^{-2})$ @endtex 
+    REAL(r_std)                                      :: tempa, tempb          !! Variable to store a temporary value (unit varies)
+    REAL(r_std), DIMENSION(nparts,nelements)         :: tempc                 !! Variable to store a temporary value of
+                                                                              !! circ_class_biomass  
+    REAL(r_std), DIMENSION(ncirc)                    :: exp_circ_class_n      !! Temporary variable for circ_class_n of the
+                                                                              !! expanded PFT @tex $(ind m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(2*ncirc)                  :: trees_left            !! Number of trees left in a circumference class when
+                                                                              !! merging the available and newly established 
+                                                                              !! vegetation @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(2*ncirc)                  :: temp_circ_class       !! Temporary variable for circ_class of the expanded
+                                                                              !! PFT for sorting the availble and newly established
+                                                                              !! circumference classes (m)
+    REAL(r_std), DIMENSION(2*ncirc)                  :: temp_circ_class_n     !! Temporary variable for circ_class_n of the expanded
+                                                                              !! PFT for sorting the availble and newly established
+                                                                              !! circumference classes @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(2*ncirc,nparts,nelements) :: temp_circ_class_biomass !! Temporary variable for sorting circ_class_biomass
+                                                                              !! @tex $(g C ind^{-1})$ @endtex
+
+!_ ================================================================================================================================
+
+ IF (bavard.GE.3) WRITE(numout,*) 'Entering merging biomass of pfts'
+
+ !! 1. Initialize
+
+    !! 1.1 Initialize variables
+   
+
+ !! 2. Merge biomass, litter, soilcarbon and soil water
+
+    !  We have already ::ncirc classes in this PFT and we add another 
+    !  ::ncirc through calling prescribe_prognostic. What we want to 
+    !  do is to merge these 2*ncirc into ncirc circumference classes.     
+    !  We need to populate the new distribution of trees among
+    !  the circumference classes, and move the heartwood and sap masses 
+    !  to the new distributions. We also need to move the other pools.  
+    !  This is more tricky because the allometric relations for the 
+    !  new tree sizes will NOT give the same amount of biomass for
+    !  the non-woody pools. Let us first try it just distributing
+    !  everything equally, and then if that doesn't work we can
+    !  redistribute the non-woody pools more cleverly, even if that 
+    !  means we change the total amount of biomass we have in this
+    !  stand.  I want to try it this way because we conserve biomass 
+    !  this way, and I hope that the stress on the trees will be
+    !  small enough that it doesn't cause problems. Redistribution
+    !  is not expected to de-stabilize the allocation too much is the
+    !  diameter range within an age-class is not too big (or in other
+    !  words if we define a sufficiently large number of age classes).
+ 
+    !! 2.1 Calculate new distribution
+    !  The first step is to decide of the distribution of individuals 
+    !  that we want in each class, for example, a uniform or exponential 
+    !  distribution (::circ_class_dist). The total number of individuals
+    !  that needs to be distributed is the weighted sum of the number of 
+    !  individuals (#/m-2) that is already available and the the 
+    !  individuals that are newly established.  
+    IF (share_expanded .LT. min_stomate) THEN
+
+       ! The new PFT is still empty so simply copy the current tree 
+       ! distribution into the new PFT
+       exp_circ_class_n(:) = tmp_circ_class_n(:)
+
+    ELSE
+
+       ! The new PFT contains trees, merge the tree distributions. The
+       ! new tree distribution follows a prescribed distribution
+       exp_circ_class_n(:) = circ_class_dist(:) * &
+            SUM( share_expanded * est_circ_class_n(:) + &
+            (un-share_expanded) * tmp_circ_class_n(:) )
+
+    ENDIF   
+
+
+    !! 2.2 Copy both distributions into a single variable
+    DO icir = 1,2*ncirc
+
+       IF (icir .LE. ncirc) THEN
+
+          ! Circumference classes, number of individuals and biomass
+          ! of the available vegetation (m). Weight by the area share
+          ! such that we don't need to do this further down. Don't
+          ! weight the circumference and biomass as those variables are
+          ! expressed per tree. This helps to simplify the equations.
+          temp_circ_class(icir) = pi * est_circ_class_dia(icir)
+          temp_circ_class_n(icir) = share_expanded * &
+               est_circ_class_n(icir)
+          temp_circ_class_biomass(icir,:,:) = &
+               est_circ_class_biomass(icir,:,:)  
+
+       ELSEIF ( (icir .GT. ncirc) .AND. (icir .LE. 2*ncirc) ) THEN
+
+          ! Circumference classes, number of individuals and biomass
+          ! of the newly established vegetation (m). Weight by the area 
+          ! share such that we don't need to do this further down. Don't
+          ! weight the circumference and biomass as those variables are
+          ! expressed per tree. This helps to simplify the equations.
+          temp_circ_class(icir) = pi * tmp_circ_class_dia(icir-ncirc)
+          temp_circ_class_n(icir) = (un - share_expanded) * &
+               tmp_circ_class_n(icir-ncirc)
+          temp_circ_class_biomass(icir,:,:) = &
+               tmp_circ_class_biomass(icir-ncirc,:,:)
+
+       ELSE
+
+          WRITE(numout,*) 'Error - problem with the dimensions of a do-loop '
+
+       ENDIF
+
+    ENDDO !loop over 2*ncirc
+
+
+    !! 2.3 Sort the biomass and number of trees according to their 
+    !  circumference 
+    DO jcir = 2,2*ncirc
+
+       tempa = temp_circ_class(jcir)
+       tempb = temp_circ_class_n(jcir)
+       tempc(:,:) = temp_circ_class_biomass(jcir,:,:)
+
+       DO icir = jcir-1,1,-1
+
+          IF (temp_circ_class(icir) .LE. tempa) EXIT
+          temp_circ_class(icir+1) = temp_circ_class(icir)
+          temp_circ_class_n(icir+1) = temp_circ_class_n(icir)
+          temp_circ_class_biomass(icir+1,:,:) = &
+               temp_circ_class_biomass(icir,:,:)
+
+       ENDDO
+
+       temp_circ_class(icir+1) = tempa
+       temp_circ_class_n(icir+1) = tempb
+       temp_circ_class_biomass(icir+1,:,:) = tempc(:,:)
+
+    ENDDO
+   
+
+    !! 2.4 Merge into a single distribution with ncirc classes
+    !  Merge the 2*ncirc classes in ncirc classes. Empty one circ class
+    !  after the other going from the smallest to the biggest. Here we
+    !  still have 2*ncirc dimensions
+    circ_class_biomass(ipts,ivm,:,:,:) = zero
+    trees_left(:) = temp_circ_class_n(:)
+    DO icir=1,ncirc
+
+       ! This is the number of trees in the ncirc circ classes thus
+       ! AFTER the merge happened 
+       trees_needed = exp_circ_class_n(icir)
+       DO jcir = 1,2*ncirc
+
+          IF (trees_needed .LT. min_stomate) EXIT
+
+          IF (trees_left(jcir) .GE. trees_needed) THEN
+
+             ! We can get all the trees we need from this class
+             ! and don't have to continue searching. Note that
+             ! the units of circ_class_biomass have temporarly 
+             ! changed to gC m-2
+             circ_class_biomass(ipts,ivm,icir,:,:) = &
+                  circ_class_biomass(ipts,ivm,icir,:,:) + &
+                  temp_circ_class_biomass(jcir,:,:) * &
+                  trees_needed
+             trees_left(jcir) = trees_left(jcir) - trees_needed
+             trees_needed = zero
+
+             EXIT
+
+          ELSE
+
+             ! The number of trees in this class are not sufficient, so
+             ! we need to move all of them to the new class. Note that
+             ! the units of circ_class_biomass have temporarly changed 
+             ! to gC m-2
+             circ_class_biomass(ipts,ivm,icir,:,:) = &
+                  circ_class_biomass(ipts,ivm,icir,:,:) + &
+                  temp_circ_class_biomass(jcir,:,:) * &
+                  trees_left(jcir)
+             trees_needed = trees_needed - trees_left(jcir)
+             trees_left(jcir) = zero
+
+          ENDIF
+
+       ENDDO ! jcir=1,ncirc   
+
+    ENDDO ! icir=1,ncirc
+
+
+    !! 2.5 convert units back to the original units (gC tree-1) 
+    !  Right now, circ_class_biomass gives the total biomass
+    !  in each class, but it should only be for a model tree. 
+    !  So let's normalize it. And, update the variables that 
+    !  pass this information around
+    DO icir=1,ncirc
+
+       circ_class_biomass(ipts,ivm,icir,:,:) = &
+            circ_class_biomass(ipts,ivm,icir,:,:) / exp_circ_class_n(icir)
+       circ_class_n(ipts,ivm,icir) = exp_circ_class_n(icir)         
+
+    ENDDO
+ 
+    ! Synchronize circ_class_biomass and biomass and 
+    ! circ_class_n and ind
+    ind(ipts,ivm) = SUM(circ_class_n(ipts,ivm,:))
+    DO iele = 1,nelements
+
+       DO ipart = 1,nparts
+
+          biomass(ipts,ivm,ipart,iele) = &
+               SUM(circ_class_biomass(ipts,ivm,:,ipart,iele) * &
+               circ_class_n(ipts,ivm,:))
+
+       ENDDO
+
+    ENDDO
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving merging biomass of pfts'
+    
+  END SUBROUTINE merge_biomass_pfts
+
+! ================================================================================================================================
+!! SUBROUTINE   : print_lcc_error_message
+!!
+!>\BRIEF        
+!!
+!! DESCRIPTION  : 
+!!
+!! RECENT CHANGE(S) : 
+!!
+!! MAIN OUTPUT VARIABLE(S) :  
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : 
+!! \n
+!_ ================================================================================================================================
+
+  
+  SUBROUTINE print_lcc_error_message(npts,ipts,veget_max_new,veget_max,&
+       veget_max_new_group,veget_max_group,delta_veget,loss_gain,flag)
+
+    IMPLICIT NONE
+    
+  !! 0. Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+
+    INTEGER, INTENT(in)                                :: npts                 !! Domain size - number of pixels (unitless)
+    INTEGER, INTENT(in)                                :: ipts                 !! Location of current gridsquare
+    INTEGER, INTENT(in)                                :: flag                 !! Indicates what to print
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)       :: veget_max            !! "maximal" coverage fraction of a PFT (LAI ->
+                                                                               !! infinity) on ground.  (unitless) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)       :: veget_max_new        !! new "maximal" coverage fraction of a PFT (LAI
+                                                                               !! -> infinity) on ground. 
+    REAL(r_std),DIMENSION(npts,nvmap), INTENT(in)      :: delta_veget          !! changes in "maximal" coverage fraction of PFT 
+    REAL(r_std), DIMENSION(npts,nvmap) , INTENT(in)    :: veget_max_new_group  !! Total veget_max_new of all age clases within a PFT group 
+                                                                               !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,nvmap) , INTENT(in)    :: veget_max_group      !! Total veget_max of all age clases within a PFT group 
+                                                                               !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,nvm)                   :: loss_gain            !! The same as delta_veget but distributed of all
+                                                                               !! age classes and thus taking the age-classes into 
+                                                                               !! account (unitless, 0-1)
+
+    !! 0.2 Output variables
+
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                    :: ivm,ivma  !! Indices
+!_ ================================================================================================================================
+
+    IF(ipts .LT. 1)THEN
+       WRITE(numout,*) 'ERROR: Passing a bad point to print_lcc_error_message.'
+       WRITE(numout,*) 'ipts, test_grid: ',ipts,test_grid
+       RETURN
+    ENDIF
+
+    SELECT CASE(flag)
+    CASE(1)
+
+       ! Case 1
+       WRITE(numout,*) 'ipts ivma veget_max_group veget_max_new_group'
+       DO ivma=1,nvmap
+          WRITE(numout,'(2I7,2F14.10)') ipts,ivma,veget_max_group(ipts,ivma),&
+               veget_max_new_group(ipts,ivma)
+       ENDDO
+       WRITE(numout,*) 'SUMS: ',SUM(veget_max_group(ipts,:)),&
+            SUM(veget_max_new_group(ipts,:))
+
+    CASE(2)
+
+       ! Case 2
+       WRITE(numout,*) 'ivm veget_max veget_max_new'
+       DO ivm=1,nvm
+          WRITE(numout,'(2I7,2F14.10)') ipts,ivm,veget_max(ipts,ivm),&
+               veget_max_new(ipts,ivm)
+       ENDDO
+       WRITE(numout,*) 'SUMS: ',SUM(veget_max(ipts,:)),&
+            SUM(veget_max_new(ipts,:))
+
+    CASE(3)
+
+       ! Case 3
+       WRITE(numout,*) 'ivm veget_max_group delta_veget'
+       DO ivma=1,nvmap
+          WRITE(numout,'(2I7,3F14.10)') ipts,ivma,veget_max_group(ipts,ivma),&
+               delta_veget(ipts,ivma)
+       ENDDO
+       WRITE(numout,*) 'SUMS: ',SUM(veget_max_group(ipts,:)),&
+            SUM(delta_veget(ipts,:))
+    CASE(4)
+
+       !Case 4
+       WRITE(numout,*) 'ipts ivm veget_max loss_gain'
+       DO ivm=1,nvm
+         WRITE(numout,'(2I7,3F14.10)') ipts,ivm,&
+               veget_max(ipts,ivm),loss_gain(ipts,ivm)
+       ENDDO
+       WRITE(numout,*) 'SUMS: ',SUM(veget_max(ipts,:)),&
+            SUM(loss_gain(ipts,:))
+
+   CASE(5)
+
+       ! Case 5
+       WRITE(numout,*) 'ivm agec_group'
+       DO ivm=1,nvm
+          WRITE(numout,'(2I8)') ivm,agec_group(ivm)
+       ENDDO
+
+    CASE default
+
+       ! Default case
+       WRITE(numout,*) 'ERROR: Not sure what you want me to print in LCC.'
+    END SELECT
+    
+     
+  END SUBROUTINE print_lcc_error_message
+
+
+! ================================================================================================================================
+!! SUBROUTINE   : adjust_delta_veget
+!!
+!>\BRIEF        
+!!
+!! DESCRIPTION  : 
+!!
+!! RECENT CHANGE(S) : 
+!!
+!! MAIN OUTPUT VARIABLE(S) :  
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : 
+!! \n
+!_ ================================================================================================================================
+
+  
+  SUBROUTINE adjust_delta_veget(npts,veget_max,veget_max_group,veget_max_new,&
+       veget_max_new_group,loss_gain,delta_veget)
+
+  !! 0. Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+
+    INTEGER, INTENT(in)                                :: npts                 !! Domain size - number of pixels (unitless)
+    REAL(r_std), DIMENSION(npts,nvmap),INTENT(in)               :: veget_max_group        !! Total veget_max of all age clases within a PFT group 
+                                                                               !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: veget_max_new    !! new "maximal" coverage fraction of a PFT (LAI
+                                                                                  !! -> infinity) on ground. 
+    REAL(r_std), DIMENSION(npts,nvmap), INTENT(in)               :: veget_max_new_group    !! Total veget_max_new of all age clases within a PFT group 
+                                                                               !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: veget_max        !! "maximal" coverage fraction of a PFT (LAI ->
+                                                                                  !! infinity) on ground.  (unitless) 
+
+    !! 0.2 Output variables
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                 :: loss_gain              !! The same as delta_veget but distributed of all
+                                                                                           !! age classes and thus taking the age-classes into 
+
+
+    !! 0.3 Modified variables
+    REAL(r_std),DIMENSION(npts,nvmap), INTENT(inout)      :: delta_veget          !! changes in "maximal" coverage fraction of PFT 
+
+    !! 0.4 Local variables
+    REAL(r_std), DIMENSION(npts,nvmap)                    :: delta_veget_old        !! A temporary copy of delta_veget.
+    INTEGER(i_std)                                    :: ivm,ivma,ipts  !! Indices
+    INTEGER(i_std)                                    :: jvma,igroup,iyoung  !! Indices
+    REAL(r_std)                                      :: excess_veg_add         !! 
+    REAL(r_std)                                      :: excess_veg_rem         !! 
+    REAL(r_std)                                      :: veg_add_tot            !! 
+    REAL(r_std)                                      :: difference             !! How much leftover veget_max we have
+    INTEGER(i_std)                                   :: ncount                 !! The number of PFTs with significant changes
+                                                                               !! in vegetation.
+    INTEGER(i_std)                                   :: nagec_local            !! The number of age classes in this map PFT.
+
+!_ ================================================================================================================================
+
+
+    loss_gain(:,:)=zero
+
+    ! Here we have to be careful.  There is a variable, min_vegfrac, which checks some things
+    ! below to make sure we do not end up with land that is below a certain size.  This seems to be
+    ! mainly for the DGVM, but it affects us here, too.  If our final veget_max is too low,
+    ! this will cause problems.  Therefore, adjust them beforehand.  
+
+    delta_veget_old(:,:)=delta_veget(:,:)
+    DO ipts=1,npts
+
+       
+       IF(ld_lcc)THEN
+          IF(test_grid == ipts)THEN
+             WRITE(numout,*) 'Readjusting LCC fluxes for grid: ',ipts
+          ENDIF
+       ENDIF
+
+!! 4. Distribute delta_veget over all age-classes
+    
+    !  ::delta_veget has been calculated for the sum of the age classes
+    !  within a PFT. ::delta_veget thus needs to be distributed over 
+    !  all the age classes. This distribution requires a rule which 
+    !  in the absence of better information is based on the assumption
+    !  that a land cover change does not care about the age classes.
+    !  Following a forestry logic, one would change an old forest into 
+    !  a grassland because that would result in an income from the wood
+    !  harvest. However, here we assume that LCC follows a spatialized 
+    !  economic need and therefore does not respect the forestry logic.
+    !  In other words, when a farmer needs more land, he will not cut
+    !  spatialy distributed old stands but will target a block of land
+    !  bordering his current agricultural lands. By doing so forest
+    !  of all age classes will be cut when LCC is the underlying 
+    !  motivation. The reasoning applies for deforestation driven by 
+    !  urbanisation. This assumption translates in that the land cover
+    !  fraction of all age classes will decrease proportionally to their
+    !  share when the PFT experiences a loss. When the PFT experiences an
+    !  increase in the PFT cover this only happens in the youngest age *
+    !  class.
+
+    ! There is one more constraint.  The new vegetation fraction at
+       ! the end of the calculation must be larger than min_vegfrac.  It might
+       ! not be if we remove the wrong amount of vegetation.  If veget_max
+       ! is greater than zero but less than min_vegfrac after accounting
+       ! for loss_gain, we kill the whole PFT and move the leftover to
+       ! bare soil.  This leftover should be a small number.
+ 
+       ! This is a clean up case.  We should not have absolute values of loss_gain
+       ! or delta_veget which are less than min_stomate.  This carbon will get
+       ! lost otherwise.  First let's do delta_veget.  We will have to do something
+       ! at the end to be sure nothing has gone wrong with loss_gain, too.
+       excess_veg_add=zero
+       excess_veg_rem=zero
+       DO ivma=1,nvmap
+          IF ((delta_veget(ipts,ivma) .LT. min_stomate) .AND. &
+               (delta_veget(ipts,ivma) .GT. zero)) THEN
+
+             IF(ld_lcc .AND. ipts == test_grid)THEN
+                WRITE(numout,*) 'delta_veget between zero and min_stomate, adding ',&
+                     ivma,delta_veget(ipts,ivma)
+             ENDIF
+
+             ! We want to add just a tiny amount of land.  Add it somewhere else.
+             excess_veg_add=excess_veg_add+delta_veget(ipts,ivma)
+             delta_veget(ipts,ivma)=zero
+
+          ELSEIF((delta_veget(ipts,ivma) .LT. zero) .AND. &
+               (delta_veget(ipts,ivma) .GT. -min_stomate))THEN
+             
+             IF(ld_lcc .AND. ipts == test_grid)THEN
+                WRITE(numout,*) 'delta_veget between zero and -min_stomate, removing ',&
+                     ivma,delta_veget(ipts,ivma)
+             ENDIF
+
+             ! We want to remove just a tiny amount of land.  Remove it somewhere else.
+             excess_veg_rem=excess_veg_rem+delta_veget(ipts,ivma)
+             delta_veget(ipts,ivma)=zero
+
+          ENDIF
+
+       ENDDO
+
+
+       ! From here on, we are only concerned with loss_gain.  We will ignore
+       ! delta_veget after creating loss_gain, and then we will reconstruct
+       ! delta_veget at the end from the changes we have made to loss_gain.
+       DO ivm=1,nvm
+
+          igroup=agec_group(ivm)
+          iyoung=start_index(igroup)
+
+          ! Only forest PFTs have age classes
+          IF (is_tree(ivm)) THEN
+
+             ! PFT cover area decreases (loss)
+             IF (delta_veget(ipts,igroup) .LE. -min_stomate) THEN
+
+                ! Calculate the proportinal cover change 
+
+                loss_gain(ipts,ivm) = veget_max(ipts,ivm) / &
+                        veget_max_group(ipts,igroup) * delta_veget(ipts,igroup)
+
+             ! PFT cover area increases (gain)
+             ELSE
+
+                ! The first age-class in a PFT group is the youngest
+                ! and that is the age-class were the change in cover fraction
+                ! takes place
+                IF(ivm == iyoung)THEN
+                   loss_gain(ipts,ivm) = delta_veget(ipts,igroup)
+                ELSE
+
+                   ! The remaining age-classes in that PFT don't experience a
+                   ! change in cover fraction  
+
+                   loss_gain(ipts,ivm) = zero
+
+                ENDIF ! looking for youngest age class
+
+             ENDIF
+
+          ! Grasses and croplands
+          ELSE
+
+             ! There are no age-classes for grasses and crops, hence, 
+             ! delta_veget should not be distributed over the age classes
+             loss_gain(ipts,ivm) = delta_veget(ipts,igroup)
+
+          ENDIF ! is_tree(ivm)
+
+       ENDDO ! looping over PFTs
+
+       IF (ld_lcc) THEN
+          IF(ipts == test_grid)THEN
+             WRITE(numout,*) 'First estimate of loss_gain '
+             
+             CALL print_lcc_error_message(npts,test_grid,veget_max_new,veget_max,veget_max_new_group,&
+                  veget_max_group,delta_veget,loss_gain,4)
+          ENDIF
+       ENDIF
+
+       ! It is possible that we try to add a very small amount to a PFT
+       ! which does not exist.  We cannot have a veget_max between
+       ! min_stomate and min_vegfrac.  We will remove such small
+       ! changes here, but we need to be sure to add them somewhere else.
+       DO ivm=1,nvm
+
+          IF(veget_max(ipts,ivm) .LT. min_stomate)THEN
+
+
+             IF((loss_gain(ipts,ivm) .GT. zero) .AND. &
+                  (loss_gain(ipts,ivm) .LE. min_vegfrac))THEN
+                IF(ld_lcc .AND. ipts == test_grid)THEN
+                   WRITE(numout,*) 'Trying to add too small of loss_gain to a PFT ' // &
+                        'which does not exist.  Correcting.'
+                   WRITE(numout,*) 'ipts, ivm, min_vegfrac: ',ipts, ivm, min_vegfrac
+                   WRITE(numout,*) 'veget_max,loss_gain (before): ',&
+                        veget_max(ipts,ivm),loss_gain(ipts,ivm)
+                ENDIF
+                excess_veg_add=excess_veg_add+loss_gain(ipts,ivm)
+                loss_gain(ipts,ivm)=zero
+                
+             ENDIF
+             
+          ENDIF
+
+       ENDDO ! looping over all PFTs
+
+       ! This is a first readjustment due to the fact that creating
+       ! loss_gain proportational to veget_max might generate a
+       ! new veget_max for a given PFT which is below min_fracveg.
+       DO ivma=1,nvmap
+
+          iyoung=start_index(ivma)
+          nagec_local=nagec_pft(ivma)
+
+          ! Only a concern if we have age classes
+          IF (nagec_local .GT. 1) THEN
+
+             ! Will any veget_maxes created by these loss_gains
+             ! be below the minmum vegetation fraction?
+
+             DO ivm=iyoung,iyoung+nagec_local-1
+                IF(loss_gain(ipts,ivm) .LT. zero)THEN
+                   ! We also need to check if it's greater than zero, since we might want
+                   ! to remove the whole PFT, which is perfectly okay.
+                   IF(veget_max(ipts,ivm)-ABS(loss_gain(ipts,ivm)) .LE. min_vegfrac .AND. &
+                        (veget_max(ipts,ivm)-ABS(loss_gain(ipts,ivm)) .NE. zero))THEN
+                      IF(ld_lcc .AND. ipts == test_grid)THEN
+                         WRITE(numout,*) 'Results in a veget_max below min_vegfrac!  Correcting.'
+                         WRITE(numout,*) 'ipts, ivm, min_vegfrac: ',ipts, ivm, min_vegfrac
+                         WRITE(numout,*) 'veget_max,loss_gain (before): ',&
+                              veget_max(ipts,ivm),loss_gain(ipts,ivm)
+                      ENDIF
+                      ! We kill the whole PFT.  This means we have to add a gain somewhere
+                      ! to compensate, probably bare soil.
+                      excess_veg_add=excess_veg_add+(veget_max(ipts,ivm)-ABS(loss_gain(ipts,ivm)))
+                      loss_gain(ipts,ivm)=-veget_max(ipts,ivm)
+                   ENDIF
+                ENDIF
+             ENDDO
+
+          ENDIF ! checking if we have age classes 
+
+       ENDDO ! looping over the map PFTs
+
+       ! Now we do one final check to make sure that our loss_gain isn't too small.
+       ! It should be fairly rare that we actually do something here.  We have
+       ! already done the same check above for delta_veget, so if we don't have
+       ! age classes there will be nothing to do here.  This is required because
+       ! some of the actions in LCC are not done if loss_gain is below min_stomate,
+       ! so we would have a mass balance error otherwise.
+       DO ivma=1,nvmap
+
+          iyoung=start_index(ivma)
+          nagec_local=nagec_pft(ivma)
+
+          ! Only a concern if we have age classes
+          IF (nagec_local .GT. 1) THEN
+
+             ! Will any veget_maxes created by these loss_gains
+             ! be below the minmum vegetation fraction?
+
+             DO ivm=iyoung,iyoung+nagec_local-1
+                IF ((loss_gain(ipts,ivm) .LT. min_stomate) .AND. &
+                     (loss_gain(ipts,ivm) .GT. zero)) THEN
+                   
+                   IF(ld_lcc .AND. ipts == test_grid)THEN
+                      WRITE(numout,*) 'loss_gain between zero and min_stomate, adding ',&
+                           ivm,ivma,delta_veget(ipts,ivma),loss_gain(ipts,ivm)
+                   ENDIF
+
+                  ! We want to add just a tiny amount of land.  Add it somewhere else.
+                   excess_veg_add=excess_veg_add+loss_gain(ipts,ivm)
+                   loss_gain(ipts,ivm)=zero
+                   
+                ELSEIF((loss_gain(ipts,ivm) .LT. zero) .AND. &
+                     (loss_gain(ipts,ivm) .GT. -min_stomate))THEN
+                   
+                   IF(ld_lcc .AND. ipts == test_grid)THEN
+                      WRITE(numout,*) 'loss_gain between zero and -min_stomate, removing ',&
+                           ivm,ivma,delta_veget(ipts,ivma),loss_gain(ipts,ivm)
+                   ENDIF
+
+                   ! We want to add just a tiny amount of land.  Add it somewhere else.
+                   excess_veg_rem=excess_veg_rem+loss_gain(ipts,ivm)
+                   loss_gain(ipts,ivm)=zero
+                   
+                ENDIF
+
+             ENDDO ! loop over the age classes for this PFT
+
+          ENDIF ! checking if we have age classes 
+
+       ENDDO ! looping over the map PFTs
+
+
+       ! If we have extra land to add/remove, let's change the loss_gain of bare soil.
+       ! This should, in general, be a small number.
+       IF (ld_lcc) THEN
+          IF(ipts == test_grid)THEN
+             WRITE(numout,*) 'Extra vegetation to add: '
+             WRITE(numout,*) 'excess_veg_add: ',excess_veg_add
+             WRITE(numout,*) 'Extra vegetation to remove: '
+             WRITE(numout,*) 'excess_veg_rem: ',excess_veg_rem
+
+             WRITE(numout,*) 'Readjusting loss_gain to make sure an age class does not fall too low.'
+
+             CALL print_lcc_error_message(npts,ipts,veget_max_new,veget_max,veget_max_new_group,&
+                  veget_max_group,delta_veget,loss_gain,4)
+
+          ENDIF
+
+       ENDIF
+
+       ! Our loss_gain should not lead to a bare soil fraction below min_vegfrac.
+       ! Start with PFT 1 (bare soil) and try to put all the excess into a single PFT.
+       ! If we cannot do that, throw an error. It's possible that we can flip the sign
+       ! of the loss_gain by doing this, but that should not cause any
+       ! serious problem.  We just won't be 100% inline with the maps, but as long
+       ! as min_vegfrac exists, we won't be anyways.
+
+       ! We loop over the map PFTs here.  We don't want to loop over all the PFTs
+       ! and check, because we might end up adding area to an age class which
+       ! is not the youngest that way, which would be bad.
+       excess:DO ivma=1,nvmap
+          ! Do we have vegetation?
+          ivm=start_index(ivma)
+          IF(veget_max(ipts,ivm) .GE. min_stomate)THEN
+
+             ! Can we add the difference without falling below min_vegfrac?
+             IF((veget_max(ipts,ivm)+&
+                  (loss_gain(ipts,ivm)+excess_veg_add+excess_veg_rem)) .GT. min_vegfrac)THEN
+                ! Also, our total loss_gain needs to be above min_stomate
+                IF(ABS(loss_gain(ipts,ivm)+excess_veg_add+excess_veg_rem) .GT. min_stomate)THEN
+                   
+                   IF(ld_lcc .AND. test_grid == ipts)THEN
+                      WRITE(numout,*) 'Dumping excess vegetation'
+                      WRITE(numout,*) 'ipts,ivm,ivma: ',ipts,ivm,ivma
+                      WRITE(numout,*) 'Correction: ',&
+                           excess_veg_add+excess_veg_rem
+                      WRITE(numout,*) 'veget_max: ',veget_max(ipts,ivm)
+                      WRITE(numout,*) 'veget_max corrected: ',veget_max(ipts,ivm)+&
+                           (loss_gain(ipts,ivm)+excess_veg_add+excess_veg_rem)
+                      WRITE(numout,*) 'loss_gain: ',loss_gain(ipts,ivm)
+                      WRITE(numout,*) 'loss_gain corrected: ',loss_gain(ipts,ivm)+&
+                           excess_veg_add+excess_veg_rem
+                   ENDIF
+                   ! Let's do it.
+                   loss_gain(ipts,ivm)=loss_gain(ipts,ivm)+&
+                        excess_veg_add+excess_veg_rem
+                   excess_veg_add=zero
+                   excess_veg_rem=zero
+                   EXIT excess
+                ENDIF
+             ENDIF
+          ENDIF
+       ENDDO excess
+
+       ! If we still have excess vegetation, our method did not work.
+       IF((excess_veg_add .GE. min_stomate) .OR. &
+            (ABS(excess_veg_rem) .GE. min_stomate))THEN
+
+          ! It is possible that the excess amount we have to add and that which we have to remove
+          ! cancel each other out.  In which case, we don't actually have a problem.
+          IF(ABS(excess_veg_add+excess_veg_rem) .GE. min_stomate)THEN
+             WRITE(numout,*) 'We were not able to redistribute all the extra vegetation in LCC.'
+             WRITE(numout,*) 'excess_veg_add: ',excess_veg_add
+             WRITE(numout,*) 'excess_veg_rem: ',excess_veg_rem
+             WRITE(numout,*) 'ipts: ',ipts
+             CALL print_lcc_error_message(npts,ipts,veget_max_new,veget_max,veget_max_new_group,&
+                  veget_max_group,delta_veget,loss_gain,4)
+             IF(lignore_lcc_stops)THEN
+                CALL ipslerr_p (2,'land_cover_main', 'Not stopping here.',&
+                     'Only ignore me if you know what you are doing!','Place 2')
+                excess_veg_add=zero
+                excess_veg_rem=zero
+             ELSE
+                CALL ipslerr_p (3,'land_cover_main', 'Unable to redistribute vegetation (see output file)','','')
+             ENDIF
+
+          ELSE
+             IF(ld_lcc .AND. ipts == test_grid)THEN
+                WRITE(numout,*) 'All extra vegetation successfully redistributed in LCC.'
+                WRITE(numout,*) 'excess_veg_add: ',excess_veg_add
+                WRITE(numout,*) 'excess_veg_rem: ',excess_veg_rem
+             ENDIF
+             excess_veg_add=zero
+             excess_veg_rem=zero
+          ENDIF
+       ENDIF
+
+       ! Reconstruct the delta_veget from the adjusted loss_gain array.
+       delta_veget(ipts,:)=zero
+       DO ivma=1,nvmap
+
+          iyoung=start_index(ivma)
+          nagec_local=nagec_pft(ivma)
+
+          ! Add all these age classes to this map PFT
+          DO ivm=iyoung,iyoung+nagec_local-1
+             delta_veget(ipts,ivma)=delta_veget(ipts,ivma)+loss_gain(ipts,ivm)
+          ENDDO
+
+       ENDDO ! done looping over map PFTs
+
+
+
+       ! Now one final sanity check.  We should never try to remove more
+       ! vegetation than we actually have.  
+       DO ivm=1,nvm
+          ! Notice here that loss_gain is negative for pixels
+          ! which remove veget_max.
+          difference=veget_max(ipts,ivm)+loss_gain(ipts,ivm)
+          IF(difference .LT. -min_stomate)THEN
+             ! This is a problem.
+             WRITE(numout,*) 'We are trying to remove too much vegetation in LCC.'
+             WRITE(numout,*) 'ipts, ivm: ',ipts, ivm
+             WRITE(numout,*) 'veget_max, loss_gain: ',&
+                  veget_max(ipts,ivm),loss_gain(ipts,ivm)
+             CALL ipslerr_p (3,'land_cover_main', 'Removing too much vegetation (see output file)','','')
+             
+          ELSEIF((difference .LE. min_vegfrac) .AND. &
+               (difference .GT. min_stomate))THEN
+             ! We should have accounted for this above.
+             WRITE(numout,*) 'We are left with an awkward amount of vegetation vegetation in LCC.'
+             WRITE(numout,*) 'This should have been taken care of above.'
+             WRITE(numout,*) 'ipts, ivm: ',ipts, ivm
+             CALL print_lcc_error_message(npts,test_grid,veget_max_new,veget_max,veget_max_new_group,&
+                  veget_max_group,delta_veget,loss_gain,4)
+             CALL ipslerr_p (3,'land_cover_main', 'Awkward amoutn of vegetation (see output file)','','')
+          ELSEIF(difference .LT. zero)THEN
+             ! Technically not a problem since it could be -1e-17, but it might provoke
+             ! a mass balance error so we warn about it.  The serious case of
+             ! a difference less than -min_stomate was handled above.
+             WRITE(numout,*) 'WARNING: A small amount of leftover vegatation in LCC.'
+             WRITE(numout,*) 'Should not cause a problem, but watch for a mass balance error.'
+             WRITE(numout,*) 'ipts, ivm: ',ipts, ivm
+             WRITE(numout,*) 'veget_max, loss_gain: ',&
+                  veget_max(ipts,ivm),loss_gain(ipts,ivm)
+             CALL ipslerr_p (2,'land_cover_main', 'Small amount of leftover vegetation (see output file)','','')
+          ENDIF
+
+       ENDDO ! loop over PFTs
+
+    ENDDO ! loop over #pixels - domain size
+
+  END SUBROUTINE adjust_delta_veget
+
+END MODULE sapiens_lcchange
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/sapiens_product_use.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/sapiens_product_use.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/sapiens_product_use.f90	(revision 7236)
@@ -0,0 +1,1110 @@
+! =================================================================================================================================
+! MODULE       : sapiens_product_use
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Following lateral transport, calculate C-stored in the product pools
+!!             and the CO2-release from product decomposition  
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	: None
+!!
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_stomate/stomate_lcchange.f90 $
+!! $Date: 2013-07-03 10:16:15 +0200 (Wed, 03 Jul 2013) $
+!! $Revision: 1356 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE sapiens_product_use
+
+! modules used:
+  
+  USE stomate_data
+  USE pft_parameters
+  USE constantes
+  
+  IMPLICIT NONE
+  
+  PRIVATE
+  PUBLIC basic_product_use, basic_product_init, dim_product_use
+  
+CONTAINS 
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : basic_product_use
+!!
+!>\BRIEF        Calculate the C stored in biomass-based products and the 
+!!              CO2 release through their decomposition 
+!!
+!! DESCRIPTION  : The basic approach distinguished 3 pools (as introduced by
+!! Shilong Piao based on Houghton. This module does NOT make use of the 
+!! dimensions of the woody harvest or of the management and cutting flags.
+!! All wood is distributed across the short, medium and long product pools. 
+!! This basically means that wood use in ..., 1600, 1700, 1800, 1900 and 2000 
+!! was identical.\n
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : prod_s, prod_m, prod_l, flux_s, flux_m, flux_l,
+!!   cflux_prod_s cflux_prod_m and cflux_prod1_l 
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!!
+!_ ================================================================================================================================
+
+ SUBROUTINE basic_product_use(npts, dt_days, harvest_pool_bound, harvest_pool, &
+            harvest_type, harvest_cut, harvest_area, &
+            cflux_prod_s, cflux_prod_m, cflux_prod_l, prod_s, &
+            prod_m, prod_l, prod_s_total, prod_m_total, &
+            prod_l_total, cflux_prod_total, flux_s, flux_m, &
+            flux_l, resolution)
+
+   IMPLICIT NONE
+
+
+ !! 0. Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+   
+    INTEGER, INTENT(in)                                  :: npts              !! Domain size - number of pixels (unitless)
+    REAL(r_std), INTENT(in)                              :: dt_days           !! Time step of vegetation dynamics for stomate
+                                                                              !! (days)
+    REAL(r_std),DIMENSION(:,:), INTENT(in)               :: resolution        !! The length in m of each grid-box in X and Y
+    REAL(r_std), DIMENSION(:), INTENT(in)                :: harvest_pool_bound!! The boundaries of the diameter classes
+                                                                              !! in the wood harvest pools @tex $(m)$ @endtex
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: cflux_prod_s      !! C-released during first years (short term) 
+                                                                              !! following land cover change 
+                                                                              !! @tex ($gC m^{-1} dt^{-1}$) @endtex 
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: cflux_prod_m      !! Total annual release from decomposition of 
+                                                                              !! the medium-lived product pool 
+                                                                              !! @tex ($gC m^{-1} dt^{-1}$) @endtex
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: cflux_prod_l      !! Total annual release from decomposition of 
+                                                                              !! the long-lived product pool 
+                                                                              !! @tex ($gC m^{-1} dt^{-1}$) @endtex
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: prod_s_total      !! Total products remaining in the short-lived  
+                                                                              !! pool after the annual decomposition 
+                                                                              !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: prod_m_total      !! Total products remaining in the medium-lived
+                                                                              !! pool after the annual decomposition 
+                                                                              !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: prod_l_total      !! Total products remaining in the long-lived
+                                                                              !! pool after the annual release 
+                                                                              !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: cflux_prod_total  !! Total flux from decomposition of the short,
+                                                                              !! medium and long lived product pools 
+                                                                              !! @tex $(gC m^{-1} dt^{-1})$ @endtex
+
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION(:,0:), INTENT(inout)          :: prod_s            !! Short-lived product pool after the annual 
+                                                                              !! release of each compartment (short + 1 : 
+                                                                              !! input from year of land cover change) 
+                                                                              !! @tex ($gC pixel^{-1}$) @endtex    
+    REAL(r_std), DIMENSION(:,0:), INTENT(inout)          :: prod_m            !! Medium-lived product pool after the annual 
+                                                                              !! release of each compartment (medium + 1 : 
+                                                                              !! input from year of land cover change) 
+                                                                              !! @tex ($gC pixel^{-1}$) @endtex 
+    REAL(r_std), DIMENSION(:,0:), INTENT(inout)          :: prod_l            !! long-lived product pool after the annual 
+                                                                              !! release of each compartment (long + 1 : 
+                                                                              !! input from year of land cover change) 
+                                                                              !! @tex ($gC pixel^{-1}$) @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)           :: flux_s            !! Annual release from the short-lived product 
+                                                                              !! pool @tex $(gC) pixel^{-1} year^{-1}$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)           :: flux_m            !! Annual release from the medium-lived product  
+                                                                              !! pool @tex $(gC) pixel^{-1} year^{-1}$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)           :: flux_l            !! Annual release from the long-lived product
+                                                                              !! pool @tex $(gC) pixel^{-1} year^{-1}$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)       :: harvest_pool      !! The wood and biomass that have been
+                                                                              !! havested by humans @tex $(gC)$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)           :: harvest_type      !! Type of management that resulted
+                                                                              !! in the harvest (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)           :: harvest_cut       !! Type of cutting that was used for the harvest
+                                                                              !! (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)           :: harvest_area      !! Harvested area (m^{2})
+   
+
+    !! 0.4 Local variables
+ 
+    INTEGER(i_std)                                       :: ipts, ivm, iage   !! Indices (unitless)
+    INTEGER(i_std)                                       :: imbc              !! Indices (unitless)
+    REAL(r_std)                                          :: exported_biomass  !! Total biomass exported from the PFT (gC)
+    REAL(r_std)                                          :: residual          !! Residual @tex $(gC m^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements)   :: check_intern      !! Contains the components of the internal
+                                                                              !! mass balance chech for this routine
+                                                                              !! @tex $(gC m^{-2} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)           :: closure_intern    !! Check closure of internal mass balance
+                                                                              !! @tex $(gC m^{-2} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)           :: pool_start        !! Start pool of this routine 
+                                                                              !! @tex $(gC m^{-2} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)           :: pool_end          !! End pool of this routine 
+                                                                              !! @tex $(gC m^{-2} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts)                         :: pixel_area        !! surface area of the pixel @tex ($m^{2}$) @endtex
+!_ ================================================================================================================================    
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering basic product use'
+ 
+
+ !! 1. initialization
+
+    !! 1.1 Fluxes and pools
+    prod_s(:,0) = zero
+    prod_m(:,0) = zero
+    prod_l(:,0) = zero
+    prod_s_total(:) = zero
+    prod_m_total(:) = zero
+    prod_l_total(:) = zero   
+    cflux_prod_s(:) = zero
+    cflux_prod_m(:) = zero
+    cflux_prod_l(:) = zero
+    cflux_prod_total(:) = zero
+
+    !! 1.2 Pixel area
+    !  Surface area (m2) of the pixel
+    pixel_area(:) = resolution(:,1) * resolution(:,2)
+
+    !! 1.3 Mass balance closure
+    ! The biomass harvest pool shouldn't be multiplied by veget_max
+    ! its units are already in gC pixel-1. The total amount for the 
+    ! pixel was stored in harvest_pool. Account for the harvest and
+    ! wood product pools. There are no longer PFTs 
+    pool_start(:,:,:) = zero
+    pool_start(:,1,icarbon) = &
+         ( SUM(SUM(harvest_pool(:,:,:,icarbon),3),2) + &
+         SUM(prod_l(:,:),2) + SUM(prod_m(:,:),2) + &
+         SUM(prod_s(:,:),2) )/pixel_area(:)
+
+    !! 1.4 Logical check of coeff_lcchange
+    !  Within a PFT the coeff_lcchange should add up to one. Else the 
+    !  carbon balance will not be closed! Do not include PFT 1 in this 
+    !  check because its coeff_lcchange were set to undef (-9999).
+    DO ivm = 2,nvm
+
+       IF ( (coeff_lcchange_s(ivm) + coeff_lcchange_m(ivm) + &
+            coeff_lcchange_l(ivm) .LT. un - min_stomate) .OR. &
+            (coeff_lcchange_s(ivm) + coeff_lcchange_m(ivm) + &
+            coeff_lcchange_l(ivm) .GT. un + min_stomate) ) THEN
+
+          WRITE(numout,*) 'Error: coeff_lcchange in sapiens_product_use.f90 ' //&
+               'do not add up to 1 in PFT - cannot close the mass balance, ',ivm
+          STOP
+         
+
+       ENDIF
+
+    ENDDO
+
+
+ !! 2. Partition harvest in a short, medium and long-lived product pool
+
+    DO ipts = 1,npts
+
+       !! 2.1 Calculate the initial mass of the product pool (gC)
+       DO ivm = 2,nvm
+  
+          !+++NOTE+++
+          ! For the moment all harvest is lumped together and we don't 
+          ! make use of harvest_type and harvest_cut to refine the product
+          ! use. If these variables are to be used be aware that for the
+          ! moment these values can be overwritten within a simulation.
+          ! Although the sequence of the calls in stomate_lpj is believed
+          ! to protect against this, it is not enforced by the code. For
+          ! example, if we first thin and then harvest, wood of both
+          ! actions will be stored in the harvest pool but it will be 
+          ! recored as just harvest (thinning will be overwritten by harvest)
+          exported_biomass = SUM(harvest_pool(ipts,ivm,:,icarbon))
+          !+++++++++++
+
+          ! Attribute the harvested biomass to pools with a different 
+          ! turnover time. The turnover times are PFT depend which 
+          ! accounts for the different uses different PFT's are put to i.e. 
+          ! wood from forests vs grass or crops. The values stored in 
+          ! harvest_pool are absolute numbers gC (for that pixel), hence, 
+          ! the spatial extent of the LCC change, harvest or thinning has 
+          ! already been accounted for.
+          prod_s(ipts,0) = prod_s(ipts,0) + &
+               (coeff_lcchange_s(ivm) * exported_biomass)
+          prod_m(ipts,0) = prod_m(ipts,0) + &
+               (coeff_lcchange_m(ivm) * exported_biomass)
+          prod_l(ipts,0) = prod_l(ipts,0) + &
+               (coeff_lcchange_l(ivm) * exported_biomass)
+
+       ENDDO
+
+       !! 2.2 Check whether all the harvest was used as is to be expected
+       !  The precision we are aiming for is 10-8 per m-2. The harvest pool
+       !  is expressed for the whole pixel
+       residual = SUM(SUM(harvest_pool(ipts,:,:,icarbon),2)) - &
+            prod_s(ipts,0) - prod_m(ipts,0) - prod_l(ipts,0)
+            
+       IF (residual/pixel_area(ipts) .GT. min_stomate .OR. &
+            residual/pixel_area(ipts) .LT. - min_stomate) THEN
+          
+          WRITE (numout,*) 'Error: some harvest in sapiens_product_use has '//&
+               'not been attributed'
+          WRITE (numout,*) 'Residual in pixel, ', ipts, residual
+          STOP
+          
+       ELSE
+
+          ! We could still have residual within the precision at the 
+          ! m2 level but outside the precision at the pixel level. 
+          ! Move the residual to the short lived pool
+          prod_s(ipts,0) = prod_s(ipts,0) + residual
+
+          ! All the carbon in the harvest pool was allocated to the product 
+          ! pools the harvest pool can be set to zero so we can us it with 
+          ! confidence in the mass balance calculation
+          harvest_pool(ipts,:,:,icarbon) = zero
+          harvest_type(ipts,:) = zero
+          harvest_cut(ipts,:) = zero
+          harvest_area(ipts,:) = zero
+
+       ENDIF 
+    
+
+       !! 2.3 Update the long-turnover pool content
+       !  Update the long-turnover pool content following flux emission
+       !  of a linear decay (1/longivety) of the initial carbon input.
+       !  This must be implemented with a counter going from ::nlong to 
+       !  zero because this way it takes ::nlong years before the intial 
+       !  pool has been entirely consumed. If a more intuitive approach 
+       !  would have been used in which the counter goes from zero to
+       !  ::nlong, the pool would be depleted in the first year.
+       !  Update the long-turnover pool content following flux emission.
+       DO iage = nlong,2,-1
+
+          ! flux and prod are large numbers. At the last time step 10-5
+          ! gC remains which is outside the precision. Therefore, this 
+          ! carbon is moved to the flux 
+          IF (iage .EQ. nlong) THEN
+              
+              cflux_prod_l(ipts) = cflux_prod_l(ipts) + prod_l(ipts,iage-1)
+              flux_l(ipts,iage) = prod_l(ipts,iage-1)
+              prod_l(ipts,iage) = zero
+
+          ELSE
+          
+             ! ::flux_l has INTENT(inout), it thus has the value from the 
+             ! previuous year at the start of these calculations. Copy
+             ! the flux from the previous year to this year and update
+             ! the product pool
+             cflux_prod_l(ipts) = cflux_prod_l(ipts) + flux_l(ipts,iage)
+             prod_l(ipts,iage) = prod_l(ipts,iage-1) - flux_l(ipts,iage-1)
+             flux_l(ipts,iage) = flux_l(ipts,iage-1)
+ 
+          ENDIF
+          
+       ENDDO
+
+       ! Treat the first year separately because it is not included in 
+       ! the loop above
+       cflux_prod_l(ipts) = cflux_prod_l(ipts) + flux_l(ipts,1)
+
+       ! Each year 1/::nlong of the initial pool is decomposed. This fixed
+       ! amount of decomposition is moved to a higher age class each year. 
+       ! The units of ::flux_m are gC (absolute number as is the product 
+       ! pool). At this point in the calculation, the flux is NOT a flux 
+       ! yet but is also a pool 
+       flux_l(ipts,1) = (un/nlong) * prod_l(ipts,0)
+       prod_l(ipts,1) = prod_l(ipts,0) - flux_l(ipts,1)
+       prod_l(ipts,0) = zero
+
+       !! 2.4 Update the medium-turnover pool content 
+       !  Update the medium-turnover pool content following flux emission.
+       !  For comments see the section above. The concept is identical. 
+       DO iage = nmedium,2,-1
+
+          IF (iage .EQ. nmedium) THEN
+              
+              cflux_prod_m(ipts) = cflux_prod_m(ipts) + prod_m(ipts,iage-1)
+              flux_m(ipts,iage) = prod_m(ipts,iage-1)
+              prod_m(ipts,iage) = zero
+
+          ELSE
+
+             cflux_prod_m(ipts) = cflux_prod_m(ipts) + flux_m(ipts,iage)
+             prod_m(ipts,iage) = prod_m(ipts,iage-1) - flux_m(ipts,iage-1)
+             flux_m(ipts,iage) = flux_m(ipts,iage-1)
+         
+          ENDIF
+
+       ENDDO
+     
+       cflux_prod_m(ipts) = cflux_prod_m(ipts) + flux_m(ipts,1)
+       flux_m(ipts,1) = (un/nmedium) * prod_m(ipts,0)
+       prod_m(ipts,1) = prod_m(ipts,0) - flux_m(ipts,1)
+       prod_m(ipts,0) = zero
+
+       !! 2.5 Update the short-turnover pool
+       !  The length of the short-turnover pool will most likely be
+       !  less than length of the regular loop. The regular loop is
+       !  now conditional. 
+       !  NOTE: this code has only been tested for nshort = 1 and 
+       !  nshort = 2
+       IF (nshort .GE. 4) THEN
+
+          DO iage = nshort,2,-1
+
+             IF (iage .EQ. nshort) THEN
+              
+                cflux_prod_s(ipts) = cflux_prod_s(ipts) + prod_s(ipts,iage-1)
+                flux_s(ipts,iage) = prod_s(ipts,iage-1)
+                prod_s(ipts,iage) = zero
+
+             ELSE
+  
+                cflux_prod_s(ipts) = cflux_prod_s(ipts) + flux_s(ipts,iage)
+                prod_s(ipts,iage) = prod_s(ipts,iage-1) - flux_s(ipts,iage-1)
+                flux_s(ipts,iage) = flux_s(ipts,iage-1)
+
+             ENDIF
+
+          ENDDO
+
+          cflux_prod_s(ipts) = cflux_prod_s(ipts) + flux_s(ipts,1) 
+          flux_s(ipts,1) = (un/nshort) * prod_s(ipts,0)
+          prod_s(ipts,1) = prod_s(ipts,0) - flux_s(ipts,1)
+          prod_s(ipts,0) = zero
+
+       ELSEIF (nshort .EQ. 3) THEN
+
+          ! Decompose the product pool from the last year
+          cflux_prod_s(ipts) = cflux_prod_s(ipts) + prod_s(ipts,2)
+          flux_s(ipts,3) = prod_s(ipts,2)
+          prod_s(ipts,3) = zero
+          cflux_prod_s(ipts) = cflux_prod_s(ipts) + flux_s(ipts,2)
+          prod_s(ipts,2) = prod_s(ipts,1) - flux_s(ipts,1)
+          flux_s(ipts,2) = flux_s(ipts,1)
+
+          ! Calculate the linear product decomposition for this
+          ! year's harvest
+          cflux_prod_s(ipts) = cflux_prod_s(ipts) + flux_s(ipts,1) 
+          flux_s(ipts,1) = (un/nshort) * prod_s(ipts,0)
+          prod_s(ipts,1) = prod_s(ipts,0) - flux_s(ipts,1)
+          prod_s(ipts,0) = zero
+
+       ELSEIF (nshort .EQ. 2) THEN
+
+          ! Decompose the product pool from last year
+          cflux_prod_s(ipts) = cflux_prod_s(ipts) + prod_s(ipts,1)
+          flux_s(ipts,2) = prod_s(ipts,1)
+          prod_s(ipts,2) = zero
+
+          ! Calculate the linear product decomposition for this
+          ! year's harvest
+          cflux_prod_s(ipts) = cflux_prod_s(ipts) + flux_s(ipts,1) 
+          flux_s(ipts,1) = (un/nshort) * prod_s(ipts,0)
+          prod_s(ipts,1) = prod_s(ipts,0) - flux_s(ipts,1)
+          prod_s(ipts,0) = zero
+
+       ELSEIF (nshort .EQ. 1) THEN
+
+          ! Everything decomposes in a single year. The short product
+          ! pool remains empty.
+          cflux_prod_s(ipts) = cflux_prod_s(ipts) + prod_s(ipts,0) 
+          flux_s(ipts,1) = prod_s(ipts,0)
+          prod_s(ipts,1) = zero
+          prod_s(ipts,0) = zero
+
+       ELSE
+
+          WRITE(numout,*) 'Error: flaw in the logic of IF-construct '//&
+               '(basic_product_use in sapiens_product_use.f90)' 
+
+       ENDIF ! number of ages in short-turnover product pool
+
+    ENDDO ! #pixels - spatial domain  
+
+
+ !! 3. Check mass balance closure 
+
+    !! 3.1 Calculate pools at the end of the routine
+    ! The biomass harvest pool shouldn't be multiplied by veget_max
+    ! its in gC pixel-1 so divide by pixel_area to get a value in
+    ! gC m-2. Account for the harvest and wood product pools. The harvest 
+    ! pool should be empty, it was added for completeness.
+    closure_intern = zero
+    pool_end = zero
+    pool_end(:,1,icarbon) = &
+         ( SUM(SUM(harvest_pool(:,:,:,icarbon),3),2) + &
+         SUM(prod_l(:,:),2) + SUM(prod_m(:,:),2) + &
+         SUM(prod_s(:,:),2) ) / pixel_area(:)
+
+    !! 3.2 Calculate components of the mass balance
+    check_intern(:,1,iatm2land,icarbon) = zero
+    check_intern(:,1,iland2atm,icarbon) = -un * ( SUM(flux_s(:,:),2) + &
+         SUM(flux_m(:,:),2) + SUM(flux_l(:,:),2) ) / pixel_area(:)
+    check_intern(:,1,ilat2out,icarbon) = zero
+    check_intern(:,1,ilat2in,icarbon) = -un * zero
+    check_intern(:,1,ipoolchange,icarbon) = -un * (pool_end(:,1,icarbon) - &
+         pool_start(:,1,icarbon))
+    DO imbc = 1,nmbcomp
+       closure_intern(:,1,icarbon) = closure_intern(:,1,icarbon) + &
+            check_intern(:,1,imbc,icarbon)
+    ENDDO
+
+    ! 3.3 Write outcome
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          IF(ABS(closure_intern(ipts,ivm,icarbon)) .LE. min_stomate)THEN
+             IF (ld_massbal) WRITE(numout,*) 'Mass balance closure in basic_product_use'
+          ELSE
+             WRITE(numout,*) 'Error: mass balance is not closed in basic_product_use'
+             WRITE(numout,*) '   ipts,ivm; ', ipts,ivm
+             WRITE(numout,*) '   Difference is, ', closure_intern(ipts,ivm,icarbon)
+             WRITE(numout,*) '   pool_end,pool_start: ', pool_end(ipts,ivm,icarbon), pool_start(ipts,ivm,icarbon)
+             WRITE(numout,*) '   fluxes: ', flux_s(ipts,ivm),flux_m(ipts,ivm),flux_l(ipts,ivm)
+             WRITE(numout,*) '   pixel_area: ', pixel_area(ipts)
+             IF(ld_stop)THEN
+                CALL ipslerr_p (3,'basic_product_use', 'Mass balance error.','','')
+             ENDIF
+          ENDIF
+       ENDDO
+    ENDDO
+
+ !! 4. Convert the pools into fluxes and aggregate
+
+    !  Convert pools into fluxes
+    !  The pools are given in the absolute amount of carbon for the whole pixel
+    !  and the harvest was accumulated over the year. The unit is thus 
+    !  gc pixel-1 year-1. These fluxes should be expressed as gC m-2 dt-1. Therefore,
+    !  divide by the resolution of the pixel and the number of time steps within 
+    !  a year
+    cflux_prod_s(:) = cflux_prod_s(:) / one_year * dt_days / pixel_area(:) 
+    cflux_prod_m(:) = cflux_prod_m(:) / one_year * dt_days / pixel_area(:) 
+    cflux_prod_l(:) = cflux_prod_l(:) / one_year * dt_days / pixel_area(:) 
+
+    ! Calculate aggregate values
+    ! cflux_prod_total is now in gC m-2 dt-1. The prod_x_total are in gC m-2 
+    cflux_prod_total(:) = cflux_prod_s(:) + cflux_prod_m(:) + cflux_prod_l(:)
+    prod_s_total(:) = SUM(prod_s(:,:),2) / pixel_area(:)
+    prod_m_total(:) = SUM(prod_m(:,:),2) / pixel_area(:) 
+    prod_l_total(:) = SUM(prod_l(:,:),2) / pixel_area(:) 
+
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving basic product use'
+
+
+  END SUBROUTINE basic_product_use
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : dim_product_use
+!!
+!>\BRIEF        Calculate the C stored in biomass-based products and the 
+!!              CO2 release through their decomposition. 
+!!
+!! DESCRIPTION  : The basic approach distinguished 3 pools (as introduced by
+!! Shilong Piao based on Houghton. Wood harvest with small dimensions is being 
+!! used as fire wood the remaining wood goes into the short, medium and long 
+!! product pools. This implies that when the dimensions of the harvest change, 
+!! the product pools will change as well.\n
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : prod_s, prod_m, prod_l, flux_s, flux_m, flux_l,
+!!   cflux_prod_s cflux_prod_m and cflux_prod1_l 
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!!
+!_ ================================================================================================================================
+
+ SUBROUTINE dim_product_use(npts, dt_days, harvest_pool_bound, harvest_pool, &
+            harvest_type, harvest_cut, harvest_area, &
+            cflux_prod_s, cflux_prod_m, cflux_prod_l, prod_s, &
+            prod_m, prod_l, prod_s_total, prod_m_total, &
+            prod_l_total, cflux_prod_total, flux_s, flux_m, &
+            flux_l, resolution)
+
+   IMPLICIT NONE
+
+
+ !! 0. Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+   
+    INTEGER, INTENT(in)                                  :: npts              !! Domain size - number of pixels (unitless)
+    REAL(r_std), INTENT(in)                              :: dt_days           !! Time step of vegetation dynamics for stomate
+                                                                              !! (days)
+    REAL(r_std),DIMENSION(:,:), INTENT(in)               :: resolution        !! The length in m of each grid-box in X and Y
+    REAL(r_std), DIMENSION(:), INTENT(in)                :: harvest_pool_bound!! The boundaries of the diameter classes
+                                                                              !! in the wood harvest pools @tex $(m)$ @endtex
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: cflux_prod_s      !! C-released during first years (short term) 
+                                                                              !! following land cover change 
+                                                                              !! @tex ($gC m^{-1} dt^{-1}$) @endtex 
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: cflux_prod_m      !! Total annual release from decomposition of 
+                                                                              !! the medium-lived product pool 
+                                                                              !! @tex ($gC m^{-1} dt^{-1}$) @endtex
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: cflux_prod_l      !! Total annual release from decomposition of 
+                                                                              !! the long-lived product pool 
+                                                                              !! @tex ($gC m^{-1} dt^{-1}$) @endtex
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: prod_s_total      !! Total products remaining in the short-lived  
+                                                                              !! pool after the annual decomposition 
+                                                                              !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: prod_m_total      !! Total products remaining in the medium-lived
+                                                                              !! pool after the annual decomposition 
+                                                                              !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: prod_l_total      !! Total products remaining in the long-lived
+                                                                              !! pool after the annual release 
+                                                                              !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: cflux_prod_total  !! Total flux from decomposition of the short,
+                                                                              !! medium and long lived product pools 
+                                                                              !! @tex $(gC m^{-1} dt^{-1})$ @endtex
+
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION(:,0:), INTENT(inout)          :: prod_s            !! Short-lived product pool after the annual 
+                                                                              !! release of each compartment (short + 1 : 
+                                                                              !! input from year of land cover change) 
+                                                                              !! @tex ($gC pixel^{-1}$) @endtex    
+    REAL(r_std), DIMENSION(:,0:), INTENT(inout)          :: prod_m            !! Medium-lived product pool after the annual 
+                                                                              !! release of each compartment (medium + 1 : 
+                                                                              !! input from year of land cover change) 
+                                                                              !! @tex ($gC pixel^{-1}$) @endtex 
+    REAL(r_std), DIMENSION(:,0:), INTENT(inout)          :: prod_l            !! long-lived product pool after the annual 
+                                                                              !! release of each compartment (long + 1 : 
+                                                                              !! input from year of land cover change) 
+                                                                              !! @tex ($gC pixel^{-1}$) @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)           :: flux_s            !! Annual release from the short-lived product 
+                                                                              !! pool @tex $(gC) pixel^{-1} year^{-1}$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)           :: flux_m            !! Annual release from the medium-lived product  
+                                                                              !! pool @tex $(gC) pixel^{-1} year^{-1}$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)           :: flux_l            !! Annual release from the long-lived product
+                                                                              !! pool @tex $(gC) pixel^{-1} year^{-1}$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)       :: harvest_pool      !! The wood and biomass that have been
+                                                                              !! havested by humans @tex $(gC)$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)           :: harvest_type      !! Type of management that resulted
+                                                                              !! in the harvest (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)           :: harvest_cut       !! Type of cutting that was used for the harvest
+                                                                              !! (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)           :: harvest_area      !! Harvested area (m^{2})
+   
+
+    !! 0.4 Local variables
+ 
+    INTEGER(i_std)                                       :: ipts, ivm, iage   !! Indices (unitless)
+    INTEGER(i_std)                                       :: imbc, idia        !! Indices (unitless)
+    REAL(r_std)                                          :: exported_biomass  !! Total biomass exported from the PFT (gC)
+    REAL(r_std)                                          :: fuelwood_biomass  !! Harvest with small dimensions that will
+                                                                              !! be used as fire wood (gC)
+    REAL(r_std)                                          :: timber_biomass    !! Harvest with larger dimensions that will
+                                                                              !! be used for all kinds of uses (gC)
+    REAL(r_std)                                          :: residual          !! Residual @tex $(gC m^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements)   :: check_intern      !! Contains the components of the internal
+                                                                              !! mass balance chech for this routine
+                                                                              !! @tex $(gC m^{-2} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)           :: closure_intern    !! Check closure of internal mass balance
+                                                                              !! @tex $(gC m^{-2} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)           :: pool_start        !! Start pool of this routine 
+                                                                              !! @tex $(gC m^{-2} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)           :: pool_end          !! End pool of this routine 
+                                                                              !! @tex $(gC m^{-2} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts)                         :: pixel_area        !! surface area of the pixel @tex ($m^{2}$) @endtex
+!_ ================================================================================================================================    
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering basic product use'
+ 
+
+ !! 1. initialization
+
+    !! 1.1 Fluxes and pools
+    prod_s(:,0) = zero
+    prod_m(:,0) = zero
+    prod_l(:,0) = zero
+    prod_s_total(:) = zero
+    prod_m_total(:) = zero
+    prod_l_total(:) = zero   
+    cflux_prod_s(:) = zero
+    cflux_prod_m(:) = zero
+    cflux_prod_l(:) = zero
+    cflux_prod_total(:) = zero
+
+    !! 1.2 Pixel area
+    !  Surface area (m2) of the pixel
+    pixel_area(:) = resolution(:,1) * resolution(:,2)
+
+    !! 1.3 Mass balance closure
+    ! The biomass harvest pool shouldn't be multiplied by veget_max
+    ! its units are already in gC pixel-1. The total amount for the 
+    ! pixel was stored in harvest_pool. Account for the harvest and
+    ! wood product pools. There are no longer PFTs 
+    pool_start(:,:,:) = zero
+    pool_start(:,1,icarbon) = &
+         ( SUM(SUM(harvest_pool(:,:,:,icarbon),3),2) + &
+         SUM(prod_l(:,:),2) + SUM(prod_m(:,:),2) + &
+         SUM(prod_s(:,:),2) )/pixel_area(:)
+
+    !! 1.4 Logical check of coeff_lcchange
+    !  Within a PFT the coeff_lcchange should add up to one. Else the 
+    !  carbon balance will not be closed! Do not include PFT 1 in this 
+    !  check because its coeff_lcchange were set to undef (-9999).
+    DO ivm = 2,nvm
+
+       IF ( (coeff_lcchange_s(ivm) + coeff_lcchange_m(ivm) + &
+            coeff_lcchange_l(ivm) .LT. un - min_stomate) .OR. &
+            (coeff_lcchange_s(ivm) + coeff_lcchange_m(ivm) + &
+            coeff_lcchange_l(ivm) .GT. un + min_stomate) ) THEN
+
+          WRITE(numout,*) 'Error: coeff_lcchange in sapiens_product_use.f90 ' //&
+               'do not add up to 1 in PFT - cannot close the mass balance, ',ivm
+          STOP
+         
+       ENDIF
+
+    ENDDO
+
+
+ !! 2. Partition harvest in a short, medium and long-lived product pool
+
+    DO ipts = 1,npts
+
+       !! 2.1 Calculate the initial mass of the product pool (gC)
+       DO ivm = 2,nvm
+
+          !+++NOTE+++
+          ! For the moment all harvest is lumped together and we don't 
+          ! make use of harvest_type and harvest_cut to refine the product
+          ! use. If these variables are to be used be aware that for the
+          ! moment these values can be overwritten within a simulation.
+          ! Although the sequence of the calls in stomate_lpj is believed
+          ! to protect against this, it is not enforced by the code. For
+          ! example, if we first thin and then harvest, wood of both
+          ! actions will be stored in the harvest pool but it will be 
+          ! recored as just harvest (thinning will be overwritten by 
+          ! harvest and no warning will be given)
+          !++++++++++
+          fuelwood_biomass = zero
+          timber_biomass = zero
+ 
+          ! Grasses and crops
+          IF (fuelwood_diameter(ivm) .LT. min_stomate) THEN
+
+             !Grasses and crops do not provide fuelwood. They do have
+             ! a very short turnover time. The values stored in 
+             ! harvest_pool are absolute numbers gC (for that pixel), hence, 
+             ! the spatial extent of the LCC change, harvest or thinning has 
+             ! already been accounted for.
+             exported_biomass = SUM(harvest_pool(ipts,ivm,:,icarbon))
+             prod_s(ipts,0) = prod_s(ipts,0) + &
+               (coeff_lcchange_s(ivm) * exported_biomass)
+             prod_m(ipts,0) = prod_m(ipts,0) + &
+               (coeff_lcchange_m(ivm) * exported_biomass)
+             prod_l(ipts,0) = prod_l(ipts,0) + &
+               (coeff_lcchange_l(ivm) * exported_biomass)
+
+          ! Forests
+          ELSE
+
+             ! This is a woody PFT, check the diameter of the harvested wood
+             timber_biomass = SUM(harvest_pool(ipts,ivm,:,icarbon))
+             DO idia = 1,ndia_harvest
+
+                IF (harvest_pool_bound(idia) .LT. fuelwood_diameter(ivm)) THEN
+
+                   ! If the diameter of the harvest pool is below the treshold
+                   ! the wood is used as fuelwood and will end up in the short
+                   ! lived pool
+                   fuelwood_biomass = fuelwood_biomass + & 
+                        harvest_pool(ipts,ivm,idia,icarbon)
+
+                ENDIF
+
+             ENDDO ! harvest diameter
+
+             ! Calculate the long lived pools as the residual of all
+             ! wood mines the fuel wood.
+             timber_biomass = timber_biomass - fuelwood_biomass
+
+             ! Attribute the harvested biomass to pools with a different 
+             ! turnover time. The turnover times are PFT depend which 
+             ! accounts for the different uses different PFT's are put to i.e. 
+             ! wood from forests vs grass or crops. The values stored in 
+             ! harvest_pool are absolute numbers gC (for that pixel), hence, 
+             ! the spatial extent of the LCC change, harvest or thinning has 
+             ! already been accounted for.
+             prod_s(ipts,0) = prod_s(ipts,0) + fuelwood_biomass
+             IF  (coeff_lcchange_m(ivm) + coeff_lcchange_l(ivm) .GT. &
+                  min_stomate) THEN
+
+                ! If the condition is satisfied, calculate the fractions
+                ! if it is not satisfied there is no medium and long lived
+                ! pool for the products. Nothing should then be done. Avoid
+                ! divide by zero
+                prod_m(ipts,0) = prod_m(ipts,0) + &
+                     (coeff_lcchange_m(ivm)/ &
+                     (coeff_lcchange_m(ivm)+coeff_lcchange_l(ivm)) * &
+                     timber_biomass)
+                prod_l(ipts,0) = prod_l(ipts,0) + &
+                     (coeff_lcchange_l(ivm)/ &
+                     (coeff_lcchange_m(ivm)+coeff_lcchange_l(ivm)) * &
+                     timber_biomass)
+
+             ENDIF ! Check coeff_lcchange
+
+          ENDIF ! grasses/crops vs forests
+
+       ENDDO ! loop over PFTs 
+
+       !! 2.2 Check whether all the harvest was used as is to be expected
+       !  The precision we are aiming for is 10-8 per m-2. The harvest pool
+       !  is expressed for the whole pixel
+       residual = SUM(SUM(harvest_pool(ipts,:,:,icarbon),2)) - &
+            prod_s(ipts,0) - prod_m(ipts,0) - prod_l(ipts,0)
+            
+       IF (residual/pixel_area(ipts) .GT. min_stomate .OR. &
+            residual/pixel_area(ipts) .LT. - min_stomate) THEN
+          
+          WRITE (numout,*) 'Error: some harvest in sapiens_product_use has '//&
+               'not been attributed'
+          WRITE (numout,*) 'Residual in pixel, ', ipts, residual
+          STOP
+          
+       ELSE
+
+          ! We could still have residual within the precision at the 
+          ! m2 level but outside the precision at the pixel level. 
+          ! Move the residual to the short lived pool
+          prod_s(ipts,0) = prod_s(ipts,0) + residual
+
+          ! All the carbon in the harvest pool was allocated to the product 
+          ! pools the harvest pool can be set to zero so we can us it with 
+          ! confidence in the mass balance calculation
+          harvest_pool(ipts,:,:,icarbon) = zero
+          harvest_type(ipts,:) = zero
+          harvest_cut(ipts,:) = zero
+          harvest_area(ipts,:) = zero
+
+       ENDIF 
+    
+
+       !! 2.3 Update the long-turnover pool content
+       !  Update the long-turnover pool content following flux emission
+       !  of a linear decay (1/longivety) of the initial carbon input.
+       !  This must be implemented with a counter going from ::nlong to 
+       !  zero because this way it takes ::nlong years before the intial 
+       !  pool has been entirely consumed. If a more intuitive approach 
+       !  would have been used in which the counter goes from zero to
+       !  ::nlong, the pool would be depleted in the first year.
+       !  Update the long-turnover pool content following flux emission.
+       DO iage = nlong,2,-1
+
+          ! flux and prod are large numbers. At the last time step 10-5
+          ! gC remains which is outside the precision. Therefore, this 
+          ! carbon is moved to the flux 
+          IF (iage .EQ. nlong) THEN
+              
+              cflux_prod_l(ipts) = cflux_prod_l(ipts) + prod_l(ipts,iage-1)
+              flux_l(ipts,iage) = prod_l(ipts,iage-1)
+              prod_l(ipts,iage) = zero
+
+          ELSE
+          
+             ! ::flux_l has INTENT(inout), it thus has the value from the 
+             ! previuous year at the start of these calculations. Copy
+             ! the flux from the previous year to this year and update
+             ! the product pool
+             cflux_prod_l(ipts) = cflux_prod_l(ipts) + flux_l(ipts,iage)
+             prod_l(ipts,iage) = prod_l(ipts,iage-1) - flux_l(ipts,iage-1)
+             flux_l(ipts,iage) = flux_l(ipts,iage-1)
+ 
+          ENDIF
+          
+       ENDDO
+
+       ! Treat the first year separately because it is not included in 
+       ! the loop above
+       cflux_prod_l(ipts) = cflux_prod_l(ipts) + flux_l(ipts,1)
+
+       ! Each year 1/::nlong of the initial pool is decomposed. This fixed
+       ! amount of decomposition is moved to a higher age class each year. 
+       ! The units of ::flux_m are gC (absolute number as is the product 
+       ! pool). At this point in the calculation, the flux is NOT a flux 
+       ! yet but is also a pool 
+       flux_l(ipts,1) = (un/nlong) * prod_l(ipts,0)
+       prod_l(ipts,1) = prod_l(ipts,0) - flux_l(ipts,1)
+       prod_l(ipts,0) = zero
+
+       !! 2.4 Update the medium-turnover pool content 
+       !  Update the medium-turnover pool content following flux emission.
+       !  For comments see the section above. The concept is identical. 
+       DO iage = nmedium,2,-1
+
+          IF (iage .EQ. nmedium) THEN
+              
+              cflux_prod_m(ipts) = cflux_prod_m(ipts) + prod_m(ipts,iage-1)
+              flux_m(ipts,iage) = prod_m(ipts,iage-1)
+              prod_m(ipts,iage) = zero
+
+          ELSE
+
+             cflux_prod_m(ipts) = cflux_prod_m(ipts) + flux_m(ipts,iage)
+             prod_m(ipts,iage) = prod_m(ipts,iage-1) - flux_m(ipts,iage-1)
+             flux_m(ipts,iage) = flux_m(ipts,iage-1)
+         
+          ENDIF
+
+       ENDDO
+     
+       cflux_prod_m(ipts) = cflux_prod_m(ipts) + flux_m(ipts,1)
+       flux_m(ipts,1) = (un/nmedium) * prod_m(ipts,0)
+       prod_m(ipts,1) = prod_m(ipts,0) - flux_m(ipts,1)
+       prod_m(ipts,0) = zero
+
+       !! 2.5 Update the short-turnover pool
+       !  The length of the short-turnover pool will most likely be
+       !  less than length of the regular loop. The regular loop is
+       !  now conditional. 
+       !  NOTE: this code has only been tested for nshort = 1 and 
+       !  nshort = 2
+       IF (nshort .GE. 4) THEN
+
+          DO iage = nshort,2,-1
+
+             IF (iage .EQ. nshort) THEN
+              
+                cflux_prod_s(ipts) = cflux_prod_s(ipts) + prod_s(ipts,iage-1)
+                flux_s(ipts,iage) = prod_s(ipts,iage-1)
+                prod_s(ipts,iage) = zero
+
+             ELSE
+  
+                cflux_prod_s(ipts) = cflux_prod_s(ipts) + flux_s(ipts,iage)
+                prod_s(ipts,iage) = prod_s(ipts,iage-1) - flux_s(ipts,iage-1)
+                flux_s(ipts,iage) = flux_s(ipts,iage-1)
+
+             ENDIF
+
+          ENDDO
+
+          cflux_prod_s(ipts) = cflux_prod_s(ipts) + flux_s(ipts,1) 
+          flux_s(ipts,1) = (un/nshort) * prod_s(ipts,0)
+          prod_s(ipts,1) = prod_s(ipts,0) - flux_s(ipts,1)
+          prod_s(ipts,0) = zero
+
+       ELSEIF (nshort .EQ. 3) THEN
+
+          ! Decompose the product pool from the last year
+          cflux_prod_s(ipts) = cflux_prod_s(ipts) + prod_s(ipts,2)
+          flux_s(ipts,3) = prod_s(ipts,2)
+          prod_s(ipts,3) = zero
+          cflux_prod_s(ipts) = cflux_prod_s(ipts) + flux_s(ipts,2)
+          prod_s(ipts,2) = prod_s(ipts,1) - flux_s(ipts,1)
+          flux_s(ipts,2) = flux_s(ipts,1)
+
+          ! Calculate the linear product decomposition for this
+          ! year's harvest
+          cflux_prod_s(ipts) = cflux_prod_s(ipts) + flux_s(ipts,1) 
+          flux_s(ipts,1) = (un/nshort) * prod_s(ipts,0)
+          prod_s(ipts,1) = prod_s(ipts,0) - flux_s(ipts,1)
+          prod_s(ipts,0) = zero
+
+       ELSEIF (nshort .EQ. 2) THEN
+
+          ! Decompose the product pool from last year
+          cflux_prod_s(ipts) = cflux_prod_s(ipts) + prod_s(ipts,1)
+          flux_s(ipts,2) = prod_s(ipts,1)
+          prod_s(ipts,2) = zero
+
+          ! Calculate the linear product decomposition for this
+          ! year's harvest
+          cflux_prod_s(ipts) = cflux_prod_s(ipts) + flux_s(ipts,1) 
+          flux_s(ipts,1) = (un/nshort) * prod_s(ipts,0)
+          prod_s(ipts,1) = prod_s(ipts,0) - flux_s(ipts,1)
+          prod_s(ipts,0) = zero
+
+       ELSEIF (nshort .EQ. 1) THEN
+
+          ! Everything decomposes in a single year. The short product
+          ! pool remains empty.
+          cflux_prod_s(ipts) = cflux_prod_s(ipts) + prod_s(ipts,0) 
+          flux_s(ipts,1) = prod_s(ipts,0)
+          prod_s(ipts,1) = zero
+          prod_s(ipts,0) = zero
+
+       ELSE
+
+          WRITE(numout,*) 'Error: flaw in the logic of IF-construct '//&
+               '(basic_product_use in sapiens_product_use.f90)' 
+
+       ENDIF ! number of ages in short-turnover product pool
+
+    ENDDO ! #pixels - spatial domain  
+
+
+ !! 3. Check mass balance closure 
+
+    !! 3.1 Calculate pools at the end of the routine
+    ! The biomass harvest pool shouldn't be multiplied by veget_max
+    ! its in gC pixel-1 so divide by pixel_area to get a value in
+    ! gC m-2. Account for the harvest and wood product pools. The harvest 
+    ! pool should be empty, it was added for completeness.
+    closure_intern = zero
+    pool_end = zero
+    pool_end(:,1,icarbon) = &
+         ( SUM(SUM(harvest_pool(:,:,:,icarbon),3),2) + &
+         SUM(prod_l(:,:),2) + SUM(prod_m(:,:),2) + &
+         SUM(prod_s(:,:),2) ) / pixel_area(:)
+
+    !! 3.2 Calculate components of the mass balance
+    check_intern(:,1,iatm2land,icarbon) = zero
+    check_intern(:,1,iland2atm,icarbon) = -un * ( SUM(flux_s(:,:),2) + &
+         SUM(flux_m(:,:),2) + SUM(flux_l(:,:),2) ) / pixel_area(:)
+    check_intern(:,1,ilat2out,icarbon) = zero
+    check_intern(:,1,ilat2in,icarbon) = -un * zero
+    check_intern(:,1,ipoolchange,icarbon) = -un * (pool_end(:,1,icarbon) - &
+         pool_start(:,1,icarbon))
+    DO imbc = 1,nmbcomp
+       closure_intern(:,1,icarbon) = closure_intern(:,1,icarbon) + &
+            check_intern(:,1,imbc,icarbon)
+    ENDDO
+
+    ! 3.3 Write outcome
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          IF(ABS(closure_intern(ipts,ivm,icarbon)) .LE. min_stomate)THEN
+             IF (ld_massbal) WRITE(numout,*) 'Mass balance closure in basic_product_use'
+          ELSE
+             WRITE(numout,*) 'Error: mass balance is not closed in basic_product_use'
+             WRITE(numout,*) '   ipts,ivm; ', ipts,ivm
+             WRITE(numout,*) '   Difference is, ', closure_intern(ipts,ivm,icarbon)
+             WRITE(numout,*) '   pool_end,pool_start: ', pool_end(ipts,ivm,icarbon), pool_start(ipts,ivm,icarbon)
+             WRITE(numout,*) '   fluxes: ', flux_s(ipts,ivm),flux_m(ipts,ivm),flux_l(ipts,ivm)
+             WRITE(numout,*) '   pixel_area: ', pixel_area(ipts)
+             IF(ld_stop)THEN
+                CALL ipslerr_p (3,'basic_product_use', 'Mass balance error.','','')
+             ENDIF
+          ENDIF
+       ENDDO
+    ENDDO
+
+ !! 4. Convert the pools into fluxes and aggregate
+
+    !  Convert pools into fluxes
+    !  The pools are given in the absolute amount of carbon for the whole pixel
+    !  and the harvest was accumulated over the year. The unit is thus 
+    !  gc pixel-1 year-1. These fluxes should be expressed as gC m-2 dt-1. Therefore,
+    !  divide by the resolution of the pixel and the number of time steps within 
+    !  a year
+    cflux_prod_s(:) = cflux_prod_s(:) / one_year * dt_days / pixel_area(:) 
+    cflux_prod_m(:) = cflux_prod_m(:) / one_year * dt_days / pixel_area(:) 
+    cflux_prod_l(:) = cflux_prod_l(:) / one_year * dt_days / pixel_area(:) 
+
+    ! Calculate aggregate values
+    ! cflux_prod_total is now in gC m-2 dt-1. The prod_x_total are in gC m-2 
+    cflux_prod_total(:) = cflux_prod_s(:) + cflux_prod_m(:) + cflux_prod_l(:)
+    prod_s_total(:) = SUM(prod_s(:,:),2) / pixel_area(:)
+    prod_m_total(:) = SUM(prod_m(:,:),2) / pixel_area(:) 
+    prod_l_total(:) = SUM(prod_l(:,:),2) / pixel_area(:) 
+
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving basic product use'
+
+
+  END SUBROUTINE dim_product_use
+
+!! ================================================================================================================================
+!! SUBROUTINE   : basic_product_init
+!!
+!>\BRIEF        Initialize the product use variables when product use is not
+!!              calculated 
+!!
+!! DESCRIPTION  : Initialize the product use variables when product use is not
+!! calculated
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : prod_s, prod_m, prod_l, flux_s, flux_m, flux_l,
+!!   cflux_prod_s cflux_prod_m and cflux_prod1_l 
+!!
+!! REFERENCES   : None
+!!
+!! FLOWCHART    : None
+!!
+!_ ================================================================================================================================
+
+ SUBROUTINE basic_product_init(cflux_prod_s, cflux_prod_m, cflux_prod_l, &
+               prod_s_total, prod_m_total, prod_l_total, flux_s, &
+               flux_m, flux_l, cflux_prod_total)
+
+   IMPLICIT NONE
+
+
+ !! 0. Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: cflux_prod_s      !! C-released during first years (short term) 
+                                                                              !! following land cover change 
+                                                                              !! @tex ($gC m^{-1} dt^{-1}$) @endtex 
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: cflux_prod_m      !! Total annual release from decomposition of 
+                                                                              !! the medium-lived product pool 
+                                                                              !! @tex ($gC m^{-1} dt^{-1}$) @endtex
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: cflux_prod_l      !! Total annual release from decomposition of 
+                                                                              !! the long-lived product pool 
+                                                                              !! @tex ($gC m^{-1} dt^{-1}$) @endtex
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: prod_s_total      !! Total products remaining in the short-lived  
+                                                                              !! pool after the annual decomposition 
+                                                                              !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: prod_m_total      !! Total products remaining in the medium-lived
+                                                                              !! pool after the annual decomposition 
+                                                                              !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: prod_l_total      !! Total products remaining in the long-lived
+                                                                              !! pool after the annual release 
+                                                                              !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:), INTENT(out)               :: cflux_prod_total  !! Total flux from decomposition of the short,
+                                                                              !! medium and long lived product pools 
+                                                                              !! @tex $(gC m^{-1} dt^{-1})$ @endtex
+
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)           :: flux_s            !! Annual release from the short-lived product 
+                                                                              !! pool @tex $(gC) pixel^{-1} year^{-1}$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)           :: flux_m            !! Annual release from the medium-lived product  
+                                                                              !! pool @tex $(gC) pixel^{-1} year^{-1}$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)           :: flux_l            !! Annual release from the long-lived product
+                                                                              !! pool @tex $(gC) pixel^{-1} year^{-1}$ @endtex
+
+    !! 0.4 Local variables
+
+!_ ================================================================================================================================    
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering basic product init'
+ 
+ !! 1. initialization
+
+    cflux_prod_s(:) = zero
+    cflux_prod_m(:) = zero
+    cflux_prod_l(:) = zero
+    prod_s_total(:) = zero
+    prod_m_total(:) = zero
+    prod_l_total(:) = zero
+    flux_s(:,:) = zero
+    flux_m(:,:) = zero
+    flux_l(:,:) = zero
+    cflux_prod_total(:) = zero
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving basic product init'
+
+  END SUBROUTINE basic_product_init
+
+END MODULE sapiens_product_use
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate.f90	(revision 7236)
@@ -0,0 +1,6336 @@
+! =================================================================================================================================
+! MODULE       : stomate
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Groups the subroutines that: (1) initialize all variables in 
+!! stomate, (2) read and write forcing files of stomate and the soil component,
+!! (3) aggregates and convert variables to handle the different time steps 
+!! between sechiba and stomate, (4) call subroutines that govern major stomate
+!! processes (litter, soil, and vegetation dynamics) and (5) structures these tasks 
+!! in stomate_main
+!!
+!!\n DESCRIPTION : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! REFERENCE(S)	: None
+!!
+!! SVN :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_stomate/stomate.f90 $
+!! $Date: 2015-02-22 16:18:16 +0100 (Sun, 22 Feb 2015) $
+!! $Revision: 2555 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE stomate
+
+  ! Modules used:
+#ifdef __NAGFOR
+  USE F90_UNIX_PROC
+  USE F90_UNIX_IO
+#endif
+  USE function_library,   ONLY : check_biomass_sync, biomass_to_lai
+  USE netcdf
+  USE defprec
+  USE grid
+  USE constantes
+  USE constantes_soil
+  USE pft_parameters
+  USE sapiens_forestry,   ONLY : read_in_fm_map, read_in_litter_map, &
+                                 read_in_species_change_map
+  USE structures
+  USE stomate_io
+  USE stomate_data
+  USE stomate_season
+  USE stomate_lpj
+  USE stomate_litter
+  USE stomate_vmax
+  USE stomate_soilcarbon
+  USE stomate_resp
+  USE mod_orchidee_para
+  USE ioipsl_para 
+  USE xios_orchidee
+
+  USE matrix_resolution
+  
+  IMPLICIT NONE
+
+  ! Private & public routines
+
+  PUBLIC stomate_main,stomate_clear,init_forcing,forcing_read
+
+
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: veget_cov_max        !! Maximal fractional coverage: maximum share of a pixel
+                                                                         !! taken by a PFT 
+!$OMP THREADPRIVATE(veget_cov_max)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: veget_cov_max_new    !! Updated maximal fractional coverage (unitless)
+!$OMP THREADPRIVATE(veget_cov_max_new)
+  
+
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: ba                   !! Stand basal area @tex $(m^{-2})$ @endtex
+!$OMP THREADPRIVATE(ba)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: age                  !! Age of PFT it normalized by biomass - can increase and
+                                                                         !! decrease - (years)
+!$OMP THREADPRIVATE(age)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: adapted              !! Winter too cold for PFT to survive (0-1, unitless)
+!$OMP THREADPRIVATE(adapted)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: regenerate           !! Winter sufficiently cold to produce viable seeds 
+                                                                         !! (0-1, unitless)
+!$OMP THREADPRIVATE(regenerate)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: everywhere           !! Is the PFT everywhere in the grid box or very localized 
+                                                                         !! (after its intoduction)
+!$OMP THREADPRIVATE(everywhere)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: fireindex            !! Probability of fire (unitless)
+!$OMP THREADPRIVATE(fireindex)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: veget_lastlight      !! Vegetation fractions (on ground) after last light 
+                                                                         !! competition (unitless) 
+!$OMP THREADPRIVATE(veget_lastlight)
+  
+  REAL(r_std), ALLOCATABLE,SAVE,DIMENSION(:,:)   :: fpc_max              !! "maximal" coverage fraction of a grid box (LAI -> 
+                                                                         !! infinity) on ground. [??CHECK??] It's set to zero here, 
+                                                                         !! and then is used once in lpj_light.f90 to test if 
+                                                                         !! fpc_nat is greater than it. Something seems missing
+!$OMP THREADPRIVATE(fpc_max)
+  
+  LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:,:)        :: PFTpresent           !! PFT exists (equivalent to veget > 0 for natural PFTs)
+!$OMP THREADPRIVATE(PFTpresent)
+  
+  LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:,:)        :: senescence           !! The PFT is senescent
+!$OMP THREADPRIVATE(senescence)
+  
+  LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:,:)        :: need_adjacent        !! This PFT needs to be in present in an adjacent gridbox 
+                                                                         !! if it is to be introduced in a new gridbox
+!$OMP THREADPRIVATE(need_adjacent)
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: humrel_daily         !! Daily plant available water -root profile weighted 
+                                                                         !! (0-1, unitless)
+!$OMP THREADPRIVATE(humrel_daily)
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: vir_humrel_daily     !! Virtual daily plant available water -root profile weighted 
+                                                                         !! (0-1, unitless)
+!$OMP THREADPRIVATE(vir_humrel_daily)
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: stressed_daily       !! Accumulated proxy for stressed ecosystem functioning
+                                                                         !! see variable stressed defined in sechiba
+!$OMP THREADPRIVATE(stressed_daily)
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: unstressed_daily     !! Accumulated proxy for unstressed ecosystem functioning
+                                                                         !! see variable stressed defined in sechiba 
+!$OMP THREADPRIVATE(unstressed_daily)
+ 
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: daylight             !! Time sterps dt_radia during daylight
+!$OMP THREADPRIVATE(daylight)
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: transpir_supply_daily !! Daily supply of water for transpiration @tex $(mm dt^{-1})$ @endtex
+! $OMP THREADPRIVATE(transpir_supply_daily)
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: vir_transpir_supply_daily !! Daily supply of water for transpiration 
+                                                                         !! @tex $(mm dt^{-1})$ @endtex
+! $OMP THREADPRIVATE(vir_transpir_supply_daily)                                                                        
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: transpir_daily       !! Daily demand of water for transpiration @tex $(mm dt^{-1})$ @endtex
+! $OMP THREADPRIVATE(transpir_daily) 
+
+ REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)     :: humrel_week          !! "Weekly" plant available water -root profile weighted
+                                                                         !! (0-1, unitless)
+!$OMP THREADPRIVATE(humrel_week)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: humrel_month         !! "Monthly" plant available water -root profile weighted
+                                                                         !! (0-1, unitless)
+!$OMP THREADPRIVATE(humrel_month)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: humrel_growingseason !! Mean growing season moisture availability (used for 
+                                                                         !! allocation response)
+!$OMP THREADPRIVATE(humrel_growingseason)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: vir_humrel_growingseason !! Mean growing season moisture availability (used for 
+                                                                         !! allocation response)
+!$OMP THREADPRIVATE(vir_humrel_growingseason)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: maxhumrel_lastyear   !! Last year's max plant available water -root profile 
+                                                                         !! weighted (0-1, unitless)
+!$OMP THREADPRIVATE(maxhumrel_lastyear)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: maxhumrel_thisyear   !! This year's max plant available water -root profile 
+                                                                         !! weighted (0-1, unitless) 
+!$OMP THREADPRIVATE(maxhumrel_thisyear)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: minhumrel_lastyear   !! Last year's min plant available water -root profile 
+                                                                         !! weighted (0-1, unitless)  
+!$OMP THREADPRIVATE(minhumrel_lastyear)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: minhumrel_thisyear   !! This year's minimum plant available water -root profile
+                                                                         !! weighted (0-1, unitless)
+!$OMP THREADPRIVATE(minhumrel_thisyear)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: t2m_daily            !! Daily air temperature at 2 meter (K)
+!$OMP THREADPRIVATE(t2m_daily)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: t2m_week             !! Mean "weekly" (default 7 days) air temperature at 2 
+                                                                         !! meter (K)  
+!$OMP THREADPRIVATE(t2m_week)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: t2m_month            !! Mean "monthly" (default 20 days) air temperature at 2 
+                                                                         !! meter (K)
+!$OMP THREADPRIVATE(t2m_month)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: t2m_longterm         !! Mean "Long term" (default 3 years) air temperature at 
+                                                                         !! 2 meter (K) 
+!$OMP THREADPRIVATE(t2m_longterm)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: t2m_min_daily        !! Daily minimum air temperature at 2 meter (K)
+!$OMP THREADPRIVATE(t2m_min_daily)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: tlong_ref            !! "Long term" (default 3 years) reference temperature at
+                                                                         !! 2 meter (K) 
+!$OMP THREADPRIVATE(tlong_ref)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: tsurf_daily          !! Daily surface temperatures (K)
+!$OMP THREADPRIVATE(tsurf_daily)
+
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: precip_daily         !! Daily precipitations sum @tex $(mm day^{-1})$ @endtex
+!$OMP THREADPRIVATE(precip_daily)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: precip_lastyear      !! Last year's annual precipitation sum 
+                                                                         !! @tex $??(mm year^{-1})$ @endtex
+!$OMP THREADPRIVATE(precip_lastyear)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: precip_thisyear      !! This year's annual precipitation sum 
+                                                                         !! @tex $??(mm year^{-1})$ @endtex 
+!$OMP THREADPRIVATE(precip_thisyear)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: soilhum_daily        !! Daily soil humidity (0-1, unitless)
+!$OMP THREADPRIVATE(soilhum_daily)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: soilhum_month        !! Soil humidity - integrated over a month (0-1, unitless) 
+!$OMP THREADPRIVATE(soilhum_month)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: tsoil_daily          !! Daily soil temperatures (K)
+!$OMP THREADPRIVATE(tsoil_daily)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: tsoil_month          !! Soil temperatures at each soil layer integrated over a
+                                                                         !! month (K) 
+!$OMP THREADPRIVATE(tsoil_month)
+ 
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: litterhum_daily      !! Daily litter humidity (0-1, unitless)
+!$OMP THREADPRIVATE(litterhum_daily)
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: control_moist        !! Moisture control of heterotrophic respiration 
+                                                                         !! (0-1, unitless)
+!$OMP THREADPRIVATE(control_moist)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: control_temp         !! Temperature control of heterotrophic respiration at the
+                                                                         !! different soil levels (0-1, unitless)
+!$OMP THREADPRIVATE(control_temp)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: control_moist_daily  !! Moisture control of heterotrophic respiration daily 
+                                                                         !! (0-1, unitless)
+!$OMP THREADPRIVATE(control_moist_daily)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: control_temp_daily   !! Temperature control of heterotrophic respiration, above
+                                                                         !! and below daily (0-1, unitless)
+!$OMP THREADPRIVATE(control_temp_daily)
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: gdd_init_date        !! inital date for gdd count 
+!$OMP THREADPRIVATE(gdd_init_date)
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: gdd_from_growthinit  !! gdd from beginning of season (C)
+!$OMP THREADPRIVATE(gdd_from_growthinit)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: gdd0_lastyear        !! Last year's annual Growing Degree Days,
+                                                                         !! threshold 0 deg C (K) 
+!$OMP THREADPRIVATE(gdd0_lastyear)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: gdd0_thisyear        !! This year's annual Growing Degree Days,
+                                                                         !! threshold 0 deg C (K)
+!$OMP THREADPRIVATE(gdd0_thisyear)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: gdd_m5_dormance      !! Growing degree days for onset of growing season, 
+                                                                         !! threshold -5 deg C (K)
+!$OMP THREADPRIVATE(gdd_m5_dormance)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: gdd_midwinter        !! Growing degree days for onset of growing season, 
+                                                                         !! since midwinter (K)
+!$OMP THREADPRIVATE(gdd_midwinter)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: ncd_dormance         !! Number of chilling days since leaves were lost (days) 
+!$OMP THREADPRIVATE(ncd_dormance)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: ngd_minus5           !! Number of growing days, threshold -5 deg C (days)
+!$OMP THREADPRIVATE(ngd_minus5)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: hum_min_dormance     !! Minimum moisture during dormance (0-1, unitless) 
+!$OMP THREADPRIVATE(hum_min_dormance)
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: gpp_daily            !! Daily gross primary productivity per ground area 
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex
+!$OMP THREADPRIVATE(gpp_daily) 
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: gpp_week             !! Mean "weekly" (default 7 days) GPP  
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex
+!$OMP THREADPRIVATE(gpp_week)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: maxgppweek_lastyear  !! Last year's maximum "weekly" GPP  
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex 
+!$OMP THREADPRIVATE(maxgppweek_lastyear)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: maxgppweek_thisyear  !! This year's maximum "weekly" GPP  
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex  
+!$OMP THREADPRIVATE(maxgppweek_thisyear)
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: npp_daily            !! Daily net primary productivity per ground area 
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex 
+!$OMP THREADPRIVATE(npp_daily)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: npp_longterm         !! "Long term" (default 3 years) net primary productivity 
+                                                                         !! per ground area  
+                                                                         !! @tex $(gC m^{-2} year^{-1})$ @endtex   
+!$OMP THREADPRIVATE(npp_longterm)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: npp_equil            !! Equilibrium NPP written to forcesoil 
+                                                                         !! @tex $(gC m^{-2} year^{-1})$ @endtex
+!$OMP THREADPRIVATE(npp_equil)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: npp_tot              !! Total NPP written to forcesoil 
+                                                                         !! @tex $(gC m^{-2} year^{-1})$ @endtex 
+!$OMP THREADPRIVATE(npp_tot)
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: resp_maint_part_radia!! Maintenance respiration of different plant parts per 
+                                                                         !! total ground area at Sechiba time step  
+                                                                         !! @tex $(gC m^{-2} dtradia^{-1})$ @endtex
+!$OMP THREADPRIVATE(resp_maint_part_radia)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: resp_maint_part      !! Maintenance respiration of different plant parts per
+                                                                         !! total ground area at Stomate time step 
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex
+!$OMP THREADPRIVATE(resp_maint_part)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: resp_maint_radia     !! Maintenance respiration per ground area at Sechiba time
+                                                                         !! step   
+                                                                         !! @tex $(gC m^{-2} dtradia^{-1})$ @endtex
+!$OMP THREADPRIVATE(resp_maint_radia)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: resp_maint_d         !! Maintenance respiration per ground area at Stomate time 
+                                                                         !! step  
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex
+!$OMP THREADPRIVATE(resp_maint_d)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: resp_growth_d        !! Growth respiration per ground area 
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex
+!$OMP THREADPRIVATE(resp_growth_d)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: resp_hetero_d        !! Heterotrophic respiration per ground area 
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex
+!$OMP THREADPRIVATE(resp_hetero_d)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: resp_hetero_litter_d
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: resp_hetero_soil_d
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: resp_hetero_radia    !! Heterothrophic respiration per ground area at Sechiba
+                                                                         !! time step 
+                                                                         !! @tex $(gC m^{-2} dtradia^{-1})$ @endtex 
+!$OMP THREADPRIVATE(resp_hetero_radia)
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)   :: turnover_time       !! Turnover time of grasses 
+                                                                         !! @tex $(dt_slow^{-1})$ @endtex 
+!$OMP THREADPRIVATE(turnover_time)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:,:) :: turnover_daily      !! Senescence-driven turnover (better: mortality) of 
+                                                                         !! leaves and roots  
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex
+!$OMP THREADPRIVATE(turnover_daily)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:,:) :: turnover_littercalc !! Senescence-driven turnover (better: mortality) of 
+                                                                         !! leaves and roots at Sechiba time step 
+                                                                         !! @tex $(gC m^{-2} dtradia^{-1})$ @endtex 
+!$OMP THREADPRIVATE(turnover_littercalc)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:,:) :: turnover_longterm   !! "Long term" (default 3 years) senescence-driven 
+                                                                         !! turnover (better: mortality) of leaves and roots 
+                                                                         !! @tex $(gC m^{-2} year^{-1})$ @endtex
+!$OMP THREADPRIVATE(turnover_longterm)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:,:) :: bm_to_litter        !! Background (not senescence-driven) mortality of biomass
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex
+!$OMP THREADPRIVATE(bm_to_litter)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:,:) :: bm_to_littercalc    !! conversion of biomass to litter per ground area at 
+                                                                         !! Sechiba time step 
+                                                                         !! @tex $(gC m^{-2} dtradia^{-1})$ @endtex 
+!$OMP THREADPRIVATE(bm_to_littercalc)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)   :: dead_leaves         !! Metabolic and structural pools of dead leaves on ground
+                                                                         !! per PFT @tex $(gC m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(dead_leaves)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:,:,:):: litter             !! Above and below ground metabolic and structural litter 
+                                                                         !! per ground area 
+                                                                         !! @tex $(gC m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(litter)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: litterpart           !! Fraction of litter above the ground belonging to 
+                                                                         !! different litter pools (unitless)
+!$OMP THREADPRIVATE(litterpart)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: firelitter           !! Total litter above the ground that could potentially 
+                                                                         !! burn @tex $(gC m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(firelitter)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:,:):: soilcarbon_input     !! Quantity of carbon going into carbon pools from litter
+                                                                         !! decomposition per ground area  at Sechiba time step 
+                                                                         !! @tex $(gC m^{-2} dtradia^{-1})$ @endtex 
+!$OMP THREADPRIVATE(soilcarbon_input)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: soilcarbon_input_daily !! Daily quantity of carbon going into carbon pools from
+                                                                           !! litter decomposition per ground area 
+                                                                           !! @tex $(gC m^{-2} day^{-1})$ @endtex 
+!$OMP THREADPRIVATE(soilcarbon_input_daily)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: carbon               !! Soil carbon pools per ground area: active, slow, or 
+                                                                         !! passive, @tex $(gC m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(carbon)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: lignin_struc         !! Ratio Lignine/Carbon in structural litter for above and
+                                                                         !! below ground compartments (unitless)
+
+!$OMP THREADPRIVATE(lignin_struc)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: lignin_wood          !! Ratio Lignine/Carbon in woody litter for above and
+                                                                         !! below ground compartments (unitless)
+
+!$OMP THREADPRIVATE(lignin_wood)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: black_carbon         !! Black carbon on the ground 
+                                                                         !! @tex $(gC m^{-2})$ @endtex   
+!$OMP THREADPRIVATE(black_carbon)
+!---
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: lm_lastyearmax       !! Last year's maximum leaf mass per ground area for each
+                                                                         !! PFT @tex $(gC m^{-2})$ @endtex  
+!$OMP THREADPRIVATE(lm_lastyearmax)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: lm_thisyearmax       !! This year's maximum leaf mass per ground area for each
+                                                                         !! PFT @tex $(gC m^{-2})$ @endtex  
+!$OMP THREADPRIVATE(lm_thisyearmax)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: maxfpc_lastyear      !! Last year's maximum fpc for each natural PFT, on ground
+                                                                         !! [??CHECK] fpc but this ones look ok (computed in 
+                                                                         !! season, used in light)?? 
+!$OMP THREADPRIVATE(maxfpc_lastyear)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: maxfpc_thisyear      !! This year's maximum fpc for each PFT, on ground (see 
+                                                                         !! stomate_season), [??CHECK] fpc but this ones look ok 
+                                                                         !! (computed in season, used in light)??
+!$OMP THREADPRIVATE(maxfpc_thisyear)
+
+  REAL(r_std), ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: leaf_age             !! Age of different leaf classes (days)
+!$OMP THREADPRIVATE(leaf_age)
+  
+  REAL(r_std), ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: leaf_frac            !! PFT fraction of leaf mass in leaf age class (0-1, 
+                                                                         !! unitless) 
+!$OMP THREADPRIVATE(leaf_frac)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: when_growthinit      !! Days since beginning of growing season (days)
+!$OMP THREADPRIVATE(when_growthinit)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: herbivores           !! Time constant of probability of a leaf to be eaten by a
+                                                                         !! herbivore (days)
+!$OMP THREADPRIVATE(herbivores)
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: RIP_time             !! How much time ago was the PFT eliminated for the last 
+                                                                         !! time (year)
+!$OMP THREADPRIVATE(RIP_time)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: time_lowgpp          !! Duration of dormance (days)
+!$OMP THREADPRIVATE(time_lowgpp)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: time_hum_min         !! Time elapsed since strongest moisture limitation (days) 
+!$OMP THREADPRIVATE(time_hum_min)
+
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)         :: clay_fm              !! Soil clay content (0-1, unitless), parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)         :: clay_fm_g            !! Soil clay content (0-1, unitless), parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)         :: precip_fm            !! Daily precipitations sum @tex $(mm day^{-1})$ @endtex,
+                                                                         !! parallel computing
+   
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)         :: precip_fm_g          !! Daily precipitations sum @tex $(mm day^{-1})$ @endtex,
+                                                                         !! parallel computing
+   
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)         :: litterhum_daily_fm   !! Daily relative humidity of litter (0-1, unitless), 
+                                                                         !! parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)         :: litterhum_daily_fm_g !! Daily relative humidity of litter (0-1, unitless), 
+                                                                         !! parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)         :: t2m_daily_fm         !! Daily air temperature at 2 meter (K), parallel 
+                                                                         !! computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)         :: t2m_daily_fm_g       !! Daily air temperature at 2 meter (K), parallel 
+                                                                         !! computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)         :: t2m_min_daily_fm     !! Daily minimum air temperature at 2 meter (K), 
+                                                                         !! parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)         :: t2m_min_daily_fm_g   !! Daily minimum air temperature at 2 meter (K), 
+                                                                         !! parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)         :: tsurf_daily_fm       !! Daily surface temperatures (K), parallel 
+                                                                         !! computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)         :: tsurf_daily_fm_g     !! Daily surface temperatures (K), parallel 
+                                                                         !! computing 
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)       :: tsoil_daily_fm       !! Daily soil temperatures (K), parallel computing 
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)       :: tsoil_daily_fm_g     !! Daily soil temperatures (K), parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)       :: soilhum_daily_fm     !! Daily soil humidity (0-1, unitless), parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)       :: soilhum_daily_fm_g   !! Daily soil humidity (0-1, unitless), parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)       :: humrel_daily_fm      !! Daily relative humidity of atmosphere (0-1, unitless), 
+                                                                         !! parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)       :: humrel_daily_fm_g    !! Daily relative humidity of atmosphere (0-1, unitless), 
+                                                                         !! parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)       :: gpp_daily_fm         !! Daily gross primary productivity per ground area 
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex, 
+                                                                         !! parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)       :: gpp_daily_fm_g       !! Daily gross primary productivity per ground area 
+                                                                         !! @tex $(gC m^{-2} day^{-1})$ @endtex, 
+                                                                         !! parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)       :: veget_fm             !! Vegetation coverage taking into account non-biological
+                                                                         !! coverage (unitless), parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)       :: veget_fm_g           !! Vegetation coverage taking into account non-biological
+                                                                         !! coverage (unitless), parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)       :: veget_max_fm         !! Maximum vegetation coverage taking into account 
+                                                                         !! non-biological coverage (unitless), parallel computing
+   
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)       :: veget_max_fm_g       !! Maximum vegetation coverage taking into account none 
+                                                                         !! biological coverage (unitless), parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)       :: lai_fm               !! Leaf area index @tex $(m^2 m^{-2})$ @endtex 
+                                                                         !! parallel computing
+  
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)       :: lai_fm_g             !! Leaf area index @tex $(m^2 m^{-2})$ @endtex 
+                                                                         !! parallel computing
+
+  REAL(r_std), ALLOCATABLE,SAVE,DIMENSION(:,:)   :: senescence_days      !! days since the beginning of senescence (days)
+  
+  REAL(r_std), ALLOCATABLE,SAVE,DIMENSION(:,:)   :: rue_longterm         !! Longterm radiation use efficiency (??units??)
+  
+  REAL(r_std), ALLOCATABLE,SAVE,DIMENSION(:,:)   :: lab_fac              !! Activity of labile pool factor (??units??)
+  
+!!$  REAL(r_std), ALLOCATABLE,SAVE,DIMENSION(:,:)   :: lai_target           !! Target lai in functional allocation
+!!$                                                                         !! @tex $(m^{2} m^{-2})$ @endtex
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: co2_fire             !! Carbon emitted to the atmosphere by burning living 
+                                                                         !! and dead biomass 
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex 
+!$OMP THREADPRIVATE(co2_fire)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: co2_to_bm_dgvm       !! Psuedo-photosynthesis,C used to provide seedlings with
+                                                                         !! an initial biomass, arbitrarily removed from the 
+                                                                         !! atmosphere  
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex 
+!$OMP THREADPRIVATE(co2_to_bm_dgvm)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: co2_flux_daily       !! Daily net CO2 flux between atmosphere and biosphere 
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex
+                                                                         !! [??CHECK] sign convention?
+!$OMP THREADPRIVATE(co2_flux_daily)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: co2_flux_monthly     !! Monthly net CO2 flux between atmosphere and biosphere 
+                                                                         !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex
+                                                                         !! [??CHECK] sign convention? 
+!$OMP THREADPRIVATE(co2_flux_monthly)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: prod_s               !! Wood products remaining in the 1 year-turnover pool 
+                                                                         !! after the annual release for each compartment 
+                                                                         !! @tex $(gC m^{-2})$ @endtex    
+                                                                         !! (0:1 input from year of land cover change),
+                                                                         !! dimension(#pixels,0:1 years
+!$OMP THREADPRIVATE(prod_s)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: prod_m               !! Wood products remaining in the 10 year-turnover pool 
+                                                                         !! after the annual release for each compartment 
+                                                                         !! @tex $(gC m^{-2})$ @endtex    
+                                                                         !! (0:10 input from year of land cover change),
+                                                                         !! dimension(#pixels,0:10 years
+!$OMP THREADPRIVATE(prod_m)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: prod_l              !! Wood products remaining in the 100 year-turnover pool
+                                                                         !! after the annual release for each compartment
+                                                                         !! @tex $(gC m^{-2})$ @endtex  
+                                                                         !! (0:100 input from year of land cover change), 
+                                                                         !! dimension(#pixels,0:100 years)
+!$OMP THREADPRIVATE(prod_l)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: flux_s               !! Wood decomposition from the 1 year-turnover pool 
+                                                                         !! compartments 
+                                                                         !! @tex $(gC m^{-2} year^{-1})$ @endtex 
+                                                                         !! dimension(#pixels,0:1)  
+!$OMP THREADPRIVATE(flux_s)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: flux_m               !! Wood decomposition from the 10 year-turnover pool 
+                                                                         !! compartments 
+                                                                         !! @tex $(gC m^{-2} year^{-1})$ @endtex 
+                                                                         !! dimension(#pixels,0:10)  
+!$OMP THREADPRIVATE(flux_m)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: flux_l              !! Wood decomposition from the 100 year-turnover pool 
+                                                                         !! compartments 
+                                                                         !! @tex $(gC m^{-2} year^{-1})$ @endtex
+                                                                         !! dimension(#pixels,0:100)
+!$OMP THREADPRIVATE(flux_l)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: cflux_prod_s         !! Release during first year following land cover change 
+                                                                         !! (paper, burned, etc...) 
+                                                                         !! @tex $(gC m^{-2} year^{-1})$ @endtex  
+!$OMP THREADPRIVATE(cflux_prod_s)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: cflux_prod_m         !! Total annual release from the 10 year-turnover pool
+                                                                         !! sum of flux_m  
+                                                                         !! @tex $(gC m^{-2} year^{-1})$ @endtex
+!$OMP THREADPRIVATE(cflux_prod_m)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: cflux_prod_l         !! Total annual release from the 100 year-turnover pool 
+                                                                         !! sum of flux_l 
+                                                                         !! @tex $(gC m^{-2} year^{-1})$ @endtex
+!$OMP THREADPRIVATE(cflux_prod_l)
+
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: carb_mass_total      !! Total on-site and off-site C pool 
+                                                                         !! @tex $(??gC m^{-2})$ @endtex                        
+!$OMP THREADPRIVATE(carb_mass_total)
+!---
+  REAL(r_std),SAVE                               :: dt_days=zero         !! Time step of STOMATE (days) 
+!$OMP THREADPRIVATE(dt_days)
+  REAL(r_std),SAVE                               :: day_counter=zero     !! Time step each day sechiba (dtradia)   
+!$OMP THREADPRIVATE(day_counter)
+  INTEGER(i_std),SAVE                            :: date=0               !! Date (days) 
+!$OMP THREADPRIVATE(date)
+  INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:)   :: nforce               !! Number of states calculated for the soil forcing 
+                                                                         !! variables (unitless), dimension(::nparan*::nbyear) both 
+                                                                         !! given in the run definition file    
+!$OMP THREADPRIVATE(nforce)
+  INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:)   :: isf                  !! Index for number of time steps that can be stored in 
+                                                                         !! memory (unitless), dimension (#nsfm)
+!$OMP THREADPRIVATE(isf)
+  INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:)   :: nf_cumul             !! Number of years over which the average is calculated in
+                                                                         !! forcesoil when cumul flag is set, dimension (#nsft)
+                                                                         !! [??CHECK] definition the dimension is number of 
+                                                                         !! timesteps in a year?
+!$OMP THREADPRIVATE(nf_cumul)
+  INTEGER,PARAMETER                              :: r_typ = nf90_real4   !! Specify data format (server dependent)
+  
+  LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:)          :: nf_written           !! Flag indicating whether the forcing data have been 
+                                                                         !! written
+!$OMP THREADPRIVATE(nf_written)
+
+  LOGICAL, SAVE                                  :: do_slow=.FALSE.      !! Flag that determines whether stomate_accu calculates
+                                                                         !! the sum(do_slow=.FALSE.) or the mean 
+                                                                         !! (do_slow=.TRUE.)
+!$OMP THREADPRIVATE(do_slow)
+  LOGICAL, SAVE                                  :: EndOfYear=.FALSE.    !! Update annual variables? This variable must be 
+                                                                         !! .TRUE. once a year
+!$OMP THREADPRIVATE(EndOfYear)
+  LOGICAL, SAVE                                  :: EndOfMonth=.FALSE.   !! Update monthly variables? This variable must be 
+                                                                         !!.TRUE. once a month 
+!$OMP THREADPRIVATE(EndOfMonth)
+  
+  LOGICAL, SAVE                                  :: l_first_stomate = .TRUE.!! Is this the first call of stomate?
+!$OMP THREADPRIVATE(l_first_stomate)
+  
+  LOGICAL, SAVE                                  :: cumul_forcing=.FALSE.!! flag for cumul of forcing if teststomate
+!$OMP THREADPRIVATE(cumul_forcing)
+  
+  LOGICAL, SAVE                                  :: cumul_Cforcing=.FALSE.  !! Flag, if internal parameter cumul_Cforcing is 
+                                                                         !! TRUE then ::nbyear (defined in run definition 
+                                                                         !! file will be forced to 1 later in this module. If 
+                                                                         !! FALSE the mean over ::nbyear is written in forcesoil
+!$OMP THREADPRIVATE(cumul_Cforcing)
+  
+  REAL(r_std),DIMENSION(:),ALLOCATABLE,SAVE      :: circ_class_dist   !! When the circumference class distribution
+                                                                      !! is redone due to empty classes, this is the
+                                                                      !! tree distribution used.  Notice that this distribution
+                                                                      !! is normalized after being read in.
+!$OMP THREADPRIVATE(circ_class_dist)
+  REAL(r_std),DIMENSION(:),ALLOCATABLE,SAVE      :: st_dist           !! During self-thinning, we need to decide which
+                                                                      !! circumference classes to kill trees in.  This
+                                                                      !! is the distribution that tells us this.  Notice that 
+                                                                      !! it is normalized after being read in.
+!$OMP THREADPRIVATE(st_class_dist)
+ 
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: harvest_above_monthly!! [??CHECK] post-processing - should be removed?
+!$OMP THREADPRIVATE(harvest_above_monthly)
+  
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: cflux_prod_monthly   !! [??CHECK] post-processing - should be removed?
+!$OMP THREADPRIVATE(cflux_prod_monthly)
+
+  INTEGER(i_std), SAVE                           :: global_years         !! Global counter of years (year)
+!$OMP THREADPRIVATE(global_years)
+  
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:)       :: ok_equilibrium       !! Logical array marking the points where the resolution is ok 
+                                                                         !! (true/false)
+!$OMP THREADPRIVATE(ok_equilibrium)
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:)       :: ok_equilibrium_g     !! Logical array marking the points where the resolution is ok 
+                                                                         !! (for parallelisation) (true/false)
+!$OMP THREADPRIVATE(ok_equilibrium_g)
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:)       :: carbon_eq            !! Logical array to mark the carbon pools at equilibrium ? 
+                                                                         !! If true, the job stops. (true/false)
+!$OMP THREADPRIVATE(carbon_eq)
+  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)   :: nbp_accu             !! Accumulated Net Biospheric Production over the year (gC.m^2 )
+!$OMP THREADPRIVATE(nbp_accu)
+  ! added by yitong yao 07 Jan 16:35 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:)    :: counter_psi 
+  ! added by yitong yao 07 Jan 16:35 above line 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:)    :: counter_2
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:)    :: counter_0
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)   :: nbp_flux             !! Net Biospheric Production (gC.m^2.day^{-1})
+!$OMP THREADPRIVATE(nbp_flux)
+  
+  REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:,:)   :: matrixA              !! Matrix containing the fluxes between the carbon pools
+                                                                         !! per sechiba time step 
+                                                                         !! @tex $(gC.m^2.day^{-1})$ @endtex
+!$OMP THREADPRIVATE(matrixA)
+  
+  REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:)     :: vectorB              !! Vector containing the litter increase per sechiba time step
+                                                                         !! @tex $(gC m^{-2})$ @endtex
+!$OMP THREADPRIVATE(vectorB)
+  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: MatrixV          !! Matrix containing the accumulated values of matrixA 
+!$OMP THREADPRIVATE(MatrixV)
+  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   :: VectorU          !! Matrix containing the accumulated values of VectorB
+!$OMP THREADPRIVATE(VectorU)
+  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: MatrixW          !! Matrix containing the opposite of matrixA
+!$OMP THREADPRIVATE(MatrixW)
+  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   :: previous_stock   !! Array containing the carbon stock calculated by the analytical
+                                                                         !! method in the previous resolution
+!$OMP THREADPRIVATE(previous_stock)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   :: current_stock    !! Array containing the carbon stock calculated by the analytical
+                                                                         !! method in the current resolution 
+!$OMP THREADPRIVATE(current_stock)
+  REAL(r_std), SAVE                                  :: eps_carbon       !! Stopping criterion for carbon pools (unitless,0-1)
+!$OMP THREADPRIVATE(eps_carbon)
+
+  REAL(r_std), ALLOCATABLE, DIMENSION(:,:)           :: sigma            !! Threshold for indivudal tree growth (m, trees whose
+                                                                         !! circumference is smaller than sigma don't grow much)
+!$OMP THREADPRIVATE(sigma)
+
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:,:)  :: age_stand        !! Age of stand (years)
+!$OMP THREADPRIVATE(age_stand)
+  
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:,:)  :: rotation_n       !! Rotation number (number of rotation since pft is managed)
+!$OMP THREADPRIVATE(rotation_n)
+  
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:,:)  :: last_cut         !! Years since last thinning (years)
+!$OMP THREADPRIVATE(last_cut)
+  
+!!$  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)     :: av_height        !! Average height in the stand (m)
+!!$!$OMP THREADPRIVATE(av_height)
+  
+!!$  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)     :: lai_max_calc     !! lai_max_calc
+!!$!$OMP THREADPRIVATE(lai_max_calc)
+    
+!++++CHECK+++
+! I had to move these into sechiba, since they need to be passed to sechiba
+!!$  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   :: circ_class_n     !! Number of trees within a circumference class
+!!$!$OMP THREADPRIVATE(circ_class_n)
+!!$  
+!!$  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) :: circ_class_biomass !! Biomass components of the model tree within a circ class 
+!!$                                                                         !! @tex $(gC ind^{-1@)$ @endtex
+!!$!$OMP THREADPRIVATE(circ_class_biomass)
+!!$  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:,:):: biomass              !! Biomass per ground area @tex $(gC m^{-2})$ @endtex 
+!!$OMP THREADPRIVATE(biomass)
+!!$  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: ind                  !! Vegetation density, number of individuals per unit 
+                                                                            !! ground area @tex $(m^{-2})$ @endtex 
+!!$OMP THREADPRIVATE(ind)
+
+!!$  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: biomass_lastyear !! biomass of last year  @tex $(gC m^{-2})$ @endtex 
+!!$!$OMP THREADPRIVATE(biomass_lastyear)
+  
+!!$  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)     :: lai_max_lastyear !! max lai of last year 
+!!$!$OMP THREADPRIVATE(lai_max_lastyear)
+  
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:,:)  :: forest_managed   !! forest management flag (is the forest being managed?)
+                                                                         !! (0-4,unitless)
+!$OMP THREADPRIVATE(forest_managed)
+  
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:,:)  :: forest_managed_lastyear !! forest management flag for the previous year
+                                                                         !! (0-4,unitless)
+!$OMP THREADPRIVATE(forest_managed_lastyear)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:,:)  :: species_change_map   !! A map which gives the PFT number that each
+                                                                         !! PFT will be replanted as in case of a clearcut.
+                                                                         !! (1-nvm,unitless)
+!$OMP THREADPRIVATE(species_change_map)
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:)         :: lpft_replant     !! Indicates if this PFT has either died this year
+                                                                         !! or been clearcut/coppiced.  If it has, it is not
+                                                                         !! replanted until the end of the year.
+!$OMP THREADPRIVATE(lpft_replant)
+ 
+  ! Functional Allocation
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)     :: KF               !! Scaling factor to convert sapwood mass
+                                                                         !! into leaf mass (m). The initial value is calculated
+                                                                         !! in prescribe and updated during allocation
+!$OMP THREADPRIVATE(KF)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)     :: k_latosa_adapt   !! Leaf to sapwood area adapted for waterstress. 
+                                                                         !! Adaptation takes place at the end of the year
+                                                                         !! (m)
+!$OMP THREADPRIVATE(k_latosa_adapt)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: harvest_pool     !! The pool which records the quantity of
+                                                                         !! wood harvested and thinned due to forest
+                                                                         !! management and LCC.  
+                                                                         !! @tex $(gC m^{-2})$ @endtex 
+!$OMP THREADPRIVATE(harvest_pool)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)     :: harvest_type     !! Type of management that resulted
+                                                                         !! in the harvest (unitless)
+!$OMP THREADPRIVATE(harvest_type)  
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)     :: harvest_cut      !! Type of cutting that was used for the harvest
+                                                                         !! (unitless)
+!$OMP THREADPRIVATE(harvest_cut)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)     :: harvest_area     !! Harvested area (m^{2})
+!$OMP THREADPRIVATE(harvest_area)  
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)       :: harvest_pool_bound       !! The boundaries of the diameter classes
+                                                                                 !! in the wood harvest pools
+                                                                                 !! @tex $(m)$ @endtex 
+!$OMP THREADPRIVATE(harvest_pool_bound)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)     :: mai              !! The mean annual increment used in
+                                                                         !! forestry.  It is the average change
+                                                                         !! in the wood volume of of the trunk
+                                                                         !! over the lifetime of the forest.
+                                                                         !! @tex $(m**3 / m**2 / year)$ @endtex 
+!$OMP THREADPRIVATE(mai)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)     :: pai              !! The period annual increment used in
+                                                                         !! forestry.  It is the average change
+                                                                         !! in the wood volume of of the trunk
+                                                                         !! over the past n_pai years of the forest,
+                                                                         !! where n_pai is defined in constants.f90.
+                                                                         !! @tex $(m**3 / m**2 / year)$ @endtex 
+!$OMP THREADPRIVATE(pai)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)     :: previous_wood_volume !! The volume of the tree trunks
+                                                                         !! in a stand for the previous year.
+                                                                         !! @tex $(m**3 / m**2 )$ @endtex 
+!$OMP THREADPRIVATE(previous_wood_volume)
+
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:,:)  :: mai_count        !! The number of times we've
+                                                                         !! calculated the volume increment
+                                                                         !! for a stand
+!$OMP THREADPRIVATE(mai_count)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   :: bm_sync          !! The difference betweeen the
+                                                                         !! biomass in the circ_classes and
+                                                                         !! the total biomass 
+                                                                         !! @tex $(gC m^{-2})$ @endtex
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:)     :: coppice_dens     !! The density of a coppice at the first
+                                                                         !! cutting.
+                                                                         !! @tex $( 1 / m**2 )$ @endtex 
+!$OMP THREADPRIVATE(coppice_dens)
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)       :: litter_demand    !! The amount of litter which will
+                                                                         !! be moved from forest to crop pools
+                                                                         !! at the end of the year.
+                                                                         !! @tex $( gC / year )$ @endtex 
+!$OMP THREADPRIVATE(litter_demand)
+
+  REAL(r_std), ALLOCATABLE, SAVE,DIMENSION(:,:)      :: wstress_season   !! Water stress factor, based on hum_rel_daily
+                                                                         !! (unitless, 0-1)
+!$OMP THREADPRIVATE(wstress_season)
+
+  REAL(r_std), ALLOCATABLE, SAVE,DIMENSION(:,:)      :: wstress_month    !! Water stress factor, based on hum_rel_daily
+                                                                         !! (unitless, 0-1)
+!$OMP THREADPRIVATE(wstress_month)
+
+  REAL(r_std), ALLOCATABLE, SAVE,DIMENSION(:,:)      :: vir_wstress_fac  !! Water stress factor, based on hum_rel_daily
+                                                                         !! (unitless, 0-1)
+!$OMP THREADPRIVATE(vir_wstress_fac)
+  REAL(r_std), ALLOCATABLE, SAVE,DIMENSION(:,:)      :: c_buried         !! Carbon that is buried when land cover changes
+                                                                         !! to a nobio type.  For example, in urbanization
+                                                                         !! the soil carbon is assumed to be locked under
+                                                                         !! the concrete and cannot decompose.  Nothing is
+                                                                         !! done with this at the moment, it's just to make
+                                                                         !! sure we account for all the carbon in the mass
+ REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)       :: stemplc_daily     !! balance checks.
+                                                                         !! @tex $( gC )$ @endtex 
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:)    :: psileaf_daily
+ REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:)    :: psiroot_daily
+!$OMP THREADPRIVATE(c_buried)
+ REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)       :: psistem_daily 
+ REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)       :: humrel_ddd
+
+PUBLIC clay_fm, humrel_daily_fm, litterhum_daily_fm, t2m_daily_fm, &
+   & t2m_min_daily_fm, tsurf_daily_fm, tsoil_daily_fm, soilhum_daily_fm, &
+   & precip_fm, gpp_daily_fm, veget_fm, veget_max_fm, lai_fm
+PUBLIC  dt_days, day_counter, date, do_slow, EndOfYear
+PUBLIC isf, nf_written
+
+CONTAINS
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: stomate_main
+!!
+!>\BRIEF        Manages variable initialisation, reading and writing forcing 
+!! files, aggregating data at stomate's time step (dt_slow), aggregating data
+!! at longer time scale (i.e. for phenology) and uses these forcing to calculate
+!! CO2 fluxes (NPP and respirations) and C-pools (litter, soil, biomass, ...)
+!!
+!! DESCRIPTION  : The subroutine manages 
+!! divers tasks:
+!! (1) Initializing all variables of stomate (first call)
+!! (2) Reading and writing forcing data (last call)
+!! (3) Adding CO2 fluxes to the IPCC history files
+!! (4) Converting the time steps of variables to maintain consistency between
+!! sechiba and stomate
+!! (5) Use these variables to call stomate_lpj, maint_respiration, littercalc,
+!! soilcarbon. The called subroutines handle: climate constraints 
+!! for PFTs, PFT dynamics, Phenology, Allocation, NPP (based on GPP and
+!! authothropic respiration), fire, mortality, vmax, assimilation temperatures,
+!! all turnover processes, light competition, sapling establishment, lai,  
+!! land cover change and litter and soil dynamics.
+!! (6) Use the spin-up method developed by Lardy (2011)(only if SPINUP_ANALYTIC 
+!! is set to TRUE).
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): deadleaf_cover, assim_param, lai, height, veget, 
+!! veget_max, veget_max_new, totfrac_nobio_new, resp_maint, 
+!! resp_hetero,resp_growth, co2_flux, fco2_lu.
+!!
+!! REFERENCES	: 
+!! - Lardy, R, et al., A new method to determine soil organic carbon equilibrium,
+!! Environmental Modelling & Software (2011), doi:10.1016|j.envsoft.2011.05.016
+!!
+!! FLOWCHART    : 
+!! \latexonly 
+!! \includegraphics[scale=0.5]{stomatemainflow.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE stomate_main &
+       & (kjit, kjpij, npts, dtradia, dt_slow, &
+       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, frac_age, &
+       veget, veget_max, veget_max_new, totfrac_nobio_new, &
+       rest_id_stom, hist_id_stom, hist_id_stom_IPCC, &
+       co2_flux, fco2_lu, resp_maint, resp_hetero, resp_growth, temp_growth, &
+       sinang, circ_class_biomass, circ_class_n, &
+       transpir, stressed, unstressed, transpir_supply, &
+       biomass, ind, lai_per_level, laieff_fit, &
+       vir_transpir_supply, Isotrop_Tran_Tot_p,stem_plc,psi_stem, psi_leaf, psi_root)
+
+    IMPLICIT NONE
+
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std),INTENT(in)                   :: kjit                !! Time step number (unitless)
+    INTEGER(i_std),INTENT(in)                   :: npts                !! Domain size - terrestrial pixels only (unitless)
+    INTEGER(i_std),INTENT(in)                   :: kjpij               !! Total size of the un-compressed grid (unitless)
+    REAL(r_std),INTENT(in)                      :: dtradia             !! Time step of SECHIBA (seconds)
+    REAL(r_std),INTENT(in)                      :: dt_slow             !! Time step of STOMATE (days)
+!!$    LOGICAL,INTENT(in)                          :: ldrestart_read      !! Logical for _restart_ file to read
+    LOGICAL,INTENT(in)                          :: ldrestart_write     !! Flag to write restart file for stomate
+    LOGICAL,INTENT(in)                          :: ldforcing_write     !! Flag to write forcing file for main processes in 
+                                                                       !! stomate 
+    LOGICAL,INTENT(in)                          :: ldcarbon_write      !! Flag to write forcing file for soil processes in 
+                                                                       !! stomate 
+    INTEGER(i_std),INTENT(in)                   :: rest_id_stom        !! STOMATE's _Restart_ file identifier (unitless)
+    INTEGER(i_std),INTENT(in)                   :: hist_id_stom        !! STOMATE's _history_ file identifier (unitless)
+    INTEGER(i_std),INTENT(in)                   :: hist_id_stom_IPCC   !! STOMATE's IPCC _history_ file identifier 
+                                                                       !! (unitless) 
+    INTEGER(i_std),DIMENSION(npts),INTENT(in)   :: index               !! Indices of the pixels on the map. Stomate uses a 
+                                                                       !! reduced grid excluding oceans. ::index contains 
+                                                                       !! the indices of the terrestrial pixels only 
+                                                                       !! (unitless) 
+    INTEGER(i_std),DIMENSION(npts,8),INTENT(in) :: neighbours          !! Neighoring grid points if land for the DGVM 
+                                                                       !! (unitless) 
+    REAL(r_std),DIMENSION(npts,2),INTENT(in)    :: lalo                !! Geographical coordinates (latitude,longitude) 
+                                                                       !! for pixels (degrees) 
+    REAL(r_std),DIMENSION(npts,2),INTENT(in)    :: resolution          !! Size in x an y of the grid (m) - surface area of 
+                                                                       !! the gridbox 
+    REAL(r_std),DIMENSION (npts), INTENT (in)   :: contfrac            !! Fraction of continent in the grid cell (unitless)
+    REAL(r_std),DIMENSION(npts),INTENT(in)      :: totfrac_nobio       !! Fraction of grid cell covered by lakes, land 
+                                                                       !! ice, cities, ... (unitless) 
+    REAL(r_std),DIMENSION(npts),INTENT(in)      :: clay                !! Clay fraction of soil (0-1, unitless)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)  :: humrel              !! Relative humidity ("moisture availability") 
+                                                                       !! (0-1, unitless) 
+    REAL(r_std),DIMENSION(npts),INTENT(in)      :: t2m                 !! 2 m air temperature (K)
+    REAL(r_std),DIMENSION(npts),INTENT(in)      :: t2m_min             !! Minimum 2 m air temp. during forcing time step 
+                                                                       !! (K) 
+    REAL(r_std),DIMENSION(npts),INTENT(in)      :: temp_sol            !! Surface temperature (K)
+    REAL(r_std),DIMENSION(npts,nbdl),INTENT(in) :: stempdiag           !! Soil temperature (K)
+    REAL(r_std),DIMENSION(npts,nbdl),INTENT(in) :: shumdiag            !! Relative soil moisture (0-1, unitless)
+    REAL(r_std),DIMENSION(npts),INTENT(in)      :: litterhumdiag       !! Litter humidity (0-1, unitless)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)  :: transpir            !! transpiration @tex $(kg m^{-2} timestep^{-1})$
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)  :: transpir_supply     !! Supply of water for transpiration @tex $(mm dt^{-1})$ @endtex
+    REAL(r_std),DIMENSION(:,:),INTENT (in)      :: vir_transpir_supply !! Virtual supply of water for transpiration to deal
+                                                                       !! with water stress when PFT1 becomes vegetated in LCC
+                                                                       !! @tex $(mm dt^{-1})$ @endtex
+    REAL(r_std),DIMENSION(npts),INTENT(in)      :: precip_rain         !! Rain precipitation  
+                                                                       !! @tex $(mm dt_slow^{-1})$ @endtex 
+    REAL(r_std),DIMENSION(npts),INTENT(in)      :: precip_snow         !! Snow precipitation  
+                                                                       !! @tex $(mm dt_slow^{-1})$ @endtex 
+    REAL(r_std),DIMENSION(:,:),INTENT(in)       :: gpp                 !! GPP of total ground area  
+                                                                       !! @tex $(gC m^{-2} time step^{-1})$ @endtex 
+    REAL(r_std),DIMENSION(:,:,:),INTENT(in)     :: stem_plc            !! Calculated in sechiba, account for vegetation 
+   
+    REAL(r_std),DIMENSION(:,:,:),INTENT(in)     :: psi_stem            !! cover and effective time step to obtain ::gpp_d  
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)   :: psi_leaf 
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)   :: psi_root
+
+    REAL(r_std),DIMENSION(npts),INTENT(in)      :: totfrac_nobio_new   !! New fraction of grid cell covered by lakes, land 
+    REAL(r_std),DIMENSION(npts), INTENT(in)     :: sinang              !! the sine of the solar angle from the horizon (unitless)  
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)  :: veget               !! Fraction of vegetation type including 
+                                                                       !! non-biological fraction (unitless) 
+    REAL(r_std),DIMENSION (:,:,:), INTENT (in)  :: Isotrop_Tran_Tot_p  !! Transmitted radiation per level (unitless)
+
+    !! 0.2 Output variables
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: co2_flux            !! CO2 flux between atmosphere and biosphere per 
+                                                                       !! average ground area 
+                                                                       !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex  
+                                                                       !! [??CHECK] sign convention? 
+    REAL(r_std),DIMENSION(npts),INTENT(out)     :: fco2_lu             !! CO2 flux between atmosphere and biosphere from 
+                                                                       !! land-use (without forest management)  
+                                                                       !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex  
+                                                                       !! [??CHECK] sign convention? 
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: resp_maint          !! Maitenance component of autotrophic respiration in 
+                                                                       !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex 
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: resp_growth         !! Growth component of autotrophic respiration in 
+                                                                       !! @tex ($gC m^{-2} dt_slow^{-1}$) @endtex
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: resp_hetero         !! Heterotrophic respiration in  
+                                                                       !! @tiex $(gC m^{-2} dt_slow^{-1})$ @endtex  
+
+
+    !! 0.3 Modified
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(inout) :: lai               !! Leaf area inex @tex $(m^2 m^{-2})$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(inout) :: veget_max         !! "maximal" coverage fraction of a PFT on the ground
+                                                                       !! May sum to
+                                                                       !! less than unity if the pixel has
+                                                                       !! nobio area. (unitless, 0-1)
+    REAL(r_std),DIMENSION(npts,nvm,npco2), &
+                                    INTENT(inout) :: assim_param       !! min+max+opt temperatures (K) & vmax for 
+                                                                       !! photosynthesis  
+                                                                       !! @tex $(\mu mol m^{-2}s^{-1})$ @endtex  
+    REAL(r_std),DIMENSION(npts),INTENT(inout)     :: deadleaf_cover    !! Fraction of soil covered by dead leaves 
+                                                                       !! (unitless) 
+    REAL(r_std),DIMENSION(npts,nvm,nleafages),&
+                                    INTENT(inout) :: frac_age          !! Age efficacity from STOMATE 
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements), &
+                                    INTENT(inout) :: circ_class_biomass !! Stem diameter 
+                                                                       !! @tex $(m)$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), &
+         INTENT(inout)                            :: circ_class_n      !! Number of trees within each circumference
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &               !! Biomass per PFT
+         INTENT(inout)                            :: biomass           !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout) :: ind             !! Number of individuals at the stand level
+                                                                       !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(inout) :: veget_max_new     !! New "maximal" coverage fraction of a PFT (LAI -> 
+                                                                       !! infinity) on ground only if EndOfYear is 
+                                                                       !! activated. Including nobio fraction. (unitless)  
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)  :: lai_per_level     !! This is the LAI per vertical level
+                                                                       !! @tex $(m^{2} m^{-2})$
+    TYPE(laieff_type),DIMENSION (:,:,:),INTENT(inout) &
+                                                  :: laieff_fit        !! Fitted parameters for the effective LAI
+    REAL(r_std),DIMENSION(npts),INTENT(inout)     :: temp_growth       !! Growth temperature (Â°C) 
+                                                                       !! Is equal to t2m_month
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(inout) :: stressed          !! adjusted ecosystem functioning. Takes the unit of the variable
+                                                                       !! used as a proxy for waterstress (assigned in sechiba).
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(inout) :: unstressed        !! initial ecosystem functioning after the first calculation and 
+                                                                       !! before any recalculations. Takes the unit of the variable used
+                                                                       !! as a proxy for unstressed (assigned in sechiba).
+
+
+    !! 0.4 local variables
+
+    REAL(r_std)                                :: day_counter_read     !! Day read in restart file (days)
+    REAL(r_std)                                :: dt_days_read         !! STOMATE time step read in restart file (days)
+    INTEGER(i_std)                             :: k, ji, jv, i, j, m   !! indices
+    INTEGER(i_std)                             :: ivm, ipts, icir      !! indices    
+    INTEGER(i_std)                             :: iele, ipar, imbc     !! Indices
+    INTEGER(i_std)                             :: ilitt, ilevs, icarb  !! Indices 
+    INTEGER(i_std)                             :: date_read            !! STOMATE date read in restart file (days)
+    REAL(r_std),PARAMETER                      :: max_dt_days = 5.     !! Maximum STOMATE time step (days)
+    REAL(r_std),DIMENSION(0:nbdl)              :: z_soil               !! Variable to store depth of the different soil 
+                                                                       !! layers (m) 
+    REAL(r_std),DIMENSION(npts,nvm)            :: rprof                !! Coefficient of the exponential functions that 
+                                                                       !! relates root density to soil depth (unitless) 
+    REAL(r_std),DIMENSION(npts)                :: precip               !! Total liquid and solid precipitation  
+                                                                       !! @tex $(??mm dt_slow^{-1})$ @endtex 
+    REAL(r_std),DIMENSION(npts,nvm)            :: gpp_d                !! Gross primary productivity per ground area 
+                                                                       !! @tex $(??gC m^{-2} dt_slow^{-1})$ @endtex  
+    REAL(r_std),DIMENSION(npts,nvm)            :: gpp_daily_x          !! "Daily" gpp for teststomate  
+                                                                       !! @tex $(??gC m^{-2} dt_slow^{-1})$ @endtex 
+    REAL(r_std),DIMENSION(npts,nvm)            :: resp_hetero_litter   !! Litter heterotrophic respiration per ground area 
+                                                                       !! @tex $(gC m^{-2} day^{-1})$ @endtex  
+                                                                       !! ??Same variable is also used to 
+                                                                       !! store heterotrophic respiration per ground area 
+                                                                       !! over ::dtradia?? 
+    REAL(r_std),DIMENSION(npts,nvm)            :: resp_hetero_soil     !! soil heterotrophic respiration  
+                                                                       !! @tex $(gC m^{-2} day^{-1})$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm)            :: veget_cov            !! Fractional coverage: actually share of the pixel 
+                                                                       !! covered by a PFT (fraction of ground area), 
+                                                                       !! taking into account LAI ??(= grid scale fpc)?? 
+    REAL(r_std),DIMENSION(npts,nvm)            :: vcmax                !! Maximum rate of carboxylation
+                                                                       !! @tex $(\mumol m^{-2} s^{-1})$ @endtex
+    REAL(r_std),DIMENSION(npts,nlevs)          :: control_moist_inst   !! Moisture control of heterotrophic respiration 
+                                                                       !! (0-1, unitless) 
+    REAL(r_std),DIMENSION(npts,nlevs)          :: control_temp_inst    !! Temperature control of heterotrophic 
+                                                                       !! respiration, above and below (0-1, unitless) 
+    REAL(r_std),DIMENSION(npts,ncarb,nvm)      :: soilcarbon_input_inst!! Quantity of carbon going into carbon pools from 
+                                                                       !! litter decomposition 
+                                                                       !! @tex $(gC m^{-2} day^{-1})$ @endtex
+    INTEGER(i_std)                             :: ier                  !! Check errors in netcdf call (unitless)
+    REAL(r_std),SAVE                           :: dt_forcesoil         !! Time step of soil forcing file (days)
+    !$OMP THREADPRIVATE(dt_forcesoil)
+    INTEGER(i_std),PARAMETER                   :: nparanmax=366        !! Maximum number of time steps per year for 
+                                                                       !! forcesoil 
+    INTEGER(i_std),SAVE                        :: nparan               !! Number of time steps per year for forcesoil - 
+                                                                       !! read from run definition (unitless) 
+    !$OMP THREADPRIVATE(nparan)
+    INTEGER(i_std),SAVE                        :: nbyear=1             !! Number of years saved for forcesoil - read from 
+                                                                       !! run definition (unitless) 
+    !$OMP THREADPRIVATE(nbyear)
+    INTEGER(i_std),SAVE                        :: iatt                 !! Time step of forcing of soil processes (iatt = 1 
+                                                                       !! to ::nparan*::nbyear) 
+    !$OMP THREADPRIVATE(iatt)
+    INTEGER(i_std),SAVE                        :: iatt_old=1           !! Previous ::iatt
+    !$OMP THREADPRIVATE(iatt_old)
+    REAL(r_std)                                :: sf_time              !! Intermediate variable to calculate current time 
+                                                                       !! step 
+    INTEGER(i_std)                             :: max_totsize          !! Memory management - maximum memory size (Mb)
+    INTEGER(i_std)                             :: totsize_1step        !! Memory management - memory required to store one 
+                                                                       !! time step on one processor (Mb) 
+    INTEGER(i_std)                             :: totsize_tmp          !! Memory management - memory required to store one 
+                                                                       !! time step on all processors(Mb) 
+    REAL(r_std)                                :: xn                   !! How many times have we treated in this forcing 
+                                                                       !! state 
+    INTEGER(i_std),SAVE                        :: nsfm                 !! Number of time steps that can be stored in 
+                                                                       !! memory (unitless) 
+    !$OMP THREADPRIVATE(nsfm)
+    INTEGER(i_std),SAVE                        :: nsft                 !! Number of time steps in a year (unitless)
+    !$OMP THREADPRIVATE(nsft)
+    INTEGER(i_std),SAVE                         :: iisf                !! Current pointer for teststomate (unitless)
+    !$OMP THREADPRIVATE(iisf)
+    REAL(r_std), DIMENSION(npts)               :: vartmp               !! Temporary variable
+    CHARACTER(LEN=100), SAVE                   :: forcing_name         !! Name of forcing file 1
+    !$OMP THREADPRIVATE(forcing_name)
+    CHARACTER(LEN=100), SAVE                   :: Cforcing_name        !! Name of forcing file 2
+    !$OMP THREADPRIVATE(Cforcing_name)
+    INTEGER(i_std),SAVE                        :: Cforcing_id          !! File identifer of file 2
+    !$OMP THREADPRIVATE(Cforcing_id)    
+    INTEGER(i_std),PARAMETER                   :: ndm = 10             !! Maximum number of dimensions (unitless)
+    INTEGER(i_std)                             :: vid                  !! Variable identifer of netCDF (unitless)
+    INTEGER(i_std)                             :: nneigh               !! Number of neighbouring pixels
+    INTEGER(i_std)                             :: direct               !! ??
+    INTEGER(i_std),DIMENSION(ndm)              :: d_id                 !! ??
+
+    REAL(r_std),DIMENSION(npts,nvm)            :: t_root               !! ??[DISPENSABLE] Root temperature (K) convolution 
+                                                                       !! of root and soil temperature profiles 
+    REAL(r_std),DIMENSION(npts,nparts)         :: t_maint_radia        !! ??[DISPENSABLE] Temperature which is pertinent 
+                                                                       !! for maintenance respiration (K) 
+    REAL(r_std),DIMENSION(npts)                :: rpc                  !! ??[DISPENSABLE] Integration constant for root 
+                                                                       !! profile (unitless) 
+    REAL(r_std),DIMENSION(npts)                :: tl                   !! ??[DISPENSABLE] long term annual mean 
+                                                                       !! temperature, C 
+    REAL(r_std),DIMENSION(npts)                :: slope                !! ??[DISPENSABLE] slope of maintenance respiration 
+                                                                       !! coefficient (1/K) 
+    !    INTEGER(i_std)                            :: iyear            !! ??[DISPENSABLE]
+    REAL(r_std)                                :: net_co2_flux_monthly !! ??[DISPENSABLE]
+    REAL(r_std)                                :: net_co2_flux_monthly_sum !! ??[DISPENSABLE]
+    !    INTEGER                                   :: ios              !! ??[DISPENSABLE]
+    REAL(r_std)                                :: trans_veg            !! ??[DISPENSABLE]
+    REAL(r_std)                                :: tmp_day(1)           !! ??[DISPENSABLE]
+!!$    INTEGER(i_std),SAVE                       :: lcanop                !! ??[DISPENSABLE] soil level used for LAI
+!!$   !$OMP THREADPRIVATE(lcanop)
+    REAL(r_std),DIMENSION(nbp_glo)             :: clay_g               !! Clay fraction of soil (0-1, unitless), parallel 
+                                                                       !! computing 
+    REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:,:) :: soilcarbon_input_g   !! Quantity of carbon going into carbon pools from 
+                                                                       !! litter decomposition  
+                                                                       !! @tex $(gC m^{-2} dtradia^{-1})$ @endtex, parallel 
+                                                                       !! computing 
+    REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: control_moist_g      !! Moisture control of heterotrophic respiration 
+                                                                       !! (0-1, unitless), parallel computing 
+    REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: control_temp_g       !! Temperature control of heterotrophic respiration 
+                                                                       !! (0-1, unitless), parallel computing 
+    REAL(r_std),ALLOCATABLE,DIMENSION(:,:)     :: npp_equil_g          !! Equilibrium NPP written to forcesoil 
+                                                                       !! @tex $(gC m^{-2} year^{-1})$ @endtex, parallel 
+                                                                       !! computing 
+
+    REAL(r_std)                                :: net_cflux_prod_monthly_sum    !! AR5 output?? gC m2 month-1 (one variable for 
+                                                                       !! reduce_sum and one for bcast??), parallel 
+                                                                       !! computing 
+    REAL(r_std)                                :: net_cflux_prod_monthly_tot    !! AR5 output?? gC m2 month-1 (one variable for 
+                                                                       !! reduce_sum and one for bcast??), parallel 
+                                                                       !! computing 
+    REAL(r_std)                                :: net_harvest_above_monthly_sum !! AR5 output?? gC m2 month-1 (one variable for 
+                                                                       !! reduce_sum and one for bcast??), parallel 
+                                                                       !! computing 
+    REAL(r_std)                                :: net_harvest_above_monthly_tot !! AR5 output?? gC m2 month-1 (one variable for 
+                                                                       !! reduce_sum and one for bcast??), parallel 
+                                                                       !! computing 
+    REAL(r_std)                                :: net_biosp_prod_monthly_sum    !! AR5 output?? gC m2 month-1 (one variable for 
+                                                                       !! reduce_sum and one for bcast??), parallel 
+                                                                       !! computing 
+    REAL(r_std)                                :: net_biosp_prod_monthly_tot    !! AR5 output?? gC m2 month-1 (one variable for 
+                                                                       !! reduce_sum and one for bcast??), parallel 
+                                                                       !! computing 
+    REAL(r_std), DIMENSION(npts,nvm,nbpools)   :: carbon_stock         !! Array containing the carbon stock for each pool
+                                                                       !! used by ORCHIDEE
+    INTEGER(i_std), SAVE                       :: spinup_period        !! Period of years used to calculate the 
+                                                                       !! resolution of the system for the spinup analytic. 
+                                                                       !! This period correspond in most cases to the 
+                                                                       !! period of years of forcing data used
+    INTEGER(i_std)                             :: forest_managed_temp  !! Temporary variable to affect forest_managed(1,6)
+    REAL(r_std), DIMENSION(npts)               :: laieff_solar_angle_array !! a temporary array
+    LOGICAL                                    :: l_error              !! error flag
+    REAL(r_std)                                :: temp_total           !! Used for renormalizing
+    INTEGER(i_std)                             :: ldnight              !! Flag to only accumulate day values in stomate_accu
+    LOGICAL                                    :: lsync                !! returns false if the biomass
+                                                                       !! is not synced... do we need this?  
+                                                                       !! We could equal just handle it in the 
+                                                                       !! check_biomass_sync
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements) &
+                                               :: check_intern         !! Contains the components of the internal
+                                                                       !! mass balance chech for this routine
+                                                                       !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements) :: closure_intern       !! Check closure of internal mass balance
+                                                                       !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements) :: pool_start           !! Start and end pool of this routine 
+                                                                       !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements) :: pool_end             !! Start and end pool of this routine 
+                                                                       !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts)               :: pixel_area           !! surface area of the pixel @tex ($m^{2}$)
+    REAL(r_std), DIMENSION(npts,nvm,norphans,nelements) &
+                                               :: orphan_flux          !! Storage for fluxes of PFTs that no longer
+                                                                       !! exist. Following the total destruction of 
+                                                                       !! a PFT in LCC (veget_max_new = 0), a flux 
+                                                                       !! from before LCC needs a storage
+                                                                       !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+!!$    LOGICAL                                    :: lread_fm_map         !! A logical flag determining if we read
+!!$                                                                       !! in the forest management strategy from a map.
+    REAL(r_std), DIMENSION (npts,1)            :: temp_array
+    REAL(r_std), DIMENSION (npts,1)            :: temp_array_daily
+    
+    REAL(r_std), DIMENSION(npts,nvm)           :: tau_eff_root         !! Effective root turnover time that accounts
+                                                                       !! waterstress (days)
+    REAL(r_std), DIMENSION(npts,nvm)           :: tau_eff_sap          !! Effective sapwood turnover time that accounts
+                                                                       !! waterstress (days)
+    REAL(r_std), DIMENSION(npts,nvm)           :: tau_eff_leaf         !! Effective leaf turnover time that accounts
+                                                                       !! waterstress (days)
+    REAL(r_std), DIMENSION(npts,nvm)           :: wstress_adapt        !! Factor to account for a long acclimation of
+                                                                       !! of the PFT to the long-term waterstress in
+                                                                       !! the pixel
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)  &
+                                               :: fm_map_temp          !! A temporary variable to hold the forest
+                                                                       !! management map which is read in from a file
+                                                                       !! (0-4,unitless)
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)  &
+                                               :: species_map_temp     !! A temporary variable to hold the species
+                                                                       !! change map which is read in from a file
+                                                                       !! (1-nvm,unitless)
+
+!_ ================================================================================================================================
+
+    IF (bavard >= 4) THEN
+       WRITE(numout,*) 'Entering stomate bavard',l_first_stomate,control%ok_stomate
+    ENDIF
+    !! 1. Initialize variables
+    ! This is an INTENT(OUT), and otherwise some times does not get set.
+    co2_flux(:,:) = zero
+    
+
+    !! 1.1 Store current time step in a common variable
+    itime = kjit
+
+    !![DISPENSABLE] 1.2 Copy the depth of the different soil layers from diaglev specified in slow_proc
+
+    !! 1.3 PFT rooting depth across pixels, humescte is pre-defined 
+    ! (constantes_veg.f90). It is defined as the coefficient of an exponential 
+    ! function relating root density to depth 
+    DO j=1,nvm
+       rprof(:,j) = 1./humcste(j)     
+    ENDDO
+
+    !! 1.4 Initialize first call
+    ! Set growth respiration to zero
+    resp_growth(:,:) = zero
+ 
+    IF (l_first_stomate) THEN
+       IF (long_print) THEN
+          WRITE (numout,*) 'l_first_stomate : call stomate_init'
+       ENDIF
+
+       !! 1.4.0 Parameters for spinup
+       !
+       eps_carbon = 0.01
+       !Config Key   = EPS_CARBON
+       !Config Desc  = Allowed error on carbon stock
+       !Config If    = SPINUP_ANALYTIC
+       !Config Def   = 0.01
+       !Config Help  = 
+       !Config Units = [%]   
+       CALL getin_p('EPS_CARBON',eps_carbon)       
+
+       !Config Key   = SPINUP_PERIOD
+       !Config Desc  = Period to calulcate equilibrium during spinup analytic
+       !Config If    = SPINUP_ANALYTIC
+       !Config Def   = -1
+       !Config Help  = Period corresponds in most cases to the number of years of forcing data used in the spinup.
+       !Config Units = [years]   
+       spinup_period = -1
+       CALL getin_p('SPINUP_PERIOD',spinup_period)       
+
+       ! Check spinup_period values. 
+       ! For periods uptil 6 years, to obtain equilibrium, a bigger period have to be used 
+       ! and therefore spinup_period is adjusted to 10 years. 
+       IF (spinup_analytic) THEN
+          IF (spinup_period <= 0) THEN
+             WRITE(numout,*) 'Error in parameter spinup_period. This parameter must be > 0 : spinup_period=',spinup_period
+             CALL ipslerr_p (3,'stomate_main', &
+                  'Parameter spinup_period must be set to a positive integer.', &
+                  'Set this parameter to the number of years of forcing data used for the spinup.', &
+                  '')
+         ELSE IF (spinup_period <= 6) THEN
+             ! Adjust to bigger period. The period must be a multiple of the original period.
+!!             WRITE(numout,*) 'Initial spinup_period =',spinup_period,' will be adjusted.'
+ !!            spinup_period = spinup_period*(INT(9/spinup_period)+1)
+ !DSG    WRITE(numout,*) 'Initial spinup_period =',spinup_period,' will be
+ !adjusted.'
+          WRITE(numout,*) 'Initial spinup_period =',spinup_period,' will be not adjusted.'
+      !DSG:    spinup_period = spinup_period*(INT(9/spinup_period)+1)
+
+         END IF
+
+
+          WRITE(numout,*) 'Spinup analytic is activated using eps_carbon=',eps_carbon, ' and spinup_period=',spinup_period
+       END IF
+
+       !! 1.4.0 Initialization of PFT specific parameters 
+       ! Initialization of PFT specific parameters that have no value
+       ! for the bare soil PFT i.e. fire resistance, flamability, maximum lai,
+       ! settings for growing degree days (GDD), settings for senescence, 
+       ! respiration coefficients, photosynthesis, etc.
+       ! [DISPENSABLE]
+
+       !! 1.4.1 Allocate memory for all variables in stomate
+       ! Allocate memory for all variables in stomate, build new index
+       ! tables accounting for the PFTs, read and check flags and set file
+       ! identifier for restart and history files.
+       CALL stomate_init (kjpij, npts, index, ldforcing_write, lalo, &
+            rest_id_stom, hist_id_stom, hist_id_stom_IPCC)
+
+       !! 1.4.2 Initialization of PFT specific parameters
+       ! Initialization of PFT specific parameters i.e. sla from leaf life, 
+       ! sapling characteristics (biomass), migration speed, critical diameter,
+       ! coldest tolerable temperature, critical values for phenology, maximum
+       ! life time of leaves, respiration coefficients and photosynthesis.
+       ! The subroutine also communicates settings read by stomate_constant_init.
+
+       CALL data
+       !       CALL data (npts, lalo)
+
+       !! 1.4.3 Initial conditions
+
+       !! 1.4.3.1 Read initial values for STOMATE's variables from the _restart_ file
+       ! ??Shouldn't this be included in stomate_init?? Looks like an initialization!
+       fco2_lu(:) = zero
+
+       !! 1.4.3.2 Read the management status of (i,j) (has to be done before readrestart)
+       ! this is the first call in this loop, so why is this check here?  It should just
+       ! be initialised...otherwise the check is over uninitialized values,
+
+       forest_managed_lastyear(:,:) = 0
+
+       !Config Key   = FOREST_MANAGED
+       !Config Desc  =
+       !Config If    = OK_STOMATE
+       !Config Def   = 0
+       !Config Help  =
+       !Config Units =
+       !  Here we use different defaults for the case of functional
+       ! allocation and resource limited allocation, since using
+       ! functional allocation means that forestry is always actived.
+       ! However, a setting of 1 means don't do any human management.
+       IF(control%ok_functional_allocation)THEN
+
+          forest_managed_temp=1
+
+       ELSE
+
+          forest_managed_temp=0
+
+       ENDIF
+       CALL getin_p('FOREST_MANAGED_FORCED',forest_managed_temp)
+       forest_managed(:,:) = forest_managed_temp
+
+       ! We need to have the option to read the forest management
+       ! strategy from a map (NetCDF file).  If this option is
+       ! equal to Y, we will overwrite the forest_managed_forced 
+       ! option above, so you should be careful to only use one
+       ! or the other.  
+       IF(lread_fm_map)THEN
+          
+          ! If we are using age classes, we read in the map in the same
+          ! way but then we change it a bit to account for age classes.
+          l_error = .FALSE.
+          ALLOCATE(fm_map_temp(npts,nvmap),stat=ier)
+          l_error = l_error .OR. (ier /= 0)
+          IF (l_error) THEN
+             WRITE(numout,*) 'Problem with memory allocation: temporary FM map ',npts,nvmap
+             CALL ipslerr_p (3,'stomate_main', &
+                  'Problem with memory allocation','','')
+          ENDIF
+
+          CALL read_in_fm_map(npts, lalo, neighbours, resolution, &
+               contfrac, fm_map_temp)
+          IF(nagec .GT. 1)THEN
+             ! All age classes of the same PFT will have the same
+             ! management
+             DO ivm = 1,nvm
+                forest_managed(:,ivm)=fm_map_temp(:,agec_group(ivm))
+             ENDDO
+
+          ELSE
+             forest_managed(:,:)=fm_map_temp(:,:)
+ 
+          ENDIF
+
+          DEALLOCATE(fm_map_temp)
+ 
+       ENDIF
+
+       ! If we are doing litter raking, we need a map which
+       ! tells us how much litter is required at every pixel.
+       ! This number is independent of the PFTs.  
+       IF(use_litter_raking)THEN
+          
+          CALL read_in_litter_map(npts, lalo, neighbours, resolution, &
+               contfrac, litter_demand)
+
+       ENDIF
+
+       ! Get values from _restart_ file. Note that only ::npts, ::index, ::lalo 
+       ! and ::resolution are input variables, all others are output variables.
+       CALL readrestart (npts, index, lalo, resolution, neighbours, contfrac, &
+            day_counter_read, dt_days_read, date_read, ind, & 
+            adapted, regenerate, humrel_daily, gdd_init_date, &
+            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, &
+            humrel_growingseason, 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_from_growthinit, 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, senescence_days, 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, lignin_wood, turnover_time, &
+            prod_s, prod_m, prod_l, flux_s, flux_m, flux_l, &
+            cflux_prod_s, cflux_prod_m, cflux_prod_l, bm_to_litter, &
+            carb_mass_total, &
+            age_stand, rotation_n, last_cut, &
+            forest_managed, forest_managed_lastyear, global_years, &
+            ok_equilibrium, nbp_accu, nbp_flux, MatrixV, &
+            VectorU, previous_stock, current_stock, rue_longterm, &
+            fpc_max, circ_class_n, circ_class_biomass, KF, &
+            mai, pai, previous_wood_volume, mai_count, coppice_dens, &
+            vir_humrel_growingseason, lai_per_level, laieff_fit, temp_growth, &
+            wstress_season, wstress_month, vir_wstress_fac, c_buried, &
+            k_latosa_adapt, species_change_map, lpft_replant, &
+counter_psi,counter_2,counter_0,resp_hetero_litter_d,resp_hetero_soil_d)
+
+       !---TEMP---
+       CALL check_biomass_sync("stomate.f90: After readstart", npts, biomass, &
+            circ_class_biomass, circ_class_n, ind, &
+            lsync, bm_sync)      
+
+       ! If we are doing species change, we need to read in the map or force
+       ! the values.  We do this after the restart because otherwise our
+       ! values are overwritten.  In this sense, it doesn't really seem
+       ! to be a good idea to read it in the restart, does it.
+       IF(lchange_species)THEN
+
+          IF(lread_species_change_map)THEN
+             ! If we are using age classes, we read in the map in the same
+             ! way but then we change it a bit to account for age classes.
+             l_error = .FALSE.
+             ALLOCATE(species_map_temp(npts,nvmap),stat=ier)
+             l_error = l_error .OR. (ier /= 0)
+             IF (l_error) THEN
+                WRITE(numout,*) 'Problem with memory allocation: temporary species change map ',npts,nvmap
+                CALL ipslerr_p (3,'stomate_main', &
+                  'Problem with memory allocation','','')
+             ENDIF
+             
+             CALL read_in_species_change_map(npts, lalo, neighbours, resolution, &
+                  contfrac, species_map_temp)
+             
+             IF(nagec .GT. 1)THEN
+                ! All age classes of the same PFT will have the same
+                ! management
+                DO ivm = 1,nvm
+                   species_change_map(:,ivm)=species_map_temp(:,agec_group(ivm))
+                ENDDO
+                
+             ELSE
+                species_change_map(:,:)=species_map_temp(:,:)
+             ENDIF
+             
+             DEALLOCATE(species_map_temp)
+             
+          ELSE
+             species_change_map(:,:)=species_change_force
+          ENDIF
+
+       ENDIF      
+
+       !! 1.4.4 If the vegetation is dynamic
+       ! If the vegetation is dynamic, long-term reference temperature was 
+       ! read by the call above. If vegetation is static then the long-term 
+       ! reference temperature is a boundary condition and read here.  
+       CALL readbc (npts, lalo, neighbours, resolution, contfrac, tlong_ref)
+
+       !! 1.4.5 Check time step
+
+       !! 1.4.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.4.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 not a mutiple of a full day:', &
+               & dt_days,' days.'
+          CALL ipslerr_p (3,'stomate_main', &
+                  'Problem with stomate time step','','')
+       ENDIF
+
+       !! 1.4.5.3 upper limit to STOMATE's time step
+       IF ( dt_days > max_dt_days ) THEN
+          WRITE(numout,*) 'slow_processes: STOMATE time step exceeds the maximum value:', &
+               & dt_days,' days > ', max_dt_days, ' days.'  
+          CALL ipslerr_p (3,'stomate_main', &
+                  'Problem with stomate time step','','')
+       ENDIF
+
+       !! 1.4.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 ::dt_days smaller than forcing time step ::dtradia'
+          CALL ipslerr_p (3,'stomate_main', &
+                  'Problem with stomate time step','','')
+       ENDIF
+
+       !! 1.4.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.4.5.6 Date check
+       IF (date /= date_read) THEN
+          WRITE(numout,*) 'Slow_processes: STOMATE date changes:', &
+               date_read,' -> ',date
+       ENDIF
+
+       !! 1.4.5.6 Final message on time step
+       WRITE(numout,*) 'Slow_processes, STOMATE time step (days): ', dt_days
+
+       !! 1.4.6 Write forcing file for stomate?
+       IF (ldforcing_write) THEN
+
+          !Config Key   = STOMATE_FORCING_NAME
+          !Config Desc  = Name of STOMATE's forcing file
+          !Config If    = OK_STOMATE
+          !Config Def   = NONE
+          !Config Help  = Name that will be given
+          !Config         to STOMATE's offline forcing file
+          !Config         Compatible with Nicolas Viovy's driver
+          !Config Units = [FILE]
+          forcing_name = stomate_forcing_name
+          CALL getin_p('STOMATE_FORCING_NAME',forcing_name)
+
+          IF ( TRIM(forcing_name) /= 'NONE' ) THEN
+
+             !! 1.4.6.1 Calculate steps that can be stored in memory
+             ! Action for the root processor only (parallel computing)  
+             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 
+             !Config If    = OK_STOMATE
+             !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.
+             !Config Units = [MegaBytes]
+             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(veget)*KIND(veget) &
+                  &     +SIZE(veget_max)*KIND(veget_max) &
+                  &     +SIZE(lai)*KIND(lai)
+
+             ! Totsize_1step is the size on a single processor, sum
+             ! all processors and send to all processors
+             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))))
+
+
+	     !! 1.6.4.2 Allocate memory for variables containing forcing data  
+             ! and initialize variables (set to zero).
+             CALL init_forcing (npts,nsfm,nsft)
+
+             ! Indexing for writing forcing file
+             isf(:) = (/ (i,i=1,nsfm) /)
+             nf_written(:) = .FALSE.
+             nf_cumul(:) = 0
+             iisf = 0
+
+             !! 1.6.4.3 Create netcdf file
+             ! Create, define and populate a netcdf file containing the forcing data.
+             ! For the root processor only (parallel computing). NF90_ are functions
+             ! from and external library.  
+             IF (is_root_prc) THEN
+
+                ! Create new netCDF dataset
+                ier = NF90_CREATE (TRIM(forcing_name),NF90_SHARE,forcing_id)
+
+                ! Add variable attribute
+                ! Note ::iim_g and ::jjm_g are dimensions of the global field and 
+                ! ::nbp_glo is the number of global continental points
+                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, &
+                     & 'npts',REAL(nbp_glo,r_std))
+
+                ! Add new dimension
+                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',NF90_UNLIMITED,d_id(6))
+                ier = NF90_DEF_DIM (forcing_id,'nbparts',nparts,d_id(7))
+
+                ! Add new variable
+                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,'sinang', &
+                     & r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
+                ier = NF90_ENDDEF (forcing_id)
+
+		! Given the name of a varaible, nf90_inq_varid finds the variable 
+                ! ID (::vid). Put data value(s) into variable ::vid
+                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 ! is_root_prc
+          ENDIF ! (forcing_name) /= 'NONE'
+       ENDIF ! ldforcing_write =.TRUE.
+
+       !! 1.4.7 write forcing file for the soil?
+       IF (ldcarbon_write) THEN
+
+          !! 1.4.7.1 Initialize
+          !Config Key   = STOMATE_CFORCING_NAME
+          !Config Desc  = Name of STOMATE's carbon forcing file
+          !Config If    = OK_STOMATE
+          !Config Def   = NONE
+          !Config Help  = Name that will be given to STOMATE's carbon
+          !Config         offline forcing file
+          !Config         Compatible with Nicolas Viovy's driver
+          !Config Units = [FILE]
+          Cforcing_name = stomate_Cforcing_name
+          CALL getin_p('STOMATE_CFORCING_NAME',Cforcing_name)
+
+          IF ( TRIM(Cforcing_name) /= 'NONE' ) THEN
+
+             ! Time step of forcesoil
+             !Config Key   = FORCESOIL_STEP_PER_YEAR
+             !Config Desc  = Number of time steps per year for carbon spinup.
+             !Config If    = OK_STOMATE
+             !Config Def   = 365
+             !Config Help  = Number of time steps per year for carbon spinup.
+             !Config Units = [days, months, year]
+             nparan = 365
+             CALL getin_p('FORCESOIL_STEP_PER_YEAR', nparan)
+
+             ! Correct if setting is out of bounds 
+             IF ( nparan < 1 ) nparan = 1
+
+             !Config Key   = FORCESOIL_NB_YEAR
+             !Config Desc  = Number of years saved for carbon spinup.
+             !Config If    = OK_STOMATE
+             !Config Def   = 1
+             !Config Help  = Number of years saved for carbon spinup. If internal parameter cumul_Cforcing is TRUE in stomate.f90
+             !Config         Then this parameter is forced to one.
+             !Config Units = [years]
+             CALL getin_p('FORCESOIL_NB_YEAR', nbyear)
+
+             ! Set ::nbyear to 1. if ::cumul_Cforcing=.TRUE.
+             IF ( cumul_Cforcing ) THEN
+                CALL ipslerr_p (1,'stomate', &
+                     &          'Internal parameter cumul_Cforcing is TRUE in stomate.f90', &
+                     &          'Parameter FORCESOIL_NB_YEAR is therefore forced to 1.', &
+                     &          '::nbyear is thus set to 1.')
+                nbyear=1
+             ENDIF
+
+             ! Make use of ::nparan to calculate ::dt_forcesoil
+             dt_forcesoil = zero
+             nparan = nparan+1
+             DO WHILE ( dt_forcesoil < dt_slow/one_day )
+                nparan = nparan-1
+                IF ( nparan < 1 ) THEN
+                   CALL ipslerr_p (3,'stomate_main', &
+                        'Problem with number of soil forcing time steps ::nparan < 1.',&
+                        '','')
+                ENDIF
+                dt_forcesoil = one_year/REAL(nparan,r_std)
+             ENDDO
+             IF ( nparan > nparanmax ) THEN
+                CALL ipslerr_p (3,'stomate_main', &
+                     'Problem with number of soil forcing time steps ::nparan > ::nparanmax',&
+                     '','')
+             ENDIF
+             WRITE(numout,*) 'Time step of soil forcing (d): ',dt_forcesoil
+
+             ! Allocate memory for the forcing variables of soil dynamics
+             ALLOCATE( nforce(nparan*nbyear))
+             nforce(:) = 0
+             ALLOCATE(control_moist(npts,nlevs,nparan*nbyear))
+             ALLOCATE(npp_equil(npts,nparan*nbyear))
+             ALLOCATE(npp_tot(npts))
+             ALLOCATE(control_temp(npts,nlevs,nparan*nbyear))
+             ALLOCATE(soilcarbon_input(npts,ncarb,nvm,nparan*nbyear)) 
+
+             ! Initialize variables, set to zero
+             control_moist(:,:,:) = zero
+             npp_equil(:,:) = zero
+             npp_tot(:) = zero
+             control_temp(:,:,:) = zero
+             soilcarbon_input(:,:,:,:) = zero
+
+          ENDIF ! Cforcing_name) /= 'NONE'
+       ENDIF ! ::ldcarbon_write!.TRUE.
+
+       !! 1.4.8 Calculate STOMATE's vegetation fractions from veget, veget_max
+       DO j=1,nvm
+          WHERE ((1.-totfrac_nobio(:)) > min_sechiba)       
+             ! Pixels with vegetation
+             veget_cov(:,j) = veget(:,j)/( 1.-totfrac_nobio(:) )
+             veget_cov_max(:,j) = veget_max(:,j)/( 1.-totfrac_nobio(:) )
+          ELSEWHERE
+             ! Pixels without vegetation
+             veget_cov(:,j) = zero
+             veget_cov_max(:,j) = zero
+          ENDWHERE
+       ENDDO ! Loop over PFTs
+       IF ( EndOfYear ) THEN
+          DO j=1,nvm
+             WHERE ((1.-totfrac_nobio_new(:)) > min_sechiba)
+                ! Update pixels with vegetation
+                veget_cov_max_new(:,j) = veget_max_new(:,j)/( 1.-totfrac_nobio_new(:) )
+             ELSEWHERE
+                ! Update pixels without vegetation
+                veget_cov_max_new(:,j) = zero
+             ENDWHERE
+          ENDDO
+       ENDIF
+
+       !! 1.4.9 Initialize non-zero variables
+       IF (control%ok_stomate) THEN
+          CALL stomate_var_init &
+               &         (npts, veget_cov_max, leaf_age, leaf_frac, &
+               &          tlong_ref, t2m_month, dead_leaves, &
+               &          forest_managed, age_stand, &
+               &          deadleaf_cover, assim_param)
+
+
+          !! Calculate the initial effective lai
+          !  Convert the 3-D physiological 'true' lai to an effective lai for the 1-D
+          !  two stream radiation model...this only needs to be done if we are
+          !  using the two stream model
+          ! this cannot be done here because the diameter has not yet been calculated
+          ! in stomatelpj
+
+          SELECTCASE (albedo_type)
+          CASE ('pinty')
+!             CALL effective_lai (npts, lai, biomass, ind, laieff_isotrop)
+
+             ! This is now down in the restart
+             !CALL laieff_type_init(npts, nlevels_tot, laieff_fit)
+             !             circ_class_biomass_out=circ_class_biomass
+             !             circ_class_n_out=circ_class_n
+          END SELECT
+
+          ! This is a variable read in from the input file.  The problem is
+          ! that is depends on ncirc, which is also read in from the input
+          ! file, so I can't allocate it in the usual place (pft_parameters.f90).
+          ! So I will allocate it and deallocate it here, since it is only
+          ! used by stomate.
+          l_error = .FALSE.
+
+          ALLOCATE(circ_class_dist(ncirc),stat=ier)
+          l_error = l_error .OR. (ier /= 0)
+          IF (l_error) THEN
+             WRITE(numout,*) ' Memory allocation error for circ_class_dist. ' // &
+                  'We need ncirc words = ',ncirc
+             CALL ipslerr_p (3,'stomate_main', &
+                  'Memory allocation error for circ_class_dist','','')
+          END IF
+          !Config Key   = CIRC_CLASS_DIST
+          !Config Desc  = The tree distribution to target if we have to redistribute.
+          !Config if    = OK_STOMATE
+          !Config Def   = 1
+          !Config Help  =
+          !Config Units = [-]
+          circ_class_dist(:)=un
+          CALL getin_p('CIRC_CLASS_DIST',circ_class_dist)
+
+          ! Now we normalize the distribution
+          temp_total=SUM(circ_class_dist(:))
+          circ_class_dist(:)=circ_class_dist(:)/temp_total
+          WRITE(numout,*) 'Target distribution for renormalization: ',circ_class_dist(:)
+        
+
+          ALLOCATE(st_dist(ncirc),stat=ier)
+          l_error = l_error .OR. (ier /= 0)
+          IF (l_error) THEN
+             WRITE(numout,*) ' Memory allocation error for st_dist. ' // &
+                  'We need ncirc words = ',ncirc
+             CALL ipslerr_p (3,'stomate_main', &
+                  ' Memory allocation error for st_dist.','','')
+          END IF
+          !Config Key   = ST_DIST
+          !Config Desc  = The distribution for killing trees in self-thinning.
+          !Config if    = OK_STOMATE
+          !Config Def   = circ_class_dist
+          !Config Help  =
+          !Config Units = [-]
+          st_dist(:)=circ_class_dist(:)
+          CALL getin_p('ST_DIST',st_dist)
+ 
+          ! Now we normalize the distribution
+          temp_total=SUM(st_dist(:))
+          st_dist(:)=st_dist(:)/temp_total
+          WRITE(numout,*) 'Target distribution for self-thinning: ',st_dist(:)
+
+
+       ENDIF
+
+       !! 1.4.10 Update flag
+       l_first_stomate = .FALSE.
+
+       RETURN ! Out of stomate main
+    ENDIF  ! First call
+
+    IF (bavard >= 0 .AND. ld_date) THEN
+       WRITE(numout,*) 'stomate_main: date=',date,' ymds=', year, month, day, sec, ' itime=', itime, ' do_slow=',do_slow
+    ENDIF
+
+    !! 2. Prepares restart file for the next simulation
+
+    !! 2.1 Write restart file for stomate
+    IF (ldrestart_write) THEN
+       IF (long_print) THEN
+          WRITE (numout,*) &
+               &      ' Write a restart file for STOMATE'
+       ENDIF
+
+      CALL writerestart (npts, index, day_counter, dt_days, &
+            date, ind, adapted, regenerate, &
+            humrel_daily, gdd_init_date, 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, humrel_growingseason, 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_from_growthinit, 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, senescence_days, &
+            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, & 
+            lignin_wood, turnover_time, prod_s, prod_m, prod_l, &
+            flux_s, flux_m, flux_l, cflux_prod_s, cflux_prod_m, &
+            cflux_prod_l, bm_to_litter, carb_mass_total, &
+            age_stand, &
+            rotation_n, last_cut, forest_managed, forest_managed_lastyear, &
+            global_years, ok_equilibrium, nbp_accu, &
+            nbp_flux, MatrixV, VectorU, previous_stock, &
+            current_stock, rue_longterm, fpc_max, &
+            circ_class_n, circ_class_biomass, KF, &
+            mai, pai, previous_wood_volume, &
+            mai_count, coppice_dens, vir_humrel_growingseason, lai_per_level,&
+            laieff_fit, temp_growth, wstress_season, wstress_month, &
+            vir_wstress_fac, c_buried, k_latosa_adapt, species_change_map,&
+            lpft_replant,counter_psi,counter_2,counter_0,resp_hetero_litter_d,resp_hetero_soil_d)
+
+       !! 2.2 Write file with variables that force general processes in stomate
+       IF (ldforcing_write .AND. TRIM(forcing_name) /= 'NONE' ) THEN  
+          CALL forcing_write(forcing_id,1,iisf)
+          ! Close forcing file
+          IF (is_root_prc) ier = NF90_CLOSE (forcing_id)
+          forcing_id=-1
+       ENDIF
+
+       !! 2.3 Collect variables that force the soil processes in stomate
+       IF (ldcarbon_write .AND. TRIM(Cforcing_name) /= 'NONE' ) THEN 
+
+          !! 2.3.1 Collect variables 
+          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
+
+          ! Allocate memory for parallel computing
+          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
+
+          ! Gather distributed variables
+          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)
+
+          !! 2.3.2 Create netcdf
+          ! Create, define and populate a netcdf file containing the forcing data.
+          ! For the root processor only (parallel computing). NF90_ are functions
+          ! from and external library.  
+          IF (is_root_prc) THEN
+             WRITE (numout,*) 'Create Cforcing file : ',TRIM(Cforcing_name)
+             ! Create new netCDF dataset
+             ier = NF90_CREATE (TRIM(Cforcing_name),NF90_64BIT_OFFSET ,Cforcing_id)
+             IF (ier /= NF90_NOERR) THEN
+                WRITE (numout,*) 'Error in creating Cforcing file : ',TRIM(Cforcing_name)
+                CALL ipslerr_p (3,'stomate_main', &
+                     &        'PROBLEM creating Cforcing file', &
+                     &        NF90_STRERROR(ier),'')
+             END IF
+
+             ! Add variable attribute
+             ! Note ::nbp_glo is the number of global continental points
+             ier = NF90_PUT_ATT (Cforcing_id,NF90_GLOBAL, &
+                  &                        'npts',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))
+
+             ! Add new dimension
+             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',NF90_UNLIMITED,d_id(5))
+
+             ! Add new variable
+             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)
+
+             ! Given the name of a varaible, nf90_inq_varid finds the variable 
+             ! ID (::vid). Put data value(s) into variable ::vid 
+             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 )
+
+             ! Close netCDF
+             ier = NF90_CLOSE (Cforcing_id)
+             IF (ier /= NF90_NOERR) THEN
+                CALL ipslerr_p (3,'stomate_main', &
+                     &        'PROBLEM in closing Cforcing file', &
+                     &        NF90_STRERROR(ier),'')
+             END IF
+
+             Cforcing_id = -1
+          ENDIF
+
+          ! Clear memory
+          IF (is_root_prc) THEN
+             DEALLOCATE(soilcarbon_input_g)
+             DEALLOCATE(control_moist_g)
+             DEALLOCATE(control_temp_g)
+             DEALLOCATE(npp_equil_g)
+          ENDIF
+
+       ENDIF ! ldcarbon_write=.TRUE.
+       RETURN ! This routine is only called at the last time step to write a netcdf for forcesoil, 
+       ! the rest of the code does not need to be executed.
+
+    ENDIF  ! write restart-files
+
+
+!! 3. Special treatment for some input arrays.
+    
+    !! 3.1 Sum of liquid and solid precipitation
+    precip(:) = ( precip_rain(:) + precip_snow(:) )*one_day/dtradia
+
+    !! 3.2 Calculate STOMATE's vegetation fractions from veget and veget_max
+    DO j=1,nvm 
+       WHERE ((1.-totfrac_nobio(:)) > min_sechiba)
+          ! Pixels with vegetation
+          veget_cov(:,j) = veget(:,j)/( 1.-totfrac_nobio(:) )
+          veget_cov_max(:,j) = veget_max(:,j)/( 1.-totfrac_nobio(:) )
+       ELSEWHERE
+          ! Pixels without vegetation
+          veget_cov(:,j) = zero
+          veget_cov_max(:,j) = zero
+       ENDWHERE
+    ENDDO
+    IF ( EndOfYear ) THEN
+       DO j=1,nvm
+          WHERE ((1.-totfrac_nobio(:)) > min_sechiba)
+             ! Pixels with vegetation
+             veget_cov_max_new(:,j)=veget_max_new(:,j)/( 1.-totfrac_nobio(:) )
+          ELSEWHERE
+             ! Pixels without vegetation
+             veget_cov_max_new(:,j) = zero
+          ENDWHERE
+       ENDDO
+    ENDIF
+
+    !! 3.3 Adjust time step of GPP 
+    ! No GPP for bare soil
+    gpp_d(:,1) = zero
+    ! GPP per PFT
+    DO j = 2,nvm   
+       WHERE (veget_cov_max(:,j) > min_stomate)
+          ! The PFT is available on the pixel
+          gpp_d(:,j) =  gpp(:,j)/ veget_cov_max(:,j)* one_day/dtradia  
+       ELSEWHERE
+          ! The PFT is absent on the pixel
+          gpp_d(:,j) = zero
+       ENDWHERE
+    ENDDO
+
+    !! 3.4 The first time step of the first day of the month  
+    ! implies that the month is over
+    IF ( day == 1 .AND. sec .LT. dtradia ) THEN
+       EndOfMonth=.TRUE.
+    ELSE
+       EndOfMonth=.FALSE.
+    ENDIF
+
+  
+    !! 4. Calculate variables for dt_slow (i.e. "daily")
+
+    ! Note: If dt_days /= 1, then variables 'xx_daily' (eg. half-daily or bi-daily) are by definition
+    ! not expressed on a daily basis. This is not a problem but could be
+    ! confusing
+
+    !! 4.1. Calculate water stress accounting for hydraulic architecture
+    !  If hydraulic architecture is used, humrel_daily (water stress) for use in stomate is 
+    !  not determined from humrel as calculated in hydrol.f90, but it is calculated as the 
+    !  ratio between a proxy for stressed and unstressed ecosystem functioning. 
+    !  Nightvalues are exclude. On the first day of the simulation (no biomass)
+    !  the stressed and unstressed proxies are probably both equal to the initilazed value (=zero, 
+    !  initialized in sechiba.f90), to avoid numerical issues in this case we set humrel_daily 
+    !  to 1. If hydraulic architecture is not used humrel_daily is calculated from humrel as 
+    !  determined in hydrol. 
+    IF (control%ok_hydrol_arch) THEN
+     
+       ! Accumulate the half hourly values into a daily value. Acculate the
+       ! stressed and unstressed proxy first and then take the average. We 
+       ! first accumulate and then take the ratio because that way we better 
+       ! account for the night time values. If we do it in the other order 
+       ! we need to assign a value to the ratio during the night. Whether we
+       ! take zero or one, this will bias our waterstress number because 
+       ! the number of half hours during the night is different for the 
+       ! different pixels. So although water stress could be higher in the 
+       ! south than in the north. During the growing season, day are shorter
+       ! in the south so if we set the ratio to 1 during the night, our daily 
+       ! water stress in the south may be less than in the north because we
+       ! more 1's in the daily time series.
+
+       ! The order of the calculation may depend on the proxy used. For example, 
+       ! Accumulate transpir_supply and transpir first and then calculate ratio
+       ! By doing this water stress is buffered (it is assumed that if 
+       ! ::transpir_supply is larger than ::transpir at one timestep it can buffer 
+       ! potential water stress in the next timestep. In reality this is not the 
+       ! case: transpir_supply is a potential value not a realized one.
+       DO ipts = 1,npts
+
+          ! Sinang is the sin of the angle from the horizon this is equal 
+          ! to the cos of the zenith angle, which is what we need to 
+          ! identify night values.
+          IF (sinang(ipts) .LT. min_stomate) THEN
+           
+             ! Redundant because the value will never be used
+             ! For all pixels
+             stressed(ipts,:) = zero
+             unstressed(ipts,:) = zero
+             
+             ! For PFT1 under LCC
+             ! vir_stressed = zero
+             ! vir_unstressed = zero
+          
+          ELSE
+
+             ! No vegetation present so ecosystem functioning
+             ! was not defined
+             WHERE (veget_max(ipts,:) .LT. min_stomate)
+
+                ! To avoid uninitialized values
+                stressed(ipts,:) = zero
+                unstressed(ipts,:) = zero
+                
+                ! Update the values to avoid uninitialized fields
+                ! in ::stressed_daily and ::unstressed_daily
+                stressed_daily(ipts,:) = stressed_daily(ipts,:) + &
+                     stressed(ipts,:)
+                unstressed_daily(ipts,:) = unstressed_daily(ipts,:) + &
+                     unstressed(ipts,:)
+                daylight(ipts,:) = daylight(ipts,:) + 1
+                
+                ! For PFT1 under LCC
+                ! vir_stressed = zero
+                ! vir_unstressed = zero
+             
+             ELSEWHERE
+
+                ! The pixel and pft contain vegetation and their
+                ! is daylight, store values to calculate the stress
+                stressed_daily(ipts,:) = stressed_daily(ipts,:) + &
+                     stressed(ipts,:)
+                unstressed_daily(ipts,:) = unstressed_daily(ipts,:) + &
+                     unstressed(ipts,:)
+                daylight(ipts,:) = daylight(ipts,:) + 1
+
+                ! For PFT1 under LCC
+                ! vir_stressed = zero
+                ! vir_unstressed = zero
+
+             ENDWHERE
+
+          ENDIF
+
+       ENDDO
+        
+       !---TEMP---
+       IF(ld_wstress .OR. ld_hydrolarch) THEN
+          WRITE(numout,*) 'dt_slow, ', do_slow
+          DO ipts=1,npts
+             DO ivm=1,nvm
+                IF(ipts == test_grid .AND. ivm == test_pft)THEN
+                   WRITE(numout,*) 'stressed, ',stressed(test_grid,test_pft)
+                   WRITE(numout,*) 'stressed_daily, ',stressed_daily(test_grid,test_pft)
+                   WRITE(numout,*) 'unstressed, ',stressed(test_grid,test_pft)
+                   WRITE(numout,*) 'unstressed_daily, ',stressed_daily(test_grid,test_pft)
+                   WRITE(numout,*) 'daylight, ', daylight(test_grid,test_pft)
+                ENDIF
+             END DO
+          ENDDO
+       ENDIF
+       !----------
+       
+       ! Calculate the mean waterstress value at the end of each day
+       IF (do_slow) THEN
+
+          ! Calculate the ratio
+          WHERE (unstressed_daily(:,:) .LT. min_stomate &
+               .OR. stressed_daily(:,:) .LT. min_stomate)
+             
+             ! No ecosystem function thus no data, we assume
+             ! there is no water stress
+             humrel_daily(:,:) = un
+
+          ELSEWHERE
+
+             ! Calculate water stress. If we first calculate
+             ! the daily sum and then the ratio there is no need
+             ! to divide by daylight. If we accumulate ratios
+             ! we will have to divide by daylight. This is
+             ! arbitrary. To do this properly we should calculate
+             ! the turgor in the cells and calculate growth
+             ! based on that see i.e. Fatichi et al 2013, New
+             ! Phytologist. We use a simple numerical construct
+             ! (the sqrt of the ratio) to overcome that complexity.
+             humrel_daily(:,:) = stressed_daily(:,:) / &
+                  unstressed_daily(:,:)
+
+        
+          ENDWHERE
+
+          !+++CHECK+++
+          ! This needs to be done outside the where loop so that
+          ! all PFTs have vir_humrel_daily set.
+          ! vir_humrel_daily will be needed when accounting for the 
+          ! water columns following a land cover change. It is partly 
+          ! calculated in sechiba hydrol_arch but it is not passed all
+          ! the way to here. Check and fix. For the moment LCC does
+          ! not account for the water columns so ::humrel_daily and
+          ! ::vir_humrel_daily are equal to each other
+          vir_humrel_daily(:,:) = humrel_daily(:,:)
+          ! We have a problem.  wstress is no longer calculated in a way
+          ! that allows for a virtual quantity, since it's the ratio of the
+          ! stressed and unstressed GPPs...which cannot be calculated if there
+          ! is no vegetation.  Therefore, for any PFTs which are not
+          ! currently present we give the daily virtual waterstress to be
+          ! equal to one.
+          !+++++++++++
+
+          ! Set to zero to start accumulating for the next day
+          stressed_daily(:,:) = zero
+          unstressed_daily(:,:) = zero
+          daylight(:,:) = zero
+
+       ELSE
+          
+          ! Set to a large value so that it is easy to detect problems
+          ! This value should never be used. It should only be passed
+          ! to other routine at the end of the day when do_slow is false
+          humrel_daily(:,:) = large_value
+          vir_humrel_daily(:,:) = large_value
+
+       ENDIF
+
+       !---TEMP---
+       IF(ld_wstress .OR. ld_hydrolarch) THEN
+          IF (do_slow) THEN
+             WRITE(numout,*) 'humrel_daily, ',humrel_daily(:,:)
+          ENDIF
+       ENDIF
+       !----------
+
+    ! No hydrological architecture
+    ELSE
+
+       CALL stomate_accu (npts, nvm, dt_slow, dtradia, &
+            & do_slow, humrel, humrel_daily)
+       ! The variable ::vir_humrel_arch was not defined for this case
+       ! Assume no stress
+!!$        CALL stomate_accu (npts, nvm, dt_slow, dtradia, &
+!!$            & do_slow, vir_humrel_arch, vir_humrel_daily)
+       vir_humrel_daily = un
+      
+    ENDIF
+    
+    !---TEMP---
+    IF (ld_hydrolarch .OR. ld_wstress) THEN
+!!$       WRITE(numout,*) 'CHECK: humrel_arch after accumulation',humrel_daily(:,:)
+!!$       WRITE(numout,*) 'CHECK: vir_humrel_arch after accumulation',vir_humrel_daily(:,:)
+    ENDIF
+    !----------
+
+    !! 4.2 Accumulate instantaneous variables (do_slow=.FALSE.) 
+    !  Accumulate instantaneous variables (do_slow=.FALSE.) and eventually 
+    !  calculate daily mean value (do_slow=.TRUE.)
+
+    ! Technically, we need to pass arrays with two dimensions to
+    ! stomate_accu.  Some of these arrays have a single dimension,
+    ! though, so let's copy them to a two dimensional array.  
+    temp_array(:,1)=litterhumdiag(:)
+    temp_array_daily(:,1)=litterhum_daily(:)
+
+    CALL stomate_accu (npts,    1, dt_slow, dtradia, &
+         & do_slow, temp_array, temp_array_daily)
+
+    litterhum_daily(:)=temp_array_daily(:,1)
+
+    temp_array(:,1)=t2m(:)
+    temp_array_daily(:,1)=t2m_daily(:)
+
+    CALL stomate_accu (npts,    1, dt_slow, dtradia, &
+         & do_slow, temp_array, temp_array_daily)
+    
+    t2m_daily(:)=temp_array_daily(:,1)
+
+    temp_array(:,1)=temp_sol(:)
+    temp_array_daily(:,1)=tsurf_daily(:)
+
+    CALL stomate_accu (npts,    1, dt_slow, dtradia, &
+         & do_slow, temp_array, temp_array_daily)
+    
+    tsurf_daily(:)=temp_array_daily(:,1)
+
+    CALL stomate_accu (npts, nbdl, dt_slow, dtradia, &
+         & do_slow, stempdiag, tsoil_daily)
+    CALL stomate_accu (npts, nbdl, dt_slow, dtradia, &
+         & do_slow, shumdiag, soilhum_daily)
+    
+    temp_array(:,1)=precip(:)
+    temp_array_daily(:,1)=precip_daily(:)
+
+    CALL stomate_accu (npts,    1, dt_slow, dtradia, &
+         & do_slow,  temp_array, temp_array_daily)
+    
+    precip_daily(:)=temp_array_daily(:,1)
+
+    CALL stomate_accu (npts, nvm, dt_slow, dtradia, &
+         & do_slow, gpp_d, gpp_daily)
+
+    !! 4.2 Daily minimum temperature
+    t2m_min_daily(:) = MIN( t2m_min(:), t2m_min_daily(:) )
+        
+
+    !! 4.3 Calculate maintenance respiration
+    ! 
+    ! The trunk passes LAI out.  We do not, since LAI is
+    ! not a prognostic variable.  They say they do it
+    ! to overcome previous problems with natural and agricultural 
+    ! vegetation types.
+    CALL maint_respiration (npts, dtradia, t2m, tlong_ref, &
+         stempdiag, gpp, gpp_week, lab_fac, &
+         veget_cov_max, rprof, biomass, resp_maint_part_radia, &
+         circ_class_n, circ_class_biomass)
+
+    !---TEMP---
+    CALL check_biomass_sync("stomate.f90: After maint_respiration", npts, biomass, &
+         circ_class_biomass, circ_class_n, ind, &
+         lsync, bm_sync)
+ 
+
+    ! Aggregate maintenance respiration across the different plant parts 
+    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
+
+    ! Maintenance respiration separated by plant parts
+    resp_maint_part(:,:,:) = resp_maint_part(:,:,:) &
+         & + resp_maint_part_radia(:,:,:)
+
+
+    !!  4.4 Mass balance closure (dt_radia)
+    pool_start(:,:,:) = zero
+    DO iele = 1,nelements
+
+       ! Biomass pool
+       DO ipar = 1,nparts
+          pool_start(:,:,iele) = pool_start(:,:,iele) + &
+               ( bm_to_litter(:,:,ipar,iele) + &
+               turnover_daily(:,:,ipar,iele) ) * &
+               dtradia/one_day * veget_max(:,:)
+       ENDDO
+
+       ! Litter pool (gC m-2) *  (m2 m-2) 
+       DO ilitt = 1,nlitt
+          DO ilevs = 1,nlevs
+             pool_start(:,:,iele) = pool_start(:,:,iele) + &
+                  litter(:,ilitt,:,ilevs,iele) * veget_max(:,:)
+          ENDDO
+       ENDDO
+
+       ! Soil carbon (gC m-2) *  (m2 m-2)
+       DO icarb = 1,ncarb
+          pool_start(:,:,iele) = pool_start(:,:,iele) + &
+               carbon(:,icarb,:) * veget_max(:,:)
+       ENDDO
+
+    ENDDO ! # nelements
+ 
+    !! 4.5 Litter dynamics and litter heterothropic respiration
+
+    ! Including: litter update, lignin content, PFT parts, litter decay,
+    ! litter heterotrophic respiration, dead leaf soil cover.
+    ! Note: there is 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
+
+    IF (control%ok_functional_allocation) THEN
+
+       ! Litter calculation accounting for wood decomposition, needs to be used
+       ! when forestry is used. In earlier versions of the code veget_cov_max was
+       ! passed. Veget_cov_max does not account for the fraction of none biological
+       ! land use in the pixel. The adavantage of using both veget_cov_max and 
+       ! veget_max in stomate_lpj and its subroutines is unclear. Hence, only
+       ! veget_max was retained.
+       CALL littercalc_prognostic (npts, dtradia/one_day, &
+            turnover_littercalc, bm_to_littercalc, &
+            veget_max, temp_sol, stempdiag, shumdiag, litterhumdiag, &
+            litterpart, litter, dead_leaves, lignin_struc, &
+            lignin_wood, &
+            deadleaf_cover, resp_hetero_litter, &
+            soilcarbon_input_inst, control_temp_inst, control_moist_inst, &
+            matrixA, vectorB)
+
+    ELSE
+
+       ! Litter calculation without wood decomposition, this routine was
+       ! included for the sole purpose to reproduce the TRUNK version.
+       ! In earlier versions of the code veget_cov_max was passed.
+       ! Veget_cov_max does not account for the fraction of none biological
+       ! land use in the pixel. The adavantage of using both veget_cov_max 
+       ! and veget_max in stomate_lpj and its subroutines is unclear. Hence, 
+       ! only veget_max was retained.
+       CALL littercalc_diagnostic (npts, dtradia/one_day, &
+            turnover_littercalc, bm_to_littercalc, &
+            veget_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, &
+            matrixA, vectorB)
+
+    ENDIF
+
+
+    !---TEMP---
+    CALL check_biomass_sync("stomate.f90: After littercalc", npts, biomass, &
+         circ_class_biomass, circ_class_n, ind, &
+         lsync, bm_sync)   
+    
+    ! Heterothropic litter respiration during time step ::dtradia @tex $(gC m^{-2})$ @endtex
+
+    resp_hetero_litter(:,:) = resp_hetero_litter(:,:) * dtradia/one_day    
+
+    !! 4.6 Soil carbon dynamics and soil heterotrophic respiration
+
+    ! Note: there is no vertical discretisation in the soil for litter decay.
+    CALL soilcarbon (npts, dtradia/one_day, clay, soilcarbon_input_inst, &
+         control_temp_inst, control_moist_inst, carbon, resp_hetero_soil, &
+         matrixA, veget_max)
+
+    ! Heterothropic soil respiration during time step ::dtradia @tex $(gC m^{-2})$ @endtex 
+    resp_hetero_soil(:,:) = resp_hetero_soil(:,:) * dtradia/one_day
+
+    ! Total heterothrophic respiration during time step ::dtradia @tex $(gC m^{-2})$ @endtex
+    resp_hetero_radia(:,:) = resp_hetero_litter(:,:) + resp_hetero_soil(:,:)
+    resp_hetero_d(:,:) = resp_hetero_d(:,:) + resp_hetero_radia(:,:)
+    ! added by yitong yao print resp_hetero_soil and litter 
+
+    resp_hetero_litter_d(:,:) = resp_hetero_litter_d(:,:) + resp_hetero_litter(:,:)
+    resp_hetero_soil_d(:,:) = resp_hetero_soil_d(:,:) + resp_hetero_soil(:,:)
+
+    ! added by yitong yao 22:35 Feb 18 2020
+
+    !! 4.7 Accumulate instantaneous variables (do_slow=.FALSE.) 
+    ! Accumulate instantaneous variables (do_slow=.FALSE.) and eventually 
+    ! calculate daily mean value (do_slow=.TRUE.) 
+    CALL stomate_accu (npts, nlevs, dt_slow, dtradia, &
+         & do_slow, control_moist_inst, control_moist_daily)
+    CALL stomate_accu (npts, nlevs, dt_slow, dtradia, &
+         & do_slow, control_temp_inst, control_temp_daily)
+
+    DO i = 1,ncarb
+       CALL stomate_accu (npts, nvm, dt_slow, dtradia, &
+            & do_slow, soilcarbon_input_inst(:,i,:), soilcarbon_input_daily(:,i,:))
+    ENDDO
+    ! added by Yitong Yao in 06 Jan 2020 14:27
+    !write(*,*) 'do_slow_soilcarbon',do_slow 
+    !DO i=1,ncarb
+    !    write(*,*) 'soilcarbon_input_inst ',i,' ',soilcarbon_input_inst(1,i,2)
+    !    write(*,*) 'soilcarbon_input_daily ',i,' ',soilcarbon_input_daily(1,i,2)
+    !ENDDO
+    ! added by Yitong Yao in 06 Jan 2010 14:27 above line
+        
+
+    ! added by Yitong Yao Jan 06 Jan 2020
+    !write(*,*) 'do_slow_plc',do_slow
+    !write(*,*) 'dt_slow_plc',dt_slow
+    !write(*,*) 'dtradia_plc',dtradia
+
+    DO icir=1,ncirc
+       CALL stomate_accu (npts, nvm, dt_slow, dtradia, &
+            & do_slow, stem_plc(:,:,icir), stemplc_daily(:,:,icir))
+       !write(*,*) 'stemplc_daily ',icir,' ',stemplc_daily(1,2,icir)
+       !write(*,*) 'stem_plc_pre ',icir,' ',stem_plc(1,2,icir)
+    ENDDO
+
+       ! added by Yitong Yao Jan 06 2020 above lines
+    
+    ! added by yitong yao 07 Jan 2020 10:57 
+    DO icir=1,ncirc
+       CALL stomate_accu (npts, nvm, dt_slow, dtradia, &
+            & do_slow, psi_stem(:,:,icir), psistem_daily(:,:,icir))
+       !write(*,*) 'psi_stem_daily ',icir,' ',psistem_daily(1,2,icir)
+      ! write(*,*) 'psi_stem_pre ',icir,' ',psi_stem(1,2,icir)
+    ENDDO
+
+    DO icir=1,ncirc
+       CALL stomate_accu (npts, nvm, dt_slow, dtradia, &
+            & do_slow, psi_leaf(:,:,icir), psileaf_daily(:,:,icir))
+    ENDDO
+
+    DO icir=1,ncirc
+       CALL stomate_accu (npts, nvm, dt_slow, dtradia, &
+            & do_slow, psi_root(:,:,icir), psiroot_daily(:,:,icir))
+    ENDDO
+
+    ! added by yitong yao 07 Jan 2020 10:57 above lines
+    ! added by yitong yao Feb 24 2020 21:00 old humrel
+    CALL stomate_accu (npts, nvm, dt_slow, dtradia, &
+            & do_slow, humrel, humrel_ddd)
+    ! added by yitong yao Feb 24 2020 21:00 above lines
+
+    !! 4.8 Mass balance closure (dt_radia)
+    !! 5.9.1 Calculate components of the mass balance
+    !  Initial values of biomass, litter, soil and harvest pool
+    pool_end(:,:,:) = zero
+    DO iele = 1,nelements
+
+       ! Litter pool
+       DO ilitt = 1,nlitt
+          DO ilevs = 1,nlevs
+             pool_end(:,:,iele) = pool_end(:,:,iele) + &
+                  litter(:,ilitt,:,ilevs,iele) * veget_max(:,:)
+          ENDDO
+       ENDDO
+
+       ! Soil carbon
+       DO icarb = 1,ncarb
+          pool_end(:,:,iele) = pool_end(:,:,iele) + &
+               carbon(:,icarb,:) * veget_max(:,:)
+       ENDDO
+
+    ENDDO ! # nelements
+
+    !! 5.9.2 Calculate mass balance (dt_radia)
+    check_intern(:,:,iatm2land,icarbon) = zero
+    check_intern(:,:,iland2atm,icarbon) = -un * (resp_hetero_litter(:,:) + &
+         resp_hetero_soil(:,:)) * veget_max(:,:)
+    check_intern(:,:,ilat2out,icarbon) = zero
+    check_intern(:,:,ilat2in,icarbon) = -un * zero
+    check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - pool_start(:,:,icarbon))
+    closure_intern(:,:,:) = zero
+    DO imbc = 1,nmbcomp
+       closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + check_intern(:,:,imbc,icarbon)
+    ENDDO
+
+    ! Write result of the closure check
+    DO ipts = 1,npts
+       DO ivm = 1,nvm
+          IF (closure_intern(ipts,ivm,icarbon) .LT. min_stomate .AND. &
+               closure_intern(ipts,ivm,icarbon) .GT. -min_stomate) THEN
+             IF (ld_massbal) WRITE(numout,*) 'Mass balance closure: stomate.f90 (dt_radia)', ipts, ivm
+          ELSE
+             WRITE(numout,*) 'Error: mass balance is not closed in stomate.f90 (dt_radia)', ipts, ivm
+!             WRITE(numout,*) '   Difference, ipts, ivm', ipts, ivm, closure_intern(ipts,ivm,icarbon)
+          ENDIF
+       ENDDO
+    ENDDO
+
+!! 5. Daily processes - performed at the end of the day
+    IF (do_slow) THEN
+
+       !! 5.1 Initialize check for mass balance closure  
+       !  Initial values of biomass, litter, soil and harvest pool
+       pool_start(:,:,:) = zero
+       resp_maint_d(:,:) = zero
+       resp_growth_d(:,:) = zero
+
+       DO iele = 1,nelements
+
+          ! Biomass pool (gC m-2) * (m2 m-2)
+          ! turnover and bm_to_litter should have been set to zero when
+          ! entering the daily loop or they have to be ignored in the pool_start
+          ! calculation as done here
+          DO ipar = 1,nparts
+             pool_start(:,:,iele) = pool_start(:,:,iele) + &
+                  (biomass(:,:,ipar,iele) * veget_max(:,:)) 
+          ENDDO
+
+          ! Litter pool (gC m-2) *  (m2 m-2) 
+          DO ilitt = 1,nlitt
+             DO ilevs = 1,nlevs
+                pool_start(:,:,iele) = pool_start(:,:,iele) + &
+                     litter(:,ilitt,:,ilevs,iele) * veget_max(:,:)
+             ENDDO
+          ENDDO
+
+          ! Soil carbon (gC m-2) *  (m2 m-2)
+          ! soilcarbon_input_daily should have been set to zero when
+          ! entering the daily loop or they are ignored in the pool_start
+          ! calculation  
+          DO icarb = 1,ncarb
+             pool_start(:,:,iele) = pool_start(:,:,iele) + &
+                  carbon(:,icarb,:) * veget_max(:,:)
+          ENDDO
+
+       ENDDO ! # nelements
+
+       !  Surface area (m2) of the pixel
+       pixel_area(:) = resolution(:,1) * resolution(:,2)
+
+       ! The biomass harvest pool shouldn't be multiplied by veget_max
+       ! its units are already in gC pixel-1. The total amount for the 
+       ! pixel was stored in harvest_pool. Account for the harvest and
+       ! wood product pools. There are no longer PFTs 
+       pool_start(:,1,icarbon) = pool_start(:,1,icarbon) + &
+            (SUM(SUM(harvest_pool(:,:,:,icarbon),3),2) + &
+            SUM(prod_l(:,:),2) + SUM(prod_m(:,:),2) + &
+            SUM(prod_s(:,:),2) )/pixel_area(:)     
+
+       
+       !! 5.2 Update lai
+       ! Use lai from stomate
+       ! ?? check if this is the only time control%ok_pheno is used??
+       ! ?? Looks like it is the only time. But this variables probably is defined 
+       ! in stomate_constants or something, in which case, it is difficult to track.
+       IF (control%ok_pheno) THEN
+          !! 5.1.1 Update LAI 
+          ! Set lai of bare soil to zero
+          lai(:,ibare_sechiba) = zero
+          ! lai for all PFTs
+          DO j = 2, nvm
+             DO i = 1,npts
+
+                IF(veget_max(i,j) == zero)THEN
+                   ! this vegetation type is not present, so no reason to do the 
+                   ! calculation
+                   CYCLE
+                ENDIF
+
+                lai(i,j) = biomass_to_lai(biomass(i,j,ileaf,icarbon),j)
+             ENDDO
+          ENDDO
+          frac_age(:,:,:) = leaf_frac(:,:,:)
+       ELSE 
+          ! 5.1.2 Use a prescribed lai
+          ! WARNING: code in setlai is identical to the lines above
+          ! Update subroutine if LAI has to be forced 
+          CALL  setlai(npts,lai,biomass) 
+          frac_age(:,:,:) = zero
+       ENDIF
+
+       !! 5.3 Calculate long-term "meteorological" and biological parameters
+
+       ! mainly in support of calculating phenology. If ::EndOfYear=.TRUE.
+       ! annual values are update (i.e. xx_lastyear).
+       ! In earlier versions of the code veget_cov_max was passed.
+       ! Veget_cov_max does not account for the fraction of none biological
+       ! land use in the pixel. The adavantage of using both veget_cov_max 
+       ! and veget_max in stomate_lpj and its subroutines is unclear. Hence, 
+       ! only veget_max was retained.
+       CALL season &
+            &          (npts, dt_days, EndOfYear, &
+            &           veget, veget_max, &
+            &           humrel_daily, t2m_daily, tsoil_daily, soilhum_daily, lalo, &
+            &           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, fpc_max, &
+            &           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, gdd_init_date, &
+            &           gdd_from_growthinit, herbivores, humrel_growingseason, rue_longterm, &
+            &           vir_humrel_daily, vir_humrel_growingseason)
+
+       !---TEMP---
+       CALL check_biomass_sync("stomate.f90: After season", npts, biomass, &
+            circ_class_biomass, circ_class_n, ind, &
+            lsync, bm_sync) 
+ 
+
+       !! 5.4 Waterstress
+
+       !  The waterstress factor varies between 0.1 and 1 and is calculated
+       !  from ::humrel_growingseason. The latter is only used in the allometric 
+       !  allocation and its time integral is determined by tau_sap for trees
+       !  (see constantes_mtc.f90 for tau_sap and see pft_constantes.f90 for 
+       !  the definition of tau_hum_growingseason). The time integral for 
+       !  grasses and crops is a prescribed constant (see constantes.f90). By
+       !  having ::wstress_fac working on the turnover, water stress is progated
+       !  into LF.
+       !  Because the calculated values for ::wstress_fac are too low for this purpose
+       !  Sonke Zhaele multiply it by two in the N-branch. This approach maintains
+       !  the physiological basis of KF while combining it with a simple 
+       !  multiplicative factor for water stress. Clearly after multiplication with 
+       !  2, wstress is closer to 1 and will thus result in a KF values closer to 
+       !  the physiologically expected KF. 
+       !  In this implementation we take the sqrt (this is done in stomate where 
+       !  ::humrel_daily is calculated from ::stressed and ::unstressed. The
+       !  transformation from the ratio between stressed an unstressed gpp into a 
+       !  numerical value that is used in the allocation and turnover is arbitrairy.
+       !  A more physiological approach accounting for turgor would be needed to de
+       !  fundamentally better.
+       !  Note that the current implementation allows for the plants to adapt to drought 
+       !  by adjusting its allocation. This is a long-term effect and it is long-term
+       !  because ::humrel_growingseason integrates over ::tau_sap. For the moment no
+       !  short term effects to drought are implemented. Short-term effects should be 
+       !  implmented on mortality (through loss of turgor, heat stress, carbon starvation).
+       wstress_season(:,1) = zero
+       wstress_month(:,1) = zero
+       vir_wstress_fac(:,1) = zero
+
+       DO ivm = 2,nvm
+
+          ! Calculate waterstress
+          ! Water stress used in stomate
+          !+++CHECK+++
+          wstress_season(:,ivm) = MAX(humrel_growingseason(:,ivm), min_water_stress)
+          wstress_month(:,ivm) = MAX(humrel_month(:,ivm), min_water_stress)
+          vir_wstress_fac(:,ivm) = MAX(vir_humrel_growingseason(:,ivm), min_water_stress)
+          !+++++++++++
+ 
+          !+++CHECK+++
+          ! The reduction of the leaf longevity should probably depend on
+          ! the leaf skin temperature that will become available through
+          ! the multi-layer energy budget. For the moment we don't have
+          ! water stress on the leaves. A long term adaption could be 
+          ! through ::sla
+          tau_eff_leaf(:,ivm) = tau_leaf(ivm) * un
+          
+          ! The reduction of the root longevity depends on the soil moisture
+          ! stress which we believe is reasonably well captured by our 
+          ! proxy for wstress. We need to produce more roots to take the water
+          ! from those layers that have water.
+          ! feedback to c-allocation has been switched off
+           tau_eff_root(:,ivm) = tau_root(ivm) *  un
+          
+          ! The reduction of sapwood longevity should depend on the cavitation
+          ! which is calculated in hydrol_architecture. Should be linked
+          ! once the memory of cavitation is calculated
+          tau_eff_sap(:,ivm) = tau_sap(ivm) *  un
+          !+++++++++
+          
+       ENDDO
+
+       ! Add to sitory file
+       CALL histwrite_p (hist_id_stomate, 'WSTRESS_SEASON', itime, &
+            wstress_season(:,:), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'WSTRESS_MONTH', itime, &
+            wstress_month(:,:), npts*nvm, horipft_index)
+      
+       ! added by Yitong Yao Jan 06 Jan 2020
+      ! write(*,*) 'do_slow_daily',do_slow
+       !write(*,*) 'dt_slow_plc',dt_slow
+       !write(*,*) 'dtradia_plc',dtradia
+ 
+       !DO icir=1,ncirc 
+       !   CALL stomate_accu (npts, nvm, dt_slow, dtradia, &
+       !     & do_slow, stem_plc(:,:,icir), stemplc_daily(:,:,icir))
+       !   write(*,*) 'stemplc_daily ',icir,' ',stemplc_daily(1,2,icir)
+       !    write(*,*) 'stem_plc_pre ',icir,' ',stem_plc(1,2,icir)
+       !ENDDO
+
+       ! added by Yitong Yao Jan 06 2020 above lines 
+ 
+       !! 5.5 Use all processes included in stomate
+
+       IF (control%ok_stomate) THEN
+
+          !! 5.5.1  Activate stomate processes 
+          ! Activate stomate processes (the complete list of processes depends 
+          ! on whether the DGVM is used or not). Processes include: climate constraints 
+          ! for PFTs, PFT dynamics, Phenology, Allocation, NPP (based on GPP and
+          ! authothropic respiration), fire, mortality, vmax, assimilation temperatures,
+          ! all turnover processes, light competition, sapling establishment, lai and 
+          ! land cover change.
+          ! In earlier versions of the code veget_cov_max was passed.
+          ! Veget_cov_max does not account for the fraction of none biological
+          ! land use in the pixel. The adavantage of using both veget_cov_max 
+          ! and veget_max in stomate_lpj and its subroutines is unclear. Hence, 
+          ! only veget_max was retained. Also, ::veget_cov_max_new has now been 
+          ! replaced by ::veget_max_new.
+          
+          !---TEMP---
+          ! Useful for debugging when running over a region and a single pixel is 
+          ! causing problems. this code helps to find the coordinates of that pixel
+!!$          DO ipts=1,npts
+!!$             WRITE(numout,'(A,I3,10F20.10)') 'lalo stomate:',ipts,lalo(ipts,1:2)
+!!$          ENDDO
+          !----------
+
+          CALL StomateLpj (npts, 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, &
+               humrel_growingseason, tlong_ref, t2m_longterm, t2m_month, t2m_week, tsoil_month, &
+               soilhum_month, gdd_m5_dormance,  gdd_from_growthinit, gdd_midwinter, ncd_dormance, &
+               ngd_minus5, turnover_longterm, gpp_daily, gpp_week, time_lowgpp, &
+               time_hum_min, maxfpc_lastyear, resp_maint_part, PFTpresent, age, &
+               fireindex, firelitter, leaf_age, leaf_frac, biomass, &
+               ind, adapted, regenerate, senescence, senescence_days, &
+               when_growthinit, litterpart, litter, dead_leaves, carbon, &
+               black_carbon, lignin_struc, lignin_wood, veget_max, veget, npp_longterm, &
+               lm_lastyearmax, veget_lastlight, everywhere, need_adjacent, RIP_time, &
+               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, deadleaf_cover, vcmax, &
+               bm_to_litter, prod_s, &
+               prod_m, prod_l, flux_s, flux_m, flux_l, &
+               veget_max_new, cflux_prod_s, cflux_prod_m, cflux_prod_l, carb_mass_total, &
+               fpc_max, age_stand, rotation_n, last_cut, forest_managed, &
+               forest_managed_lastyear, matrixA, rue_longterm, lab_fac, circ_class_n, &
+               circ_class_biomass, KF, circ_class_dist, harvest_pool_bound, harvest_pool, &
+               harvest_type, harvest_cut, harvest_area, mai, pai, &
+               previous_wood_volume, mai_count, bm_sync, coppice_dens, lai_per_level, &
+               laieff_fit, orphan_flux, vir_humrel_growingseason, litter_demand, wstress_season, &
+               wstress_month, vir_wstress_fac, tau_eff_leaf,  tau_eff_sap, &
+               tau_eff_root, MatrixV, VectorB, VectorU, &
+               c_buried, st_dist, k_latosa_adapt, species_change_map, lpft_replant,stemplc_daily,psistem_daily,counter_psi,counter_2,counter_0,resp_hetero_litter_d,resp_hetero_soil_d,humrel_daily,humrel_ddd, psileaf_daily, psiroot_daily)
+
+          !---TEMP---
+          CALL check_biomass_sync("stomate.f90: After StomatLPJ", npts, biomass, &
+               circ_class_biomass, circ_class_n, ind, &
+               lsync, bm_sync)
+
+          !! 5.5.2 Long term adaptation of allocation to water stress
+          !  ::wstress season is calculated as the seasonal mean of the
+          !  ratio between the stressed and unstressed GPP. If the plant
+          !  experiences a short spell of drought, leaves will be killed
+          !  (see stomate_turnover). However, when the drought stress is 
+          !  maintained during the season, it is assumed that the plant 
+          !  will economise its canopy and therefore adjust its allocation
+          ! factors to grow less leaves. To avoid that the canopy can only
+          ! shrink the plants will try to grow more leaves when they do
+          ! not experience any water stress. Extending the LAI, however,
+          ! increases the chances that the plant will experience drough 
+          ! stress in the future. These feedbacks should stabilize the LAI.
+          wstress_adapt(:,:) = zero
+          WHERE (wstress_season(:,:) .GT. 0.99)
+
+             ! Increase the leaf allocation by 10% over the whole
+             ! year. If there was no water stress during the whole 
+             ! year, the following year more C will be allocated
+             ! to the leaves.
+             wstress_adapt(:,:) = 1.05
+
+          ELSEWHERE
+
+             wstress_adapt(:,:) = wstress_season(:,:)
+           
+          ENDWHERE
+          
+          !+++CHECK+++
+          ! Don't use this adaptation
+!!$          k_latosa_adapt(:,:) = k_latosa_adapt(:,:) * &
+!!$               (wstress_adapt(:,:)**(un/365))
+          !+++++++++++
+        
+          DO ivm = 2,nvm
+
+             WHERE ( k_latosa_adapt(:,ivm) .GE. k_latosa_max(ivm) )
+                
+                k_latosa_adapt(:,ivm) = k_latosa_max(ivm)
+
+             ENDWHERE
+
+          ENDDO
+
+          CALL histwrite_p (hist_id_stomate, 'K_LATOSA_ADAPT', itime, &
+               k_latosa_adapt(:,:), npts*nvm, horipft_index)
+          
+                
+          !+++CHECK+++
+          ! check units and variable names for new lcchange and product use
+          !! 5.3.2 Calculate the total CO2 flux from land use change
+!!$          fco2_lu(:) = cflux_prod_s(:) + cflux_prod_m(:) + &
+!!$               cflux_prod_l(:) + SUM(harvest_pool(:,:,1,ifm_crop,icut_crop),2)
+          !+++++++++++
+
+          
+          !! 5.5 Photosynthesis parameters
+          assim_param(:,:,ivcmax) = zero
+
+          DO j = 2,nvm
+             assim_param(:,j,ivcmax) = vcmax(:,j)
+             !write(*,*) 'stom2_vcmax',vcmax(1,j)
+          ENDDO
+
+
+          !! 5.6 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
+             ! ::nbyear Number of years saved for carbon spinup
+             sf_time = MODULO(REAL(date,r_std)-1,one_year*REAL(nbyear,r_std))
+             iatt=FLOOR(sf_time/dt_forcesoil) + 1
+             IF (iatt == 0) iatt = iatt_old + 1
+             IF ((iatt<iatt_old) .and. (.not. cumul_Cforcing)) THEN
+                nforce(:)=0
+                soilcarbon_input(:,:,:,:) = zero
+                control_moist(:,:,:) = zero
+                control_temp(:,:,:) = zero
+                npp_equil(:,:) = zero
+             ENDIF
+             iatt_old = iatt
+             ! Update forcing
+             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
+
+
+          !! 5.8 Check mass balance closure
+
+          !! 5.8.1 Calculate components of the mass balance
+          !  Initial values of biomass, litter, soil and harvest pool
+          pool_end(:,:,:) = zero
+          DO iele = 1,nelements
+
+             ! Biomass pool
+             DO ipar = 1,nparts
+                pool_end(:,:,iele) = pool_end(:,:,iele) + &
+                     ( (biomass(:,:,ipar,iele) + &
+                     bm_to_litter(:,:,ipar,iele) + &
+                     turnover_daily(:,:,ipar,iele)) * veget_max(:,:)) 
+             ENDDO
+
+             ! Litter pool
+             DO ilitt = 1,nlitt
+                DO ilevs = 1,nlevs
+                   pool_end(:,:,iele) = pool_end(:,:,iele) + &
+                        litter(:,ilitt,:,ilevs,iele) * veget_max(:,:)
+                ENDDO
+             ENDDO
+
+             ! Soil carbon
+             DO icarb = 1,ncarb
+                pool_end(:,:,iele) = pool_end(:,:,iele) + &
+                     carbon(:,icarb,:)  * veget_max(:,:)
+             ENDDO
+
+          ENDDO ! # nelements
+
+          pool_end(:,1,icarbon) = pool_end(:,1,icarbon) + &
+            (SUM(SUM(harvest_pool(:,:,:,icarbon),3),2) + &
+            SUM(prod_l(:,:),2) + SUM(prod_m(:,:),2) + &
+            SUM(prod_s(:,:),2) )/pixel_area(:)
+
+          !! 5.8.2 Calculate mass balance
+          !  iatm2land and iland2atm have already been calculated after growth in Â§4.2         
+          IF (control%ok_land_cover_change .AND. EndOfYear) THEN
+             check_intern(:,:,iatm2land,icarbon) = &
+                  orphan_flux(:,:,igpp,icarbon)  * orphan_flux(:,:,ivegold,icarbon) + &
+                  orphan_flux(:,:,ico2bm,icarbon) * orphan_flux(:,:,ivegnew,icarbon)
+          ELSE
+             check_intern(:,:,iatm2land,icarbon) = (gpp_daily(:,:) + co2_to_bm_dgvm(:,:)) * &
+                  veget_max(:,:)
+          ENDIF
+
+          check_intern(:,:,iland2atm,icarbon) = -un * (orphan_flux(:,:,irmain,icarbon) + &
+            orphan_flux(:,:,irgrow,icarbon)) * orphan_flux(:,:,ivegold,icarbon) * dt_days
+          check_intern(:,1,iland2atm,icarbon) = -un * ( SUM(flux_s(:,:),2) + SUM(flux_m(:,:),2) + & 
+               SUM(flux_l(:,:),2) ) / pixel_area(:)
+          check_intern(:,:,ilat2out,icarbon) = zero
+          check_intern(:,:,ilat2in,icarbon) = -un * zero
+          check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - pool_start(:,:,icarbon))
+          closure_intern(:,:,:) = zero
+          DO imbc = 1,nmbcomp
+             closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + check_intern(:,:,imbc,icarbon)
+          ENDDO
+
+          ! Write result of the closure check
+          !  Sum over ivm because of LCC and redistribution    
+          DO ipts = 1,npts
+             IF (SUM(closure_intern(ipts,:,icarbon)) .LT. min_stomate .AND. &
+                  SUM(closure_intern(ipts,:,icarbon)) .GT. -min_stomate) THEN
+                IF (ld_massbal) WRITE(numout,*) 'Mass balance closure: stomate.f90 (dt_slow)', ipts
+             ELSE
+                WRITE(numout,*) 'Error: mass balance is not closed in stomate.f90 (dt_slow)'
+!                WRITE(numout,*) '   Difference, ipts, ', ipts, SUM(closure_intern(ipts,:,icarbon)) 
+             ENDIF
+          ENDDO
+
+       ENDIF ! control%ok_stomate
+
+
+      !! 5.9 Write forcing file if ::ldforcing_write=.TRUE.
+      ! Note: if STOMATE is run in coupled mode the forcing file is written
+      ! If run in stand-alone mode, the forcing file is read!
+      IF ( ldforcing_write .AND. TRIM(forcing_name) /= 'NONE' ) THEN
+
+         !! 5.9.1 Convert GPP to sechiba time steps
+         ! GPP is multiplied by coverage to obtain forcing @tex $(gC m^{-2} dt_slow^{-1})$\f \end@tex $(m^2 m^{-2})$ @endtexonly
+         ! @tex$ m^{-2}$ @endtex remains in the units because ::veget_cov_max is a fraction, not a 
+         ! surface area. In sechiba values are ponderated by surface and frac_no_bio. 
+         ! At the beginning of stomate, the units are converted. 
+         ! When we use forcesoil we call sechiba_main and so we need the have the same units as in sechiba.
+         gpp_daily_x(:,:) = zero
+         DO j = 2, nvm             
+            gpp_daily_x(:,j) = gpp_daily_x(:,j) + &
+                 & gpp_daily(:,j) * dt_slow / one_day * veget_cov_max(:,j)
+         ENDDO
+        
+         !write(*,*) 'gpp_daily_x',gpp_daily_x(1,2)
+         !write(*,*) 'gpp_daily_3030',gpp_daily(1,2)
+         !write(*,*) 'dt_slow_3031',dt_slow
+         !write(*,*) 'veget_cov_max',veget_cov_max(1,2)
+         ! Bare soil moisture availability has not been treated
+         ! in STOMATE, update it here
+         humrel_daily(:,ibare_sechiba) = humrel(:,ibare_sechiba)   
+
+         ! Update index to store the 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)
+
+         !! 5.9.2 Cumulate forcing variables
+         ! Cumulate forcing variables (calculate average)
+         ! Note: precipitation is multiplied by dt_slow/one_day to be consistent with 
+         ! the units in sechiba
+         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.)
+            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
+            ! Here we just calculate the values
+            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(:,:)
+            veget_fm(:,:,iisf) = veget(:,:)
+            veget_max_fm(:,:,iisf) =veget_max(:,:)
+            lai_fm(:,:,iisf) =lai(:,:)
+         ENDIF
+         nf_cumul(isf(iisf)) = nf_cumul(isf(iisf))+1
+
+         ! 5.9.3 Do we have to write the forcing states?
+         IF (iisf == nsfm) THEN
+
+            !! 5.9.3.1 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 forcing variables - for debug use only
+            ! CALL forcing_read(forcing_id,nsfm)
+            iisf = 0
+
+         ENDIF
+
+      ENDIF
+
+
+!!$      !+++CHECK+++
+!!$      !! 5.10 Compute daily CO2 flux (AR5 output - not essential)
+!!$      !  CO2 flux in @tex $gC m^{-2} s^{-1}$ @endtex (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 emissions from fire - (5) co2 taken up in the DGVM to establish 
+!!$      !  saplings - (6) co2 taken up by photosyntyhesis. CHECK: In case of a LCC, 
+!!$      !  these calculations needs to make use of the orphan fluxes
+!!$      co2_flux_daily(:,:) = -un * (check_intern(:,:,iatm2land,icarbon) - &
+!!$           check_intern(:,:,iland2atm,icarbon))
+!!$
+!!$      resp_maint_d(:,:) + resp_growth_d(:,:) + resp_hetero_d(:,:) + &
+!!$           & co2_fire(:,:) - co2_to_bm_dgvm(:,:) - gpp_daily(:,:)
+!!$
+!!$      CALL xios_orchidee_send_field("nep",SUM(co2_flux_daily*veget_cov_max,dim=2)/1e3/one_day*contfrac)
+!!$
+!!$      IF ( hist_id_stom_IPCC > 0 ) THEN
+!!$         vartmp(:) = SUM(co2_flux_daily*veget_cov_max,dim=2)/1e3/one_day*contfrac
+!!$         CALL histwrite_p (hist_id_stom_IPCC, "nep", itime, &
+!!$              vartmp, npts, hori_index)
+!!$      ENDIF
+!!$
+!!$      ! CHECK: Check units of harvest pool and add a variable to account for the
+!!$      ! daily harvest flux. What is this used for? NOTE: the structure of
+!!$      ! harvest_pool has changed. CHECK: If net_co2_flux_monthly contains soil 
+!!$      ! respirations which seems likely Then the loop should go over 
+!!$      ! j=1,nvm. Because bare soil can respire after a land cover change!
+!!$      
+!!$      ! See 5.10 for details on NEP + fire. At the monthly time step also 
+!!$      ! harvest and land use change are calculated
+!!$      co2_flux_monthly(:,:) = co2_flux_monthly(:,:) + co2_flux_daily(:,:) 
+!!$      harvest_above_monthly(:) = harvest_above_monthly(:) + &
+!!$           + SUM(harvest_pool(:,:,1,ifm_crop,icut_crop),2)
+!!$      cflux_prod_monthly(:) = cflux_prod_monthly(:) + cflux_prod_s(:) + & 
+!!$           & cflux_prod_m(:) + cflux_prod_l(:)
+!!$      
+!!$      
+!!$      !! 5.11 Compute monthly CO2 fluxes 
+!!$      
+!!$      IF ( EndOfMonth ) THEN
+!!$         
+!!$         IF ( control%ok_stomate ) THEN
+!!$            
+!!$            
+!!$            !! 5.12.1 Write history file for monthly fluxes
+!!$            
+!!$            CALL histwrite_p (hist_id_stomate, 'CO2FLUX', itime, &
+!!$                 co2_flux_monthly, npts*nvm, horipft_index)
+!!$            
+!!$         ENDIF
+!!$         
+!!$         ! CHECK: loop should go over j=1,nvm. Because bare soil can respire after
+!!$         ! a land cover change! I (=VB) translated the French, but the whole stuff 
+!!$         ! does not make sense to me. "If one deletes the montly cumulation, one 
+!!$         ! should not forget this change in resolution(:,1)*resolution(:,2)*contfrac(:)"
+!!$         ! Original: "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
+!!$         
+!!$         ! Should be supressed, this is post-processing
+!!$         ! ?? How does it differ from co2_flux_monthly??
+!!$         net_co2_flux_monthly = zero
+!!$         DO ji=1,npts
+!!$            DO j=2,nvm
+!!$                net_co2_flux_monthly = net_co2_flux_monthly + &
+!!$                     &  co2_flux_monthly(ji,j)*veget_cov_max(ji,j)
+!!$             ENDDO
+!!$          ENDDO
+!!$          
+!!$          !! 5.12.2 Cumulative fluxes of land use cover change, harvest and net biosphere production
+!!$          ! Parallel processing, gather the information from different processors. first argument is the lo
+!!$          ! local variable, the second argument is the global variable. bcast send it to all processors.
+!!$          net_cflux_prod_monthly_sum = &
+!!$               &  SUM(cflux_prod_monthly(:)*resolution(:,1)*resolution(:,2)*contfrac(:))*1e-15
+!!$          CALL reduce_sum(net_cflux_prod_monthly_sum,net_cflux_prod_monthly_tot)
+!!$          CALL bcast(net_cflux_prod_monthly_tot)
+!!$          net_harvest_above_monthly_sum = &
+!!$               &   SUM(harvest_above_monthly(:)*resolution(:,1)*resolution(:,2)*contfrac(:))*1e-15
+!!$          CALL reduce_sum(net_harvest_above_monthly_sum,net_harvest_above_monthly_tot)
+!!$          CALL bcast(net_harvest_above_monthly_tot)
+!!$          net_co2_flux_monthly = net_co2_flux_monthly*1e-15
+!!$          CALL reduce_sum(net_co2_flux_monthly,net_co2_flux_monthly_sum)
+!!$          CALL bcast(net_co2_flux_monthly_sum)
+!!$          net_biosp_prod_monthly_tot =  &
+!!$               & ( net_co2_flux_monthly_sum + net_cflux_prod_monthly_tot + &
+!!$               & net_harvest_above_monthly_tot )
+!!$          
+!!$          WRITE(numout,9010) 'GLOBAL net_cflux_prod_monthly    (Peta gC/month)  = ',net_cflux_prod_monthly_tot
+!!$          WRITE(numout,9010) 'GLOBAL net_harvest_above_monthly (Peta gC/month)  = ',net_harvest_above_monthly_tot
+!!$          WRITE(numout,9010) 'GLOBAL net_co2_flux_monthly      (Peta gC/month)  = ',net_co2_flux_monthly_sum
+!!$          WRITE(numout,9010) 'GLOBAL net_biosp_prod_monthly    (Peta gC/month)  = ',net_biosp_prod_monthly_tot
+!!$          
+!!$9010      FORMAT(A52,F17.14)
+!!$          
+!!$          
+!!$          ! Reset Monthly values
+!!$          co2_flux_monthly(:,:) = zero
+!!$          harvest_above_monthly(:) = zero
+!!$          cflux_prod_monthly(:)    = zero
+!!$
+!!$       ENDIF ! Monthly processes - at the end of the month
+!!$       !+++++++++++
+
+      !! 5.12 Calculate the daily NBP
+      IF (spinup_analytic) THEN
+
+!!$         !+++CHECK+++
+!!$         Use orphan fluxes. Harvest pool accumulates over a year and is only set to zero
+!!$         at the end of the year. Seems that there is some double counting in this formulation
+!!$         nbp_accu(:) = nbp_accu(:) + (-SUM(co2_flux_daily(:,:) * veget_max(:,:),dim=2) - &
+!!$              (cflux_prod_s(:) + cflux_prod_m(:) + cflux_prod_l(:)) - &
+!!$              SUM(harvest_pool(:,:,1,ifm_crop,icut_crop),2))/1e3
+!!$         !+++++++++++
+
+         !  Daily NBP is used in the spin-up. Rather than starting from all the initial
+         !  components as done previously we prefer to make use of the aggregated components
+         !  calculated to check the mass balance closure. NBP is then the change in all
+         !  biomass pools.
+         nbp_accu(:) = nbp_accu(:) + SUM((pool_end(:,:,icarbon) - pool_start(:,:,icarbon)),2)
+
+      ENDIF
+      
+      !! 5.12 Reset daily variables
+      humrel_daily(:,:) = zero
+      vir_humrel_daily(:,:) = zero
+      vir_transpir_supply_daily(:,:) = zero
+      transpir_supply_daily(:,:) = zero
+      transpir_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
+      resp_hetero_litter_d=zero
+      resp_hetero_soil_d=zero
+
+      IF (bavard >= 3) THEN
+         WRITE(numout,*) 'stomate_main: daily processes done'
+      ENDIF
+      
+   ENDIF  ! Daily processes - at the end of the day
+
+
+   !! 6. Outputs from Stomate
+   ! co2_flux receives a value from STOMATE only if STOMATE is activated.
+   ! Otherwise, the calling hydrological module must do this itself.
+   IF ( control%ok_stomate ) THEN
+      
+      !! 6.1 Respiration and fluxes
+      !+++CHECK+++
+      ! Not clear what this is about - should the orphan fluxes be used?
+      ! This is passed to slow_proc.f90 and then to sechiba.f90
+      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(:,:)
+      
+      !! 6.2 Derived CO2 fluxes
+      ! CO2 flux in gC m^{-2} s^{-1} (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 
+      ! emissions from 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(:,:)
+      
+      temp_growth(:)=t2m_month(:)-tp_00
+      !+++++++++++
+      
+   ENDIF
+
+
+    !! 7. Analytical spinup
+
+    IF (spinup_analytic) THEN
+
+       !! 7.1. Update V and U at sechiba time step
+       DO m = 2,nvm
+          DO j = 1,npts 
+             ! V <- A * V
+             MatrixV(j,m,:,:) = MATMUL(matrixA(j,m,:,:),MatrixV(j,m,:,:))
+             ! U <- A*U + B
+             VectorU(j,m,:) = MATMUL(matrixA(j,m,:,:),VectorU(j,m,:)) + vectorB(j,m,:)
+          ENDDO ! loop pixels
+       ENDDO ! loop PFTS
+
+       !! 7.2. What happened at the end of the year ?
+       IF (EndOfYear) THEN
+     
+          ! 7.2.1 Increase the years counter every EndOfyear
+          global_years = global_years + 1 
+
+          ! 7.2.3 Is global_years is a multiple of the period time ?
+
+          ! 3.2.1 When global_years is a multiple of the spinup_period, we calculate :
+          !       1) the mean nbp flux over the period. This value is restarted
+          !       2) we solve the matrix system by Gauss Jordan method
+          !       3) We test if a point is at equilibrium : if yes, we mark the point (ok_equilibrium array)
+          !       4) Then we reset the matrix 
+          !       5) We erase the carbon_stock calculated by ORCHIDEE by the one found by the method
+          IF( MOD(global_years, spinup_period) == 0 ) THEN
+             WRITE(numout,*) 'Spinup analytic : Calculate if system is in equlibrium. global_years=',global_years
+             ! The number total of days during the forcing period is given by :
+             !    spinup_period*365 (we consider only the noleap calendar)
+             nbp_flux(:) = nbp_accu(:) / ( spinup_period * 365.)
+             ! Reset the values
+             nbp_accu(:) = zero
+
+             carbon_stock(:,ibare_sechiba,:) = zero
+             ! Prepare the matrix for the resolution
+             ! Add a temporary matrix W which contains I-MatrixV
+             ! we should take the opposite of matrixV and add the identitiy : we solve (I-MatrixV)*C = VectorU
+             MatrixW(:,:,:,:) = moins_un * MatrixV(:,:,:,:)
+             DO jv = 1,nbpools
+                MatrixW(:,:,jv,jv) =  MatrixW(:,:,jv,jv) + un
+             ENDDO
+             carbon_stock(:,:,:) = VectorU(:,:,:)
+
+             !
+             !  Solve the linear system
+             !
+             DO m = 2,nvm
+                DO j = 1,npts
+                   ! the solution will be stored in VectorU : so it should be restarted before
+                   ! loop over npts and nvm, so we solved npts*(nvm-1) (9,9) linear systems
+                   CALL gauss_jordan_method(nbpools,MatrixW(j,m,:,:),carbon_stock(j,m,:))
+                ENDDO ! loop pixels
+             ENDDO ! loop PFTS
+
+             ! Reset temporary matrixW
+             MatrixW(:,:,:,:) = zero 
+
+             previous_stock(:,:,:) = current_stock(:,:,:)
+             current_stock(:,:,:) = carbon_stock(:,:,:)  
+             ! The relative error is calculated over the passive carbon pool (sum over the pfts) over the pixel.
+             CALL error_L1_passive(npts,nvm, nbpools, current_stock, previous_stock, veget_max, &
+                  &                eps_carbon, carbon_eq)   
+
+             !! ok_equilibrium is saved,
+             WHERE( carbon_eq(:) .AND. .NOT.(ok_equilibrium(:)) )
+                ok_equilibrium(:) = .TRUE.  
+             ENDWHERE
+
+             ! Reset matrixV for the pixel to the identity matrix and vectorU to zero
+             MatrixV(:,:,:,:) = zero
+             VectorU(:,:,:) = zero
+             DO jv = 1,nbpools
+                MatrixV(:,:,jv,jv) = un
+             END DO
+             WRITE(numout,*) 'Reset for matrixV and VectorU done'    
+
+             !! Write the values found in the standard outputs of ORCHIDEE
+             litter(:,istructural,:,iabove,icarbon) = carbon_stock(:,:,istructural_above)
+             litter(:,istructural,:,ibelow,icarbon) = carbon_stock(:,:,istructural_below)
+             litter(:,imetabolic,:,iabove,icarbon) = carbon_stock(:,:,imetabolic_above)
+             litter(:,imetabolic,:,ibelow,icarbon) = carbon_stock(:,:,imetabolic_below)
+             litter(:,iwoody,:,iabove,icarbon) = carbon_stock(:,:,iwoody_above)
+             litter(:,iwoody,:,ibelow,icarbon) = carbon_stock(:,:,iwoody_below)
+             carbon(:,iactive,:) = carbon_stock(:,:,iactive_pool)
+             carbon(:,islow,:) = carbon_stock(:,:,islow_pool)
+             carbon(:,ipassive,:) = carbon_stock(:,:,ipassive_pool) 
+
+             !! Add for parallelisation 
+             IF (.NOT. ALLOCATED(ok_equilibrium_g)) THEN
+                IF(is_root_prc) THEN
+                   ALLOCATE(ok_equilibrium_g(nbp_glo),stat=ier)
+                   IF (ier /= 0) THEN
+                      CALL ipslerr_p (3,'stomate_main', &
+                           'error in memory allocation for ok_equilibrium_g.','','')
+                   ENDIF
+                ELSE
+                   ALLOCATE(ok_equilibrium_g(0))
+                END IF
+             END IF ! IF (.NOT. ALLOCATED(ok_equilibrium_g))
+             CALL gather(ok_equilibrium,ok_equilibrium_g)
+
+             ! Final step, if all the points are at equilibrium, we can stop the job
+             IF(is_root_prc) THEN         
+                IF(ALL(ok_equilibrium_g)) THEN
+                   WRITE(numout,*) 'Spinup analytic : Equilibrium for carbon pools is reached'
+                ELSE
+                   WRITE(numout,*) 'Spinup analytic : Equilibrium for carbon pools is not yet reached'
+                END IF
+             ENDIF
+          ENDIF ! ( MOD(global_years,spinup_period) == 0)
+       ENDIF ! (EndOfYear)
+
+    ENDIF !(spinup_analytic)
+
+    !! 8. Messages
+
+    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 '
+
+    CALL check_biomass_sync("stomate.f90: end of stomate_main", npts, biomass, &
+         circ_class_biomass, circ_class_n, ind, &
+         lsync, bm_sync)
+
+  END SUBROUTINE stomate_main
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: stomate_init
+!!
+!>\BRIEF        The routine is called only at the first simulation. At that 
+!! time settings and flags are read and checked for internal consistency and 
+!! memory is allocated for the variables in stomate.
+!!
+!! DESCRIPTION  : The routine reads the 
+!! following flags from the run definition file:
+!! -bavard (level of online diagnostic in stomate)\n
+!! -ipd (index of grid point for online diagnostics)\n
+!! -ok_herbivores (flag to activate herbivores)\n
+!! -treat_expansion (flag to activate PFT expansion across a pixel\n
+!! -harvest_agri (flag to harvest aboveground biomass from agricultural PFTs)\n
+!! \n
+!! Check for inconsistent setting between the following flags:
+!! -control%ok_stomate\n
+!! -control%ok_dgvm\n
+!! -control%ok_co2\n
+!! -ldforcing_write\n
+!! \n
+!! Memory is allocated for all the variables of stomate and new indexing tables 
+!! are build. New indexing tables are needed because a single pixel can conatin 
+!! several PFTs. The new indexing tables have separate indices for the different 
+!! PFTs. Similar index tables are build for land use cover change.\n
+!! \n
+!! Several global variables and land cover change variables are initialized to 
+!! zero.\n
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): Strictly speaking the subroutine has no output 
+!! variables. However, the routine allocates memory and builds new indexing 
+!! variables for later use.\n 
+!!
+!! REFERENCE(S)	: None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE stomate_init &
+       &  (kjpij, npts, index, ldforcing_write, lalo, &
+       &   rest_id_stom, hist_id_stom, hist_id_stom_IPCC)
+
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std),INTENT(in)                    :: kjpij             !! Total size of the un-compressed grid, including 
+                                                                      !! oceans (unitless) 
+    INTEGER(i_std),INTENT(in)                    :: npts              !! Domain size - number of terrestrial pixels 
+                                                                      !! (unitless) 
+    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 identifier 
+    INTEGER(i_std),DIMENSION(npts),INTENT(in):: index                 !! Indices of the terrestrial pixels on the global 
+                                                                      !! map 
+    REAL(r_std),DIMENSION(npts,2),INTENT(in) :: lalo                  !! Geogr. coordinates (latitude,longitude) (degrees)
+    LOGICAL,INTENT(in)                           :: ldforcing_write   !! Flag activates writing of _forcing_ file
+
+   
+    !! 0.2 Output variables
+
+
+    !! 0.3 Modified variables
+
+
+    !! 0.4 Local variables
+
+    LOGICAL                                      :: l_error           !! Check errors in netcdf call
+    INTEGER(i_std)                               :: ier               !! Check errors in netcdf call
+    INTEGER(i_std)                               :: ji,j,ipd,idia     !! Indices 
+!_ ================================================================================================================================
+    
+  !! 1. Online diagnostics
+
+    !Config Key   = BAVARD
+    !Config Desc  = level of online diagnostics in STOMATE (0-4)
+    !Config If    = OK_STOMATE
+    !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.
+    !Config Units = [-]
+    !
+    ! By default, ::bavard is set to 1 in stomate_data
+    bavard = 1
+    ! Get ::bavard from run definition file
+    CALL getin_p('BAVARD', bavard)
+
+    IF ( npts > 0 ) THEN
+       !Config  Key  = STOMATE_DIAGPT
+       !Config  Desc = Index of grid point for online diagnostics
+       !Config If    = OK_STOMATE
+       !Config  Def  = 1
+       !Config  Help = This is the index of the grid point which
+       !               will be used for online diagnostics.
+       !Config Units = [-]
+       ! By default ::ipd is set to 1
+       ipd = 1
+       ! Get ::ipd from run definition file
+       CALL getin_p('STOMATE_DIAGPT',ipd)
+       ipd = MIN( ipd, npts )
+       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,*) 'Inconsistency between ::control%ok_stomate and ::control%ok_dgvm'
+       CALL ipslerr_p (3,'stomate_init', &
+             'conflict in control%ok settings','','')
+    ENDIF
+
+    IF ((.NOT.control%ok_co2).AND.control%ok_stomate) THEN
+       WRITE(numout,*) 'Cannot call STOMATE without GPP.'
+       WRITE(numout,*) 'Inconsistency between ::control%ok_stomate and ::control%ok_co2'
+       CALL ipslerr_p (3,'stomate_init', &
+             'conflict in control%ok settings','','')
+    ENDIF
+
+    IF ( ( .NOT. control%ok_co2 ) .AND. ldforcing_write ) THEN
+       WRITE(numout,*)'Cannot write forcing file if photosynthesis is not activated'
+       WRITE(numout,*)'Inconsistency between ::ldforcing_write and ::control%ok_co2'
+       CALL ipslerr_p (3,'stomate_init', &
+             'conflict in control%ok settings','','')
+    ENDIF
+    
+  !! 3. Communicate settings
+    
+    WRITE(numout,*) 'stomate first call - overview of the activated flags:'
+    WRITE(numout,*) '  Photosynthesis: ', control%ok_co2
+    WRITE(numout,*) '  USE STOMATE: ', control%ok_stomate
+    WRITE(numout,*) '  USE DGVM: ', control%ok_dgvm
+    
+  !! 4. Allocate memory for STOMATE's variables
+
+    l_error = .FALSE.
+
+    ALLOCATE(veget_cov_max(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for veget_cov_max. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', &
+             'conflict in control%ok settings','','')
+    ENDIF
+
+    ALLOCATE(veget_cov_max_new(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for veget_cov_max_new. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','') 
+    ENDIF
+
+    ALLOCATE(ba(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for ba. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(adapted(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for adapted. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(regenerate(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for regenerate. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(humrel_daily(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for humrel_daily. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(vir_humrel_daily(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for vir_humrel_daily. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    vir_humrel_daily(:,:)=zero
+
+     ALLOCATE(stressed_daily(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for stressed_daily. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    stressed_daily = zero
+
+    ALLOCATE(unstressed_daily(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for unstressed_daily. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    unstressed_daily(:,:) = zero
+
+    ALLOCATE(daylight(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for daylight. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    daylight(:,:) = zero
+
+    ALLOCATE(transpir_supply_daily(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for transpir_supply_daily. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    transpir_supply_daily=zero
+
+    ALLOCATE(vir_transpir_supply_daily(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for vir_transpir_supply_daily. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    vir_transpir_supply_daily=zero
+
+    ALLOCATE(transpir_daily(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for transpir_daily. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    transpir_daily=zero
+
+    ALLOCATE(litterhum_daily(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for litterhum_daily. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(t2m_daily(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for t2m_daily. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(t2m_min_daily(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for t2m_min_daily. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(tsurf_daily(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for tsurf_daily. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(tsoil_daily(npts,nbdl),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for tsoil_daily. We stop. We need npts*nbdl words',npts,nbdl
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(soilhum_daily(npts,nbdl),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for soilhum_daily. We stop. We need npts*nbdl words',npts,nbdl
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(precip_daily(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for precip_daily. We stop. We need npts words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(gpp_daily(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for gpp_daily. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(npp_daily(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for npp_daily. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(turnover_daily(npts,nvm,nparts,nelements),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for turnover_daily. We stop. We need npts*nvm*nparts*nelements words', &
+       &   npts,nvm,nparts,nelements
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    turnover_daily(:,:,:,:) = zero
+
+    ALLOCATE(turnover_littercalc(npts,nvm,nparts,nelements),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for turnover_littercalc. We stop. We need npts*nvm*nparts*nelements words', & 
+        &  npts,nvm,nparts,nelements
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(humrel_month(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for humrel_month. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(humrel_week(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(humrel_growingseason(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(vir_humrel_growingseason(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(t2m_longterm(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for t2m_longterm. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(tlong_ref(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for tlong_ref. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(t2m_month(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for t2m_month. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(t2m_week(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for t2m_week. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(tsoil_month(npts,nbdl),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for tsoil_month. We stop. We need npts*nbdl words',npts,nbdl
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(soilhum_month(npts,nbdl),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for soilhum_month. We stop. We need npts*nbdl words',npts,nbdl
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(fireindex(npts,nvm),stat=ier) 
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for fireindex. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(firelitter(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for firelitter. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(maxhumrel_lastyear(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for maxhumrel_lastyear. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(maxhumrel_thisyear(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for maxhumrel_thisyear. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(minhumrel_lastyear(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for minhumrel_lastyear. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(minhumrel_thisyear(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for minhumrel_thisyear. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(maxgppweek_lastyear(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for maxgppweek_lastyear. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(maxgppweek_thisyear(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for maxgppweek_thisyear. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(gdd0_lastyear(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for gdd0_lastyear. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(gdd0_thisyear(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for gdd0_thisyear. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(gdd_init_date(npts,4),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for gdd_init_date. We stop. We need npts*4 words',npts,4
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(gdd_from_growthinit(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for gdd_from_growthinit. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    gdd_from_growthinit(:,:) = zero
+
+    ALLOCATE(precip_lastyear(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for precip_lastyear. We stop. We need npts*nvm words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(precip_thisyear(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for precip_thisyear. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(gdd_m5_dormance(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for gdd_m5_dormance. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    gdd_m5_dormance(:,:) = zero
+
+    ALLOCATE(gdd_midwinter(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for gdd_midwinter. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    gdd_midwinter(:,:) = zero
+
+    ALLOCATE(ncd_dormance(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for ncd_dormance. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    ncd_dormance(:,:) = zero
+
+    ALLOCATE(ngd_minus5(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for ngd_minus5. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    ngd_minus5(:,:) = zero
+
+    ALLOCATE(PFTpresent(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for PFTpresent. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(npp_longterm(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for npp_longterm. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(lm_lastyearmax(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for lm_lastyearmax. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(lm_thisyearmax(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for lm_thisyearmax. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(maxfpc_lastyear(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for maxfpc_lastyear. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(maxfpc_thisyear(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for maxfpc_thisyear. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(turnover_longterm(npts,nvm,nparts,nelements),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for turnover_longterm. We stop. We need npts*nvm*nparts*nelements words', & 
+       &    npts,nvm,nparts,nelements
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(gpp_week(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for gpp_week. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(senescence(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for senescence. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    senescence(:,:) = .FALSE.
+
+    ALLOCATE(when_growthinit(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for when_growthinit. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(age(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for age. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(resp_hetero_d(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for resp_hetero_d. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(resp_hetero_litter_d(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for resp_hetero_litter_d. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(resp_hetero_soil_d(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for resp_hetero_soil_d. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+
+
+
+
+
+    ALLOCATE(resp_hetero_radia(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for resp_hetero_radia. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(resp_maint_d(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for resp_maint_d. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(resp_growth_d(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for resp_growth_d. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(co2_fire(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for co2_fire. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(co2_to_bm_dgvm(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for co2_to_bm_dgvm. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    co2_to_bm_dgvm(:,:) = zero
+
+    ALLOCATE(veget_lastlight(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for veget_lastlight. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(everywhere(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for everywhere. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(need_adjacent(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for need_adjacent. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(leaf_age(npts,nvm,nleafages),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for leaf_age. We stop. We need npts*nvm*nleafages words', & 
+       &      npts,nvm,nleafages
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(leaf_frac(npts,nvm,nleafages),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for leaf_frac. We stop. We need npts*nvm*nleafages words', & 
+       &      npts,nvm,nleafages
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+! moved to sechiba
+!!$    ALLOCATE(circ_class_n(npts,nvm,ncirc),stat=ier)
+!!$    l_error = l_error .OR. (ier /= 0)
+!!$    IF (l_error) THEN
+!!$       WRITE(numout,*) 'Memory allocation error for circ_class_n. We stop. We need npts*nvm*ncirc words', & 
+!!$       &      npts,nvm,ncirc
+!!$       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+!!$    ENDIF
+!!$    
+!!$    ALLOCATE(circ_class_biomass(npts,nvm,ncirc,nparts,nelements),stat=ier)
+!!$    l_error = l_error .OR. (ier /= 0)
+!!$    IF (l_error) THEN
+!!$       WRITE(numout,*) 'Memory allocation error for circ_class_biomass.'
+!!$       WRITE(numout,*) 'We stop. We need npts*nvm*nparts*ncirc*nelmements words', & 
+!!$       &      npts,nvm,ncirc,nparts,nelements
+!!$       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+!!$    ENDIF
+
+!!$    ALLOCATE(biomass(npts,nvm,nparts,nelements),stat=ier)
+!!$    l_error = l_error .OR. (ier /= 0)
+!!$    IF (l_error) THEN
+!!$       WRITE(numout,*) 'Memory allocation error for biomass. We stop. We need npts*nvm*nparts*nelements words', &
+!!$       &    npts,nvm,nparts,nelements
+!!$       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+!!$    ENDIF
+!!$    ALLOCATE(ind(npts,nvm),stat=ier)
+!!$    l_error = l_error .OR. (ier /= 0)
+!!$    IF (l_error) THEN
+!!$       WRITE(numout,*) 'Memory allocation error for ind. We stop. We need npts*nvm words',npts,nvm
+!!$       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+!!$    ENDIF
+
+    ALLOCATE(RIP_time(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for RIP_time. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(time_lowgpp(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for time_lowgpp. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(time_hum_min(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for time_hum_min. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(hum_min_dormance(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for hum_min_dormance. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(litterpart(npts,nvm,nlitt),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for litterpart. We stop. We need npts*nvm*nlitt words',  &
+       &  npts,nvm,nlitt
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(litter(npts,nlitt,nvm,nlevs,nelements),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for litter. We stop. We need npts*nlitt*nvm*nlevs*nelements words', & 
+       &    npts,nlitt,nvm,nlevs,nelements
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(dead_leaves(npts,nvm,nlitt),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for dead_leaves. We stop. We need npts*nvm*nlitt words', & 
+       &   npts,nvm,nlitt
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(carbon(npts,ncarb,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for carbon. We stop. We need npts*ncarb*nvm words',npts,ncarb,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(black_carbon(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for black_carbon. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(lignin_struc(npts,nvm,nlevs),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for lignin_struc. We stop. We need npts*nvm*nlevs words',npts,nvm,nlevs
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(lignin_wood(npts,nvm,nlevs),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for lignin_wood. We stop. We need npts*nvm*nlevs words',npts,nvm,nlevs
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(turnover_time(npts,nvm,nparts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for turnover_time. We stop. We need npts*nvm words',npts,nvm,nparts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(co2_flux_daily(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for co2_flux_daily. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(co2_flux_monthly(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for co2_flux_monthly. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (cflux_prod_monthly(npts), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for cflux_prod_monthly. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+ 
+    ALLOCATE (harvest_above_monthly(npts), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for harvest_above_monthly. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(bm_to_litter(npts,nvm,nparts,nelements),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for bm_to_litter. We stop. We need npts*nvm*nparts*nelements words', & 
+       &    npts,nvm,nparts,nelements
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(bm_to_littercalc(npts,nvm,nparts,nelements),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for bm_to_littercalc. We stop. We need npts*nvm*nparts*nelements words', &
+       &   npts,nvm,nparts,nelements
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(herbivores(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for herbivores. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(hori_index(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for hori_index. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(horipft_index(npts*nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for horipft_index. We stop. We need npts*nvm words',npts*nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(horican_index(npts*nlevels_tot),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for horican_index. We stop. We need npts*nlevels_tot words',&
+            npts*nlevels_tot
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(resp_maint_part_radia(npts,nvm,nparts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for resp_maint_part_radia. We stop. We need npts*nvm*nparts words', &
+       &  npts,nvm,nparts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(resp_maint_radia(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for resp_maint_radia. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(resp_maint_part(npts,nvm,nparts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for resp_maint_part. We stop. We need npts*nvm*nparts words', &
+       &    npts,nvm,nparts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    resp_maint_part(:,:,:) = zero
+
+    ALLOCATE (horip_s_index(npts*nshort), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for horip_s_index. We stop. We need npts*10 words',npts,nshort
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (horip_m_index(npts*nmedium), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for horip_m_index. We stop. We need npts*10 words',npts,nmedium
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (horip_l_index(npts*100), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for horip_l_index. We stop. We need npts*100 words',npts,nlong
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+ 
+    ALLOCATE (horip_ss_index(npts*(nshort+1)), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for horip_ss_index. We stop. We need npts*11 words',npts,nshort+1
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF 
+
+    ALLOCATE (horip_mm_index(npts*(nmedium+1)), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for horip_mm_index. We stop. We need npts*11 words',npts,nmedium+1
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (horip_ll_index(npts*(nlong+1)), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for horip_ll_index. We stop. We need npts*101 words',npts,nlong+1
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (prod_s(npts,0:nshort), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for prod_s. We stop. We need npts*(nshort+1) words',npts,nshort+1
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF  
+
+    ALLOCATE (prod_m(npts,0:nmedium), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for prod_m. We stop. We need npts*(nmedium+1) words',npts,nmedium+1
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF 
+
+    ALLOCATE (prod_l(npts,0:nlong), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for prod_l. We stop. We need npts*(nlong+1) words',npts,nlong+1
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (flux_s(npts,nshort), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for flux_s. We stop. We need npts*nshort words',npts,nshort
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (flux_m(npts,nmedium), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for flux_m. We stop. We need npts*nmedium words',npts,nmedium
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (flux_l(npts,nlong), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for flux_l. We stop. We need npts*nlong words',npts,nlong
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (cflux_prod_s(npts), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for cflux_prod_s. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (cflux_prod_m(npts), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for cflux_prod_m. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (cflux_prod_l(npts), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for cflux_prod_l. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (carb_mass_total(npts), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for carb_mass_total. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (soilcarbon_input_daily(npts,ncarb,nvm), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for soilcarbon_input_daily. We stop. We need npts*ncarb*nvm words', & 
+       &    npts,ncarb,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (control_temp_daily(npts,nlevs), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for control_temp_daily. We stop. We need npts*nlevs words',npts,nlevs
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (control_moist_daily(npts,nlevs), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for control_moist_daily. We stop. We need npts*nlevs words',npts,nlevs
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE (rue_longterm(npts,nvm), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for rue_longterm. We stop. We need npts*nlevs words',npts,nlevs
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    rue_longterm(:,:) = un
+
+!!$    ALLOCATE (t_photo_stress(npts,nvm), stat=ier)
+!!$    l_error = l_error .OR. (ier /= 0)
+!!$    IF (l_error) THEN
+!!$       WRITE(numout,*) 'Memory allocation error for t_photo_stress. We stop. We need npts*nlevs words',npts,nlevs
+!!$       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+!!$    ENDIF
+!!$    t_photo_stress(:,:)=zero ! Initializing here, but not 100% certain this is right
+
+    ALLOCATE (lab_fac(npts,nvm), stat=ier)
+    ! temp fix, initializing it here...the values get set in stomate_growth_fun_all,
+    ! but they get used in stomate_resp beforehand, so maybe a code flow problem?
+    lab_fac(:,:)=zero
+
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for lab_fac. We stop. We need npts*nlevs words',npts,nlevs
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+!!$    ALLOCATE (lai_target(npts,nvm), stat=ier)
+!!$    l_error = l_error .OR. (ier /= 0)
+!!$    IF (l_error) THEN
+!!$       WRITE(numout,*) 'Memory allocation error for lai_target. We stop. We need npts*nlevs words',npts,nlevs
+!!$       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+!!$    ENDIF
+    ALLOCATE (fpc_max(npts,nvm), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for fpc_max. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE (senescence_days(npts,nvm), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for senescence_days. We stop. We need npts*nvm words',npts,nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    senescence_days(:,:) = zero
+
+    ALLOCATE(ok_equilibrium(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0) 
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for ok_equilibrium. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(carbon_eq(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for carbon_eq. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(nbp_accu(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for nbp_accu. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    
+    ! added by yitong yao 07 Jan 2020 16:31 
+    ALLOCATE(counter_psi(npts,nvm,ncirc),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for counter_psi. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+     
+    ! added by yitong yao 07 Jan 2020 16:31 above line 
+   
+    ! added by yitong yao 07 Jan 2020 16:31
+    ALLOCATE(counter_2(npts,nvm,ncirc),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for counter_2. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ! added by yitong yao 07 Jan 2020 16:31 above line
+    ! added by yitong yao 07 Jan 2020 16:31
+    ALLOCATE(counter_0(npts,nvm,ncirc),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for counter_0. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ! added by yitong yao 07 Jan 2020 16:31 above line
+
+
+
+
+
+
+
+     ALLOCATE(nbp_flux(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for nbp_flux. We stop. We need npts words',npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(matrixA(npts,nvm,nbpools,nbpools),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for matrixA. We stop. We need npts*nvm*nbpools*nbpools words',  & 
+       &     npts, nvm, nbpools, nbpools
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(vectorB(npts,nvm,nbpools),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for vectorB. We stop. We need npts*nvm*nbpools words',  & 
+       &     npts, nvm, nbpools
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(VectorU(npts,nvm,nbpools),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for VectorU. We stop. We need npts*nvm*nbpools words',  & 
+       &     npts, nvm, nbpools
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(MatrixV(npts,nvm,nbpools,nbpools),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for MatrixV. We stop. We need npts*nvm*nbpools*nbpools words',  & 
+       &     npts, nvm, nbpools, nbpools
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(MatrixW(npts,nvm,nbpools,nbpools),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for MatrixW. We stop. We need npts*nvm*nbpools*nbpools words',  & 
+       &     npts, nvm, nbpools, nbpools
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(previous_stock(npts,nvm,nbpools),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for previous_stock. We stop. We need npts*nvm*nbpools words',  & 
+       &     npts, nvm, nbpools
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(current_stock(npts,nvm,nbpools),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for current_stock. We stop. We need npts*nvm*nbpools words',  & 
+       &     npts, nvm, nbpools
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    
+    ALLOCATE(forest_managed(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for forest_managed. We stop. We need npts*nvm words',  & 
+       &     npts, nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+
+    ALLOCATE(forest_managed_lastyear(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for forest_managed_lastyear. We stop. We need npts*nvm words',  & 
+       &     npts, nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(species_change_map(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for species_change_map. We stop. We need npts*nvm words',  & 
+       &     npts, nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    species_change_map(:,:)=0
+
+    ALLOCATE(lpft_replant(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for lpft_replant. We stop. We need npts*nvm words',  & 
+       &     npts, nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    lpft_replant(:,:)=.FALSE.
+
+    ALLOCATE(age_stand(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for age_stand. We stop. We need npts*nvm words',  & 
+       &     npts, nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(rotation_n(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for rotation_n. We stop. We need npts*nvm words',  & 
+       &     npts, nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(last_cut(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for last_cut. We stop. We need npts*nvm words',  & 
+       &     npts, nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(sigma(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for sigma. We stop. We need npts*nvm words',  & 
+       &     npts, nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(KF(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for KF. We stop. We need nvm words = ',npts*nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    KF(:,:) = zero ! Is there a better place in the code for this?
+
+    ALLOCATE(k_latosa_adapt(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for k_latosa_adapt. We stop. We need nvm words = ',npts*nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(harvest_pool(npts,nvm,ndia_harvest+1,nelements),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for harvest_pool. We stop. We need many words = ',&
+            npts*nvm*(ndia_harvest+1)*nelements
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    harvest_pool(:,:,:,:)=zero
+
+    ALLOCATE(harvest_type(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for harvest_type. We stop. We need many words = ',&
+            npts*nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    harvest_type(:,:)=zero
+
+    ALLOCATE(harvest_cut(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for harvest_cut. We stop. We need many words = ',&
+            npts*nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    harvest_cut(:,:)=zero
+
+    ALLOCATE(harvest_area(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for harvest_area. We stop. We need many words = ',&
+            npts*nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    harvest_area(:,:)=zero
+
+    ALLOCATE(harvest_pool_bound(0:ndia_harvest+1),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for harvest_pool_bound. ' // &
+            'We stop. We need ndia_harvest+2 words = ',&
+            ndia_harvest+2
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ! Here we can initialize the values of this array, too.  They should never change
+    ! over the course of the simulation.
+    harvest_pool_bound(ndia_harvest+1) = val_exp
+    DO idia = 0,ndia_harvest
+       harvest_pool_bound(idia) = max_harvest_dia*REAL(idia,r_std)/REAL(ndia_harvest,r_std)
+    ENDDO
+
+    ALLOCATE(mai(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for mai. ' // &
+            'We stop. We need npts*nvm words = ',&
+            npts*nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(pai(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for pai. ' // &
+            'We stop. We need npts*nvm words = ',&
+            npts*nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(previous_wood_volume(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for previous_wood_volume. ' // &
+            'We stop. We need npts*nvm words = ',&
+            npts*nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+    
+    ALLOCATE(mai_count(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for mai_count. We stop. We need npts*nvm words',  & 
+       &     npts, nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(bm_sync(npts,nvm,nelements),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for bm_sync. We stop. We need npts*nvm*nelements words',  & 
+       &     npts, nvm, nelements
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(coppice_dens(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for coppice_dens. ' // &
+            'We stop. We need npts*nvm words = ',&
+            npts*nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(litter_demand(npts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for litter_demand. ' // &
+            'We stop. We need npts words = ',&
+            npts
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(wstress_season(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for wstress_season. ' // &
+            'We stop. We need npts*nvm words = ',&
+            npts, nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(wstress_month(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for wstress_month. ' // &
+            'We stop. We need npts*nvm words = ',&
+            npts, nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(vir_wstress_fac(npts,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for vir_wstress_fac. ' // &
+            'We stop. We need npts*nvm words = ',&
+            npts, nvm
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ALLOCATE(c_buried(npts,nnobio),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for c_buried. ' // &
+            'We stop. We need npts*nnobio words = ',&
+            npts, nnobio
+       CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+     ! added by yitong yao in 06 Jan 2020 13:!5
+    ALLOCATE (psileaf_daily(npts,nvm,ncirc), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for psileaf_daily.We stop. We need npts*nvm*ncirc words', &
+        &    npts,nvm,ncirc
+        CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    
+
+ ! added by yitong yao in 06 Jan 2020 13:!5
+    ALLOCATE (psiroot_daily(npts,nvm,ncirc), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for psiroot_daily.We stop. We need npts*nvm*ncirc words', &
+        &    npts,nvm,ncirc
+        CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+ 
+    ! added by yitong yao in 06 Jan 2020 13:!5
+    ALLOCATE (stemplc_daily(npts,nvm,ncirc), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for stemplc_daily.We stop. We need npts*nvm*ncirc words', &
+        &    npts,nvm,ncirc
+        CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+
+    ! added by yitong yao in 06 Jan 2020 13:15 above line
+    
+    ! added by yitong yao in 07 Jan 2020 11:00 
+    ALLOCATE (psistem_daily(npts,nvm,ncirc), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for psistem_daily.We stop. We need npts*nvm*ncirc words', &
+        &    npts,nvm,ncirc
+        CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ! added by yitong yao in 07 Jan 2020 11:00 above lines
+    ! added by yitong yao in Feb 24 2020 21:02 
+    ALLOCATE (humrel_ddd(npts,nvm), stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Memory allocation error for humrel_ddd. We stop. We need npts*nvm words', &
+        &    npts,nvm
+        CALL ipslerr_p (3,'stomate_init', 'Memory allocation issue','','')
+    ENDIF
+
+    ! added by yitong yao in Feb 24 2020 21:02 
+
+    !! 5. File definitions
+    
+    ! Store history and restart files in common variables
+    hist_id_stomate = hist_id_stom
+    hist_id_stomate_IPCC = hist_id_stom_IPCC
+    rest_id_stomate = rest_id_stom
+    
+    ! In STOMATE reduced grids are used containing only terrestrial pixels.
+    ! Build a new indexing table for the vegetation fields separating 
+    ! between the different PFTs. Note that ::index has dimension (npts) 
+    ! wheras ::indexpft has dimension (npts*nvm). 
+
+    hori_index(:) = index(:)
+
+    DO j = 1, nvm
+       DO ji = 1, npts
+          horipft_index((j-1)*npts+ji) = index(ji)+(j-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+    ENDDO
+
+    DO j = 1, nlevels_tot
+       DO ji = 1, npts
+          horican_index((j-1)*npts+ji) = index(ji)+(j-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+    ENDDO
+
+    ! Similar index tables are build for the land cover change variables
+    DO j = 1, nshort
+       DO ji = 1, npts
+          horip_s_index((j-1)*npts+ji) = index(ji)+(j-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+    ENDDO
+
+    DO j = 1, nmedium
+       DO ji = 1, npts
+          horip_m_index((j-1)*npts+ji) = index(ji)+(j-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+    ENDDO
+
+    DO j = 1, nlong
+       DO ji = 1, npts
+          horip_l_index((j-1)*npts+ji) = index(ji)+(j-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+    ENDDO
+
+    DO j = 1, nshort+1
+       DO ji = 1, npts
+          horip_ss_index((j-1)*npts+ji) = index(ji)+(j-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+    ENDDO
+
+    DO j = 1, nmedium+1
+       DO ji = 1, npts
+          horip_mm_index((j-1)*npts+ji) = index(ji)+(j-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+    ENDDO
+
+    DO j = 1, nlong+1
+       DO ji = 1, npts
+          horip_ll_index((j-1)*npts+ji) = index(ji)+(j-1)*kjpij + offset_omp - offset_mpi
+       ENDDO
+    ENDDO
+
+  !! 6. Initialization of global and land cover change variables. 
+
+    ! All variables are cumulative variables. bm_to_litter is not and is therefore
+    ! excluded
+    !   bm_to_litter(:,:,:) = zero
+    turnover_daily(:,:,:,:) = zero
+    resp_hetero_d(:,:) = zero
+    resp_hetero_litter_d(:,:)=zero
+    resp_hetero_soil_d(:,:)=zero
+
+    co2_flux_daily(:,:) = zero
+    co2_flux_monthly(:,:) = zero
+    cflux_prod_monthly(:) = zero
+    harvest_above_monthly(:) = zero
+    control_moist_daily(:,:) = zero
+    control_temp_daily(:,:) = zero
+    soilcarbon_input_daily(:,:,:) = zero
+    
+    ! added by Yitong Yao in 06 Jan 2020 13:51
+    stemplc_daily(:,:,:)=zero
+    ! added by Yitong Yao in 06 Jan 2020 13:51 above line 
+    humrel_ddd(:,:)=zero 
+    ! added by yitong yao in 07 Jan 2020 11:02 
+    psistem_daily(:,:,:)=zero
+    psileaf_daily(:,:,:)=zero
+    psiroot_daily(:,:,:)=zero
+    ! added by yitong yao in 07 Jan 2020 11:02 above lines
+
+    ! Land cover change variables
+    prod_s(:,:)  = zero
+    prod_m(:,:)  = zero
+    prod_l(:,:) = zero
+    flux_s(:,:)  = zero
+    flux_m(:,:)  = zero
+    flux_l(:,:) = zero
+    cflux_prod_s(:)  = zero
+    cflux_prod_m(:) = zero
+    cflux_prod_l(:) = zero
+    fpc_max(:,:)=zero
+    
+  END SUBROUTINE stomate_init
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: stomate_clear
+!!
+!>\BRIEF        Deallocate memory of the stomate variables.
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCES	: None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+  
+  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(ba)) DEALLOCATE(ba)
+   
+    IF (ALLOCATED(adapted)) DEALLOCATE(adapted)
+    IF (ALLOCATED(regenerate)) DEALLOCATE(regenerate)
+    IF (ALLOCATED(humrel_daily)) DEALLOCATE(humrel_daily)
+    IF (ALLOCATED(vir_humrel_daily)) DEALLOCATE(vir_humrel_daily)
+    IF (ALLOCATED(transpir_supply_daily)) DEALLOCATE(transpir_supply_daily)
+    IF (ALLOCATED(vir_transpir_supply_daily)) DEALLOCATE(vir_transpir_supply_daily)
+    IF (ALLOCATED(transpir_daily)) DEALLOCATE(transpir_daily)
+    IF (ALLOCATED(gdd_init_date)) DEALLOCATE(gdd_init_date)
+    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(humrel_growingseason)) DEALLOCATE(humrel_growingseason)
+    IF (ALLOCATED(vir_humrel_growingseason)) DEALLOCATE(vir_humrel_growingseason)
+    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_from_growthinit)) DEALLOCATE(gdd_from_growthinit)
+    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(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_litter_d)) DEALLOCATE(resp_hetero_litter_d)
+    IF (ALLOCATED(resp_hetero_soil_d)) DEALLOCATE(resp_hetero_soil_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)
+! moved to sechiba
+!    IF (ALLOCATED(circ_class_n)) DEALLOCATE(circ_class_n)
+!    IF (ALLOCATED(circ_class_biomass)) DEALLOCATE(circ_class_biomass)
+!    IF (ALLOCATED(ind)) DEALLOCATE(ind)
+!    IF (ALLOCATED(biomass)) DEALLOCATE(biomass)
+    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(lignin_wood)) DEALLOCATE(lignin_wood)
+    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(harvest_above_monthly)) DEALLOCATE (harvest_above_monthly)
+    IF (ALLOCATED(cflux_prod_monthly)) DEALLOCATE (cflux_prod_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(horican_index)) DEALLOCATE(horican_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(veget_fm)) DEALLOCATE(veget_fm)
+    IF (ALLOCATED(veget_max_fm)) DEALLOCATE(veget_max_fm)
+    IF (ALLOCATED(lai_fm))  DEALLOCATE(lai_fm)
+    !
+    IF (ALLOCATED(ok_equilibrium)) DEALLOCATE(ok_equilibrium)
+    IF (ALLOCATED(carbon_eq)) DEALLOCATE(carbon_eq)
+    IF (ALLOCATED(matrixA)) DEALLOCATE(matrixA)
+    IF (ALLOCATED(vectorB)) DEALLOCATE(vectorB)
+    IF (ALLOCATED(MatrixV)) DEALLOCATE(MatrixV)
+    IF (ALLOCATED(VectorU)) DEALLOCATE(VectorU)
+    IF (ALLOCATED(MatrixW)) DEALLOCATE(MatrixW)
+    IF (ALLOCATED(previous_stock)) DEALLOCATE(previous_stock)
+    IF (ALLOCATED(current_stock)) DEALLOCATE(current_stock) 
+    IF (ALLOCATED(nbp_accu)) DEALLOCATE(nbp_accu)
+    IF (ALLOCATED(nbp_flux)) DEALLOCATE(nbp_flux)
+    ! added by yitong yao 07 Jan 2020 16:33 
+    IF (ALLOCATED(counter_psi)) DEALLOCATE(counter_psi)
+    ! added by yitong yao 07 Jan 2020 16:33 above line 
+    !
+    IF (ALLOCATED(counter_2)) DEALLOCATE(counter_2)
+    IF (ALLOCATED(counter_0)) DEALLOCATE(counter_0)
+
+    IF (ALLOCATED(sigma)) DEALLOCATE (sigma) 
+    IF (ALLOCATED(age_stand)) DEALLOCATE (age_stand)
+    IF (ALLOCATED(rotation_n)) DEALLOCATE (rotation_n)
+    IF (ALLOCATED(last_cut)) DEALLOCATE (last_cut)
+    IF (ALLOCATED(KF)) DEALLOCATE (KF)
+    IF (ALLOCATED(k_latosa_adapt)) DEALLOCATE (k_latosa_adapt)
+    IF (ALLOCATED(harvest_pool)) DEALLOCATE (harvest_pool)
+    IF (ALLOCATED(harvest_type)) DEALLOCATE (harvest_type)
+    IF (ALLOCATED(harvest_cut)) DEALLOCATE (harvest_cut)
+    IF (ALLOCATED(harvest_area)) DEALLOCATE (harvest_area)
+    IF (ALLOCATED(harvest_pool_bound)) DEALLOCATE (harvest_pool_bound)
+    IF (ALLOCATED(mai)) DEALLOCATE (mai)
+    IF (ALLOCATED(pai)) DEALLOCATE (pai)
+    IF (ALLOCATED(previous_wood_volume)) DEALLOCATE (previous_wood_volume)
+    IF (ALLOCATED(mai_count)) DEALLOCATE (mai_count)
+    IF (ALLOCATED(coppice_dens)) DEALLOCATE (coppice_dens)
+    IF (ALLOCATED(litter_demand)) DEALLOCATE (litter_demand)
+    IF (ALLOCATED(wstress_season)) DEALLOCATE (wstress_season)
+    IF (ALLOCATED(wstress_month)) DEALLOCATE (wstress_month)
+    IF (ALLOCATED(vir_wstress_fac)) DEALLOCATE (vir_wstress_fac)
+    IF (ALLOCATED(c_buried)) DEALLOCATE (c_buried)
+    IF (ALLOCATED(bm_sync)) DEALLOCATE (bm_sync)
+    IF (ALLOCATED(forest_managed)) DEALLOCATE (forest_managed)
+    IF (ALLOCATED(forest_managed_lastyear)) DEALLOCATE (forest_managed_lastyear)
+    IF (ALLOCATED(circ_class_dist)) DEALLOCATE (circ_class_dist)
+    IF (ALLOCATED(st_dist)) DEALLOCATE (st_dist)
+    IF (ALLOCATED(species_change_map)) DEALLOCATE (species_change_map)
+    IF (ALLOCATED(lpft_replant)) DEALLOCATE (lpft_replant)
+
+    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(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)
+       IF (ALLOCATED(ok_equilibrium_g)) DEALLOCATE(ok_equilibrium_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 (horip_s_index)) DEALLOCATE (horip_s_index)
+    IF ( ALLOCATED (horip_m_index)) DEALLOCATE (horip_m_index)
+    IF ( ALLOCATED (horip_l_index)) DEALLOCATE (horip_l_index)
+    IF ( ALLOCATED (horip_ss_index)) DEALLOCATE (horip_ss_index)
+    IF ( ALLOCATED (horip_mm_index)) DEALLOCATE (horip_mm_index)
+    IF ( ALLOCATED (horip_ll_index)) DEALLOCATE (horip_ll_index)
+    IF ( ALLOCATED (prod_s)) DEALLOCATE (prod_s)
+    IF ( ALLOCATED (prod_m)) DEALLOCATE (prod_m)
+    IF ( ALLOCATED (prod_l)) DEALLOCATE (prod_l)
+    IF ( ALLOCATED (flux_s)) DEALLOCATE (flux_s)
+    IF ( ALLOCATED (flux_m)) DEALLOCATE (flux_m)
+    IF ( ALLOCATED (flux_l)) DEALLOCATE (flux_l)
+    IF ( ALLOCATED (cflux_prod_s)) DEALLOCATE (cflux_prod_s)
+    IF ( ALLOCATED (cflux_prod_m)) DEALLOCATE (cflux_prod_m)
+    IF ( ALLOCATED (cflux_prod_l)) DEALLOCATE (cflux_prod_l)
+    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)
+    IF ( ALLOCATED (fpc_max)) DEALLOCATE (fpc_max)
+    IF ( ALLOCATED (stemplc_daily)) DEALLOCATE (stemplc_daily)
+    IF ( ALLOCATED (psistem_daily)) DEALLOCATE (psistem_daily)
+    IF ( ALLOCATED (psileaf_daily)) DEALLOCATE (psileaf_daily)
+    IF ( ALLOCATED (psiroot_daily)) DEALLOCATE (psiroot_daily)
+    IF ( ALLOCATED (humrel_ddd)) DEALLOCATE (humrel_ddd)
+ !! 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
+!!
+!>\BRIEF        Initialize variables of stomate with a none-zero initial value.
+!! Subroutine is called only if ::ok_stomate = .TRUE. STOMATE diagnoses some 
+!! variables for SECHIBA : assim_param, deadleaf_cover, etc. These variables can 
+!! be recalculated from STOMATE's prognostic variables.
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): leaf age (::leaf_age) and fraction of leaves in leaf 
+!! age class (::leaf_frac). The maximum water on vegetation available for 
+!! interception, fraction of soil covered by dead leaves
+!! (::deadleaf_cover) and assimilation parameters (:: assim_param).
+!!
+!! REFERENCE(S)	: None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE stomate_var_init &
+       &  (npts, veget_cov_max, leaf_age, leaf_frac, &
+       &   tlong_ref, t2m_month, dead_leaves, &
+       &   forest_managed, age_stand, &
+       &   deadleaf_cover, assim_param)
+
+
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std),INTENT(in)                         :: npts            !! Domain size - terrestrial pixels only
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)        :: veget_cov_max   !! Fractional coverage: maximum share of the pixel 
+                                                                         !! covered by a PFT (unitless) 
+    REAL(r_std),DIMENSION(npts),INTENT(in)            :: tlong_ref       !! "long term" 2 meter reference temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(in)            :: t2m_month       !! Air temperature at 2 meter integrated over a 
+                                                                         !! month (K) 
+    REAL(r_std),DIMENSION(npts,nvm,nlitt),INTENT(in)  :: dead_leaves     !! Metabolic and structural fraction of dead leaves 
+                                                                         !! per ground area 
+                                                                         !! @tex $(gC m^{-2})$ @endtex 
+    INTEGER(i_std),DIMENSION(npts,nvm),INTENT(in)     :: forest_managed  !! forest management flag (0-4, unitless)
+    INTEGER(i_std),DIMENSION(npts,nvm),INTENT(in)     :: age_stand       !! Age of stand (years)
+    
+    !! 0.2 Modified variables
+
+    REAL(r_std),DIMENSION(npts,nvm,nleafages),INTENT(inout) :: leaf_age  !! Age of different leaf classes per PFT (days)
+    REAL(r_std),DIMENSION(npts,nvm,nleafages),INTENT(inout) :: leaf_frac !! Fraction of leaves in leaf age class per PFT 
+                                                                         !! (unitless; 1) 
+    
+    !! 0.3 Output variables
+
+    REAL(r_std),DIMENSION(npts), INTENT (out)         :: deadleaf_cover  !! Fraction of soil covered by dead leaves 
+                                                                         !! (unitless) 
+    REAL(r_std),DIMENSION(:,:,:), INTENT(out)         :: assim_param     !! min+max+opt temperatures (K) & vmax for 
+                                                                         !! photosynthesis  
+                                                                         !! @tex $(\mumol m^{-2} s^{-1})$ @endtex
+    ! 0.4 Local variables
+   
+    REAL(r_std),PARAMETER                             :: dt_0 = zero     !! Dummy time step, must be zero
+    REAL(r_std),DIMENSION(npts,nvm)                   :: vcmax           !! Dummy vcmax 
+                                                                         !! @tex $(\mu mol m^{-2} s^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                  :: tau_dum_leaf    !! Dummy leaf turnover time. Equals the initial
+                                                                         !! because it has to be calculated before
+                                                                         !! waterstress is known (days)
+    INTEGER(i_std)                                    :: j               !! Index (untiless)
+    
+!_ ================================================================================================================================   
+
+    ! Only if stomate is activated
+    IF (control%ok_stomate) THEN
+     
+  !! 1. photosynthesis parameters
+
+       !! 1.1 vcmax (stomate_vmax.f90)
+       IF (control%ok_functional_allocation)THEN
+
+          DO j = 1,nvm
+             tau_dum_leaf(:,j) = tau_leaf(j)
+          ENDDO
+          CALL vmax_prognostic (npts, dt_0, leaf_age, leaf_frac,  &
+            &    age_stand, vcmax, tau_dum_leaf)
+
+       ELSE
+
+          CALL vmax_diagnostic (npts, dt_0, leaf_age, leaf_frac,  &
+            &    forest_managed, age_stand, &
+            &    vcmax)
+
+       ENDIF
+      
+       !! 1.3 transform into nvm vegetation types
+       assim_param(:,:,ivcmax) = zero
+       DO j = 2, nvm
+          assim_param(:,j,ivcmax)=vcmax(:,j)
+       ENDDO
+       
+  !! 2. Dead leaf cover (stomate_litter.f90)
+       
+       CALL deadleaf (npts, veget_cov_max, dead_leaves, deadleaf_cover)     
+       
+    ENDIF ! ok_stomate = .TRUE.
+    
+  END SUBROUTINE stomate_var_init
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: stomate_accu
+!!
+!>\BRIEF        Accumulate a variable for the time period specified by 
+!! ::dt_tot or calculate the mean value over ::dt_tot.
+!! 
+!! DESCRIPTION : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): accumulated or mean variable ::field_out:: 
+!!
+!! REFERENCE(S)	: None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE stomate_accu &
+       &  (npts, n_dim2, dt_tot, dt, ldmean, field_in, field_out)
+    
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+ 
+    INTEGER(i_std),INTENT(in)                        :: npts      !! Domain size (unitless)
+    INTEGER(i_std),INTENT(in)                        :: n_dim2    !! 2nd dimension (1 or nvm)
+    REAL(r_std),INTENT(in)                           :: dt_tot    !! Current time step (days)
+    REAL(r_std),INTENT(in)                           :: dt        !! Accumulated time step (days)
+    LOGICAL,INTENT(in)                               :: ldmean    !! Flag to calculate the mean over
+!!$    LOGICAL,INTENT(in)                               :: ldnight   !! Flag indicating day vs night time
+    REAL(r_std),DIMENSION(:,:),INTENT(in)            :: field_in  !! Field that needs to be accumulated
+ 
+    !! 0.2 Output variables
+    
+    !! 0.3 Modified variables
+
+    REAL(r_std),DIMENSION(:,:),INTENT(inout)         :: field_out !! Accumulated or mean field
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                   :: ipts      !! Index
+  
+!_ ================================================================================================================================
+
+  !! 1. Accumulate field
+
+    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
+!!
+!>\BRIEF        Allocate memory for the variables containing the forcing data.
+!! The maximum size of the allocated memory is specified in run definition file
+!! (::max_totsize) and needs to be a compromise between charging the memory and 
+!! accessing disks to get the forcing data.
+!!
+!! DESCRIPTION : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): Strictly speaking the subroutine has no output 
+!! variables. However, the routine allocates memory for later use. 
+!!
+!! REFERENCE(S)	: None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE init_forcing (npts,nsfm,nsft)
+    
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+    
+    INTEGER(i_std),INTENT(in) :: npts     !! Domain size - terrestrial pixels only (unitless)
+    INTEGER(i_std),INTENT(in) :: nsfm     !! Number of time steps that can be stored in memory (unitless)
+    INTEGER(i_std),INTENT(in) :: nsft     !! Number of time steps in a year (unitless)
+
+   !! 0.2 Output variables
+
+   !! 0.3 Modified variables
+
+   !! 0.4 Local variables
+
+    LOGICAL                   :: l_error  !! Check errors in netcdf call
+    INTEGER(i_std)            :: ier      !! Check errors in netcdf call
+!_ ================================================================================================================================
+    
+  !! 1. Allocate memory
+
+    ! Note ::nvm is number of PFTs and ::nbdl is number of soil layers
+    l_error = .FALSE.
+    ALLOCATE(clay_fm(npts,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables clay_fm ',npts,nsfm
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(humrel_daily_fm(npts,nvm,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables humrel_daily_fm ',npts,nvm,nsfm
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(litterhum_daily_fm(npts,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables litterhum_daily_fm ',npts,nsfm
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(t2m_daily_fm(npts,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables t2m_daily_fm ',npts,nsfm
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(t2m_min_daily_fm(npts,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables t2m_min_daily_fm ',npts,nsfm
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(tsurf_daily_fm(npts,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables tsurf_daily_fm ',npts,nsfm
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(tsoil_daily_fm(npts,nbdl,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables tsoil_daily_fm ',npts,nbdl,nsfm
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(soilhum_daily_fm(npts,nbdl,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables soilhum_daily_fm ',npts,nbdl,nsfm
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(precip_fm(npts,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables precip_fm ',npts,nsfm
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(gpp_daily_fm(npts,nvm,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables gpp_daily_fm ',npts,nvm,nsfm
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(veget_fm(npts,nvm,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables veget_fm ',npts,nvm,nsfm
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(veget_max_fm(npts,nvm,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables veget_max_fm ',npts,nvm,nsfm
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(lai_fm(npts,nvm,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables lai_fm ',npts,nvm,nsfm
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(isf(nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables isf ',nsfm
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(nf_written(nsft),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables nf_written ',nsft
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    ALLOCATE(nf_cumul(nsft),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables nf_cumul ',nsft
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+    
+  !! 2. Allocate memory for the root processor only (parallel computing)
+
+    ! Where, ::nbp_glo is the number of global continental points
+    IF (is_root_prc) THEN
+       ALLOCATE(clay_fm_g(nbp_glo,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       IF (l_error) THEN
+          WRITE(numout,*) 'Problem with memory allocation: forcing variables clay_fm_g ',nbp_glo,nsfm
+          CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+       ENDIF
+       ALLOCATE(humrel_daily_fm_g(nbp_glo,nvm,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       IF (l_error) THEN
+          WRITE(numout,*) 'Problem with memory allocation: forcing variables humrel_daily_fm_g ',nbp_glo,nvm,nsfm
+          CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+       ENDIF
+       ALLOCATE(litterhum_daily_fm_g(nbp_glo,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       IF (l_error) THEN
+          WRITE(numout,*) 'Problem with memory allocation: forcing variables litterhum_daily_fm_g ',nbp_glo,nsfm
+          CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+       ENDIF
+       ALLOCATE(t2m_daily_fm_g(nbp_glo,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       IF (l_error) THEN
+          WRITE(numout,*) 'Problem with memory allocation: forcing variables t2m_daily_fm_g ',nbp_glo,nsfm
+          CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+       ENDIF
+       ALLOCATE(t2m_min_daily_fm_g(nbp_glo,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       IF (l_error) THEN
+          WRITE(numout,*) 'Problem with memory allocation: forcing variables t2m_min_daily_fm_g ',nbp_glo,nsfm
+          CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+       ENDIF
+       ALLOCATE(tsurf_daily_fm_g(nbp_glo,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       IF (l_error) THEN
+          WRITE(numout,*) 'Problem with memory allocation: forcing variables tsurf_daily_fm_g ',nbp_glo,nsfm
+          CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+       ENDIF
+       ALLOCATE(tsoil_daily_fm_g(nbp_glo,nbdl,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       IF (l_error) THEN
+          WRITE(numout,*) 'Problem with memory allocation: forcing variables tsoil_daily_fm_g ',nbp_glo,nbdl,nsfm
+          CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+       ENDIF
+       ALLOCATE(soilhum_daily_fm_g(nbp_glo,nbdl,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       IF (l_error) THEN
+          WRITE(numout,*) 'Problem with memory allocation: forcing variables soilhum_daily_fm_g ',nbp_glo,nbdl,nsfm
+          CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+       ENDIF
+       ALLOCATE(precip_fm_g(nbp_glo,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       IF (l_error) THEN
+          WRITE(numout,*) 'Problem with memory allocation: forcing variables precip_fm_g ',nbp_glo,nsfm
+          CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+       ENDIF
+       ALLOCATE(gpp_daily_fm_g(nbp_glo,nvm,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       IF (l_error) THEN
+          WRITE(numout,*) 'Problem with memory allocation: forcing variables gpp_daily_fm_g ',nbp_glo,nvm,nsfm
+          CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+       ENDIF
+       ALLOCATE(veget_fm_g(nbp_glo,nvm,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       IF (l_error) THEN
+          WRITE(numout,*) 'Problem with memory allocation: forcing variables veget_fm_g ',nbp_glo,nvm,nsfm
+          CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+       ENDIF
+       ALLOCATE(veget_max_fm_g(nbp_glo,nvm,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       IF (l_error) THEN
+          WRITE(numout,*) 'Problem with memory allocation: forcing variables veget_max_fm_g ',nbp_glo,nvm,nsfm
+          CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+       ENDIF
+       ALLOCATE(lai_fm_g(nbp_glo,nvm,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       IF (l_error) THEN
+          WRITE(numout,*) 'Problem with memory allocation: forcing variables lai_fm_g ',nbp_glo,nvm,nsfm
+          CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+       ENDIF
+    ELSE
+       ! Allocate memory for co-processors
+       ALLOCATE(clay_fm_g(0,nsfm),stat=ier)
+       ALLOCATE(humrel_daily_fm_g(0,nvm,nsfm),stat=ier)
+       ALLOCATE(litterhum_daily_fm_g(0,nsfm),stat=ier)
+       ALLOCATE(t2m_daily_fm_g(0,nsfm),stat=ier)
+       ALLOCATE(t2m_min_daily_fm_g(0,nsfm),stat=ier)
+       ALLOCATE(tsurf_daily_fm_g(0,nsfm),stat=ier)
+       ALLOCATE(tsoil_daily_fm_g(0,nbdl,nsfm),stat=ier)
+       ALLOCATE(soilhum_daily_fm_g(0,nbdl,nsfm),stat=ier)
+       ALLOCATE(precip_fm_g(0,nsfm),stat=ier)
+       ALLOCATE(gpp_daily_fm_g(0,nvm,nsfm),stat=ier)
+       ALLOCATE(veget_fm_g(0,nvm,nsfm),stat=ier)
+       ALLOCATE(veget_max_fm_g(0,nvm,nsfm),stat=ier)
+       ALLOCATE(lai_fm_g(0,nvm,nsfm),stat=ier)
+    ENDIF ! is_root_proc
+    
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables'
+       CALL ipslerr_p (3,'init_forcing', 'Memory allocation issue','','')
+    ENDIF
+
+  !! 3. Initilaize variables
+
+    CALL forcing_zero
+    
+  END SUBROUTINE init_forcing
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: forcing_zero
+!!
+!>\BRIEF        Initialize variables containing the forcing data; variables are 
+!! set to zero.
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCES	: None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+  
+  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
+    veget_fm(:,:,:) = zero
+    veget_max_fm(:,:,:) = zero
+    lai_fm(:,:,:) = zero
+    
+  END SUBROUTINE forcing_zero
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: forcing_write
+!!
+!>\BRIEF        Appends data values to a netCDF file containing the forcing 
+!! variables of the general processes in stomate.
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): netCDF file
+!!
+!! REFERENCES	: None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE forcing_write(forcing_id,ibeg,iend)
+    
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std),INTENT(in)      :: forcing_id  !! File identifer of forcing file, assigned when netcdf is created
+    INTEGER(i_std),INTENT(in)      :: ibeg, iend  !! First and last time step to be written
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                 :: iisf        !! Index of isf where isf is the number of time steps that can be 
+                                                  !! stored in memory 
+    INTEGER(i_std)                 :: iblocks     !! Index of block that is written
+    INTEGER(i_std)                 :: nblocks     !! Number of blocks that needs to be written
+    INTEGER(i_std)                 :: ier         !! Check errors in netcdf call
+    INTEGER(i_std),DIMENSION(0:2)  :: ifirst      !! First block in memory - changes with iblocks
+    INTEGER(i_std),DIMENSION(0:2)  :: ilast       !! Last block in memory - changes with iblocks
+    INTEGER(i_std),PARAMETER       :: ndm = 10    !! Maximum number of dimensions
+    INTEGER(i_std),DIMENSION(ndm)  :: start       !! First block to write
+    INTEGER(i_std)                 :: ndim        !! Dimensions of forcing to be added to the netCDF
+    INTEGER(i_std),DIMENSION(ndm)  :: count_force !! Number of elements in each dimension  
+    INTEGER(i_std)                 :: vid         !! Variable identifer of netCDF
+!_ ================================================================================================================================
+    
+  !! 1. Determine number of blocks of forcing variables that are stored in memory
+
+    nblocks = 0
+    ifirst(:) = 1
+    ilast(:) = 1
+    DO iisf = ibeg, iend
+       IF (     (nblocks /= 0) &
+            &      .AND.(isf(iisf) == isf(ilast(nblocks))+1)) THEN
+          ! Last block found
+          ilast(nblocks) = iisf
+       ELSE
+          ! First block found
+          nblocks = nblocks+1
+          IF (nblocks > 2) THEN 
+             CALL ipslerr_p (3,'forcing_write', 'Memory allocationNumber of blocks issue','','')
+          ENDIF
+          ifirst(nblocks) = iisf
+          ilast(nblocks) = iisf
+       ENDIF
+    ENDDO
+
+  !! 2. Gather distributed variables (parallel computing)
+
+    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(veget_fm,veget_fm_g)
+    CALL gather(veget_max_fm,veget_max_fm_g)
+    CALL gather(lai_fm,lai_fm_g)
+ 
+ !! 3. Append data to netCDF file
+   
+    IF (is_root_prc) THEN
+       ! The netCDF file has been created earlier in this module, a file ID is available 
+       ! and variables and dimensions have already been defined
+       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 = 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
+    
+  !! 4. Adjust flag of forcing file
+    nf_written(isf(:)) = .TRUE.
+
+  END SUBROUTINE forcing_write
+
+  
+!! ================================================================================================================================
+!! SUBROUTINE 	: forcing_read
+!!
+!>\BRIEF        Read forcing file.
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): None 
+!!
+!! REFERENCES	: None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE forcing_read(forcing_id,nsfm)
+   
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std),INTENT(in)  :: forcing_id           !! File identifer of forcing file, assigned when netcdf is created
+    INTEGER(i_std),INTENT(in)  :: nsfm                 !! Number of time steps stored in memory        
+    
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                 :: iisf              !! Index of isf where isf is the number of time steps that can be stored in 
+                                                        !! memory 
+    INTEGER(i_std)                 :: iblocks           !! Index of block that is written
+    INTEGER(i_std)                 :: nblocks           !! Number of blocks that needs to be written
+    INTEGER(i_std)                 :: ier               !! Check error of netcdf call
+    INTEGER(i_std),DIMENSION(0:2)  :: ifirst            !! First block in memory - changes with iblocks
+    INTEGER(i_std),DIMENSION(0:2)  :: ilast             !! Last block in memory - changes with iblocks
+    INTEGER(i_std),PARAMETER       :: ndm = 10          !! Maximum number of dimensions
+    INTEGER(i_std),DIMENSION(ndm)  :: start             !! First block to write
+    INTEGER(i_std)                 :: ndim              !! Dimensions of forcing to be added to the netCDF
+    INTEGER(i_std),DIMENSION(ndm)  :: count_force       !! Number of elements in each dimension
+    INTEGER(i_std)                 :: vid               !! Variable identifer of netCDF
+    LOGICAL, PARAMETER             :: check=.FALSE.     !! Flag for debugging 
+    LOGICAL                        :: a_er=.FALSE.      !! Error catching from netcdf file
+!_ ================================================================================================================================
+
+    IF (check) WRITE(numout,*) "forcing_read "
+    
+  !! 1. 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
+          veget_fm(:,:,iisf) = zero
+          veget_max_fm(:,:,iisf) = zero
+          lai_fm(:,:,iisf) = zero
+       ENDIF
+    ENDDO
+    
+  !! 2. 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) THEN
+                CALL ipslerr_p (3,'forcing_read', 'Number of blocks issue','','')
+             ENDIF
+             ifirst(nblocks) = iisf
+             ilast(nblocks) = iisf
+          ENDIF
+       ENDIF
+    ENDDO
+    IF (check) WRITE(numout,*) "forcing_read nblocks, ifirst, ilast",nblocks, ifirst, ilast
+    
+  !! 3. Read variable values
+
+    IF (is_root_prc) THEN
+       DO iblocks = 1, nblocks
+          IF (check) WRITE(numout,*) "forcing_read iblocks, ifirst(iblocks), ilast(iblocks)",iblocks, &
+               ifirst(iblocks), ilast(iblocks)
+          IF (ifirst(iblocks) /= ilast(iblocks)) THEN
+             a_er=.FALSE.
+             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)
+             a_er = a_er.OR.(ier /= 0)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &            clay_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             a_er = a_er.OR.(ier /= 0)
+
+             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)
+             a_er = a_er.OR.(ier /= 0)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &            humrel_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             a_er = a_er.OR.(ier /= 0)
+
+             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)
+             a_er = a_er.OR.(ier /= 0)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &              litterhum_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             a_er = a_er.OR.(ier /= 0)
+
+             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)
+             a_er = a_er.OR.(ier /= 0)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &              t2m_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             a_er = a_er.OR.(ier /= 0)
+
+             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)
+             a_er = a_er.OR.(ier /= 0)
+             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))
+             a_er = a_er.OR.(ier /= 0)
+
+             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)
+             a_er = a_er.OR.(ier /= 0)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &              tsurf_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             a_er = a_er.OR.(ier /= 0)
+
+             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)
+             a_er = a_er.OR.(ier /= 0)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &              tsoil_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             a_er = a_er.OR.(ier /= 0)
+
+             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)
+             a_er = a_er.OR.(ier /= 0)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &              soilhum_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             a_er = a_er.OR.(ier /= 0)
+
+             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)
+             a_er = a_er.OR.(ier /= 0)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &              precip_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             a_er = a_er.OR.(ier /= 0)
+
+             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)
+             a_er = a_er.OR.(ier /= 0)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &            gpp_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             a_er = a_er.OR.(ier /= 0)
+
+             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)
+             a_er = a_er.OR.(ier /= 0)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &            veget_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             a_er = a_er.OR.(ier /= 0)
+
+             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)
+             a_er = a_er.OR.(ier /= 0)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &            veget_max_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             a_er = a_er.OR.(ier /= 0)
+
+             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)
+             a_er = a_er.OR.(ier /= 0)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &            lai_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             a_er = a_er.OR.(ier /= 0)
+             IF (a_er) THEN
+                CALL ipslerr_p (3,'forcing_read', &
+                     &        'PROBLEM when read forcing file', &
+                     &        '','')
+             ENDIF
+
+          ENDIF ! (ifirst(iblocks) /= ilast(iblocks))
+       ENDDO ! iblocks
+    ENDIF ! is_root_prc
+
+  !! 4. Distribute the variable over several processors
+
+    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(veget_fm_g,veget_fm)
+    CALL scatter(veget_max_fm_g,veget_max_fm)
+    CALL scatter(lai_fm_g,lai_fm)
+  
+  END SUBROUTINE forcing_read
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: setlai
+!!
+!>\BRIEF        Routine to force the lai in STOMATE. The code in this routine
+!! simply CALCULATES lai and is therefore not functional. The routine should be 
+!! rewritten if one wants to force lai.
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::lai
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART : None
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE setlai(npts,lai,biomass)
+
+  !! 0 Variable and parameter declaration 
+  
+    !! 0.1 Input variables
+
+    INTEGER(i_std),INTENT(in)                                      :: npts     !! Domain size - number of pixels (unitless)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(in)  :: biomass  !!Biomass per PFT
+    
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out)  :: lai  !! PFT leaf area index @tex $(m^{2} m^{-2})$ @endtex
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                               :: j    !! index (unitless)
+!_ ================================================================================================================================
+    
+    !! 1. Set lai for bare soil to zero
+
+    lai(:,ibare_sechiba) = zero
+
+    !! 2. Multiply foliage biomass by sla to calculate lai for all PFTs and pixels
+
+    DO j=2,nvm
+       lai(:,j) = biomass(:,j,ileaf,icarbon)*sla(j)
+    ENDDO
+    
+  END SUBROUTINE setlai
+
+END MODULE stomate
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_assimtemp.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_assimtemp.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_assimtemp.f90	(revision 7236)
@@ -0,0 +1,143 @@
+! =================================================================================================================================
+! MODULE 	: stomate_assimtemp
+!
+! CONTACT	: orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      	: IPSL (2006). This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        Calculate the photosynthesis temperatures.
+!!	
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! SVN		:
+!! $HeadURL$ 
+!! $Date$
+!! $Revision$
+!! \n
+!_ =================================================================================================================================
+
+MODULE stomate_assimtemp
+
+  ! modules used:
+
+  USE pft_parameters
+  USE constantes 
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC assim_temp
+
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: assim_temp
+!!
+!>\BRIEF        This subroutine calculates the minimal, maximal and optimal 
+!! temperatures for photosynthesis. 
+!!
+!! \n DESCRIPTION (definitions, functional, design, flags): The temperatures are 
+!! calculated as second order polynomials of the long term reference temperature tlong_ref. 
+!!
+!! A climatological annual temperature is given as an input file of ORCHIDEE, at a 1.125Â°(lon)x1.121Â°(lat) spatial resolution. 
+!! This temperature was derived from a IIASA database (Leemans and Cramer, 1991).
+!! This initial climatological annual temperature is first interpolated at the spatial grid of the
+!! meteorological forcing fields in stomate_io.f90::get_reftemp (\f$tlong\_ref\f$).
+!! This long term reference temperature is then updated along the ORCHIDEE run at each stomate time step in stomate_season.f90.
+!! 
+!! The polynomial coefficients depend on the PFT and their values are defined in 
+!! stomate_constants.f90. Coefficients for degrees 1 and 2 of the polynomials are 
+!! zero, meaning the temperatures are just predefined constants (Wullschleger, 1993), except for C3
+!! grasses, which has been designed specifically for ORCHIDEE (no reference publication other than Krinner et al. (2005)).
+!!
+!! This routine is called once at the beginning by stomate_var_init and then at each stomate time step by stomateLpj.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): minimal (t_photo_min), maximal (t_photo_max) and 
+!! optimal temperatures (t_photo_opt) for photosynthesis
+!!
+!! REFERENCE(S)	: 
+!! - Krinner, G., Viovy, N., Noblet-Ducoudre, N. de, Ogee, J., Polcher, J., 
+!! Friedlingstein, P., Sitch, S., and Prentice, I. C (2005). A dynamic global 
+!! vegetation model for studies of the coupled atmosphere-biosphere system. 
+!! Global Biogeochem. Cycles, 19, GB1015
+!! - Leemans, R. and Cramer,W. (1991). The IIASA Database for Mean Monthly Values
+!! of Temperature, Precipitation, and Cloudiness on a Global Terrestrial Grid.
+!! Research Report, INTERNATIONAL INSTITUTE FOR APPLIED SYSTEMS ANALYSIS Laxenburg, Austria.
+!! International Standard Book Number 3-7045-0113-1. 
+!! - Wullschleger, S.D. (1993). Biochemical limitations to carbon assimilation in C\f$_3\f$ plants: 
+!! a retrospective analysis of the A/C\f$_i\f$ curves from 109 species. Journal of Experimental Botany, 44 (262), 907-920
+!!
+!! FLOWCHART    : None
+!!
+!! REVISION(S)	: None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE assim_temp (npts, tlong_ref, t2m_month, t_photo_min, t_photo_opt, t_photo_max)
+
+    !
+    !! 0. Variable and parameter declaration
+    !
+
+    !
+    !! 0.1 Input variables
+    !
+    INTEGER(i_std), INTENT(in)                                  :: npts        !! Domain size    
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: tlong_ref   !! "long term" 2 meter reference temperatures (K)    
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: t2m_month   !! "monthly" 2-meter temperatures (K)
+
+    !
+    !! 0.2 Output variables 
+    !
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)               :: t_photo_min !! Minimum temperature for photosynthesis (K)    
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)               :: t_photo_opt !! Optimum temperature for photosynthesis (K)    
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)               :: t_photo_max !! Maximum temperature for photosynthesis (K)
+
+    !
+    !! 0.3 Modified variables
+    !
+
+    !
+    !! 0.4 Local variables
+    !
+    REAL(r_std), DIMENSION(npts)                                :: tl          !! "Long term" 2 meter reference temperatures 
+                                                                               !! (degree C)    
+    INTEGER(i_std)                                              :: j           !! Index (unitless)
+
+!_ ================================================================================================================================
+
+    tl(:) = tlong_ref(:) - ZeroCelsius
+
+    DO j = 2,nvm	! Loop over # PFTs 
+
+       !
+       !! 1. Normal case
+       !
+
+       t_photo_min(:,j) = tphoto_min_c(j) + tphoto_min_b(j)*tl(:) + tphoto_min_a(j)*tl(:)*tl(:) + ZeroCelsius
+       t_photo_opt(:,j) = tphoto_opt_c(j) + tphoto_opt_b(j)*tl(:) + tphoto_opt_a(j)*tl(:)*tl(:) + ZeroCelsius
+       t_photo_max(:,j) = tphoto_max_c(j) + tphoto_max_b(j)*tl(:) + tphoto_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).
+       !     t2m_month is calculated at every stomate time step using a linear relaxation method, in stomate_season.f90 
+       !     (see section [27] in Krinner et al. (2005)).
+       !
+
+!! min_stomate is a constant defined in stomate_constants.f90 (= 1.E-8_r_std).
+       WHERE ( t2m_month(:) .LT. t_photo_min(:,j) )
+          t_photo_max(:,j) = t_photo_min(:,j) - min_stomate
+       ENDWHERE
+
+    ENDDO	! Loop over # PFTs
+
+  END SUBROUTINE assim_temp
+
+END MODULE stomate_assimtemp
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_data.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_data.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_data.f90	(revision 7236)
@@ -0,0 +1,857 @@
+! =================================================================================================================================
+! MODULE 	: stomate_data
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         "stomate_data" module defines the values about the PFT parameters. It will print
+!! the values of the parameters for STOMATE in the standard outputs. 
+!!
+!!\n DESCRIPTION: None 
+!!
+!! RECENT CHANGE(S): Sonke Zaehle: 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))
+!!
+!! REFERENCE(S)	: None
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE stomate_data
+
+  ! modules used:
+
+  USE constantes
+  USE pft_parameters
+  USE defprec
+  
+
+  IMPLICIT NONE
+
+  INTEGER(i_std),SAVE :: bavard=1                 !! Level of online diagnostics in STOMATE (0-4, unitless)
+!$OMP THREADPRIVATE(bavard)
+
+  INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: hori_index     !! Move to Horizontal indices
+!$OMP THREADPRIVATE(hori_index)
+
+  INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: horipft_index  !! Horizontal + PFT indices
+!$OMP THREADPRIVATE(horipft_index)
+
+  INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: horican_index  !! Horizontal + canopy levels indices
+!$OMP THREADPRIVATE(horican_index)
+
+  !
+  ! Functional Allocation
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)    :: latosa_height  !! Slope of the relationship between k_latosa
+                                                                    !! and tree height (-)
+!$OMP THREADPRIVATE(latosa_height)
+  
+   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)    :: latosa_ind    !! Slope of the relationship between k_latosa
+                                                                    !! and stand density (-)
+!$OMP THREADPRIVATE(latosa_ind)
+
+  !
+  ! Land cover change
+  !
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip_s_index   !! Horizontal + P short indices
+!$OMP THREADPRIVATE(horip_s_index)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip_m_index   !! Horizontal + P medium indices
+!$OMP THREADPRIVATE(horip_m_index)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip_l_index   !! Horizontal + P long indice
+!$OMP THREADPRIVATE(horip_l_index)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip_ss_index  !! Horizontal + P short indices
+!$OMP THREADPRIVATE(horip_ss_index)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip_mm_index  !! Horizontal + P medium indices
+!$OMP THREADPRIVATE(horip_mm_index)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip_ll_index  !! Horizontal + P long indices
+!$OMP THREADPRIVATE(horip_ll_index)
+
+
+  INTEGER(i_std),SAVE :: itime                 !! time step
+!$OMP THREADPRIVATE(itime)
+  INTEGER(i_std),SAVE :: hist_id_stomate       !! STOMATE history file ID
+!$OMP THREADPRIVATE(hist_id_stomate)
+  INTEGER(i_std),SAVE :: hist_id_stomate_IPCC  !! STOMATE history file ID for IPCC output
+!$OMP THREADPRIVATE(hist_id_stomate_IPCC)
+  INTEGER(i_std),SAVE :: rest_id_stomate       !! STOMATE restart file ID
+!$OMP THREADPRIVATE(rest_id_stomate)
+
+  REAL(r_std),PARAMETER :: adapted_crit = 1. - ( 1. / euler ) !! critical value for being adapted (1-1/e) (unitless)
+  REAL(r_std),PARAMETER :: regenerate_crit = 1. / euler       !! critical value for being regenerative (1/e) (unitless)
+
+  
+  ! private & public routines
+
+  PUBLIC data
+
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: data
+!!
+!>\BRIEF         This routine defines the values of the PFT parameters. It will print the values of the parameters for STOMATE
+!!               in the standard outputs of ORCHIDEE. 
+!!
+!! DESCRIPTION : This routine defines PFT parameters. It initializes the pheno_crit structure by tabulated parameters.\n
+!!               Some initializations are done for parameters. The SLA is calculated according *to* Reich et al (1992).\n
+!!               Another formulation by Reich et al(1997) could be used for the computation of the SLA.
+!!               The geographical coordinates might be used for defining some additional parameters
+!!               (e.g. frequency of anthropogenic fires, irrigation of agricultural surfaces, etc.). \n
+!!               For the moment, this possibility is not used. \n
+!!               The specifc leaf area (SLA) is calculated according Reich et al, 1992 by :
+!!               \latexonly
+!!               \input{stomate_data_SLA.tex}
+!!               \endlatexonly
+!!               The sapling (young) biomass for trees and for each compartment of biomass is calculated by :
+!!               \latexonly
+!!               \input{stomate_data_sapl_tree.tex}
+!!               \endlatexonly
+!!               The sapling biomass for grasses and for each compartment of biomass is calculated by :
+!!               \latexonly
+!!               \input{stomate_data_sapl_grass.tex}
+!!               \endlatexonly
+!!               The critical stem diameter is given by the following formula :
+!!               \latexonly
+!!               \input{stomate_data_stem_diameter.tex}
+!!               \endlatexonly
+!!
+!! RECENT CHANGE(S): Sonke Zaehle: 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)) 
+!!                   \latexonly
+!!                   \input{stomate_data_SLA_Reich_97.tex}
+!!                   \endlatexonly
+!!
+!! MAIN OUTPUT VARIABLE(S): 
+!!
+!! REFERENCE(S) :
+!! - Reich PB, Walters MB, Ellsworth DS, (1992), Leaf life-span in relation to leaf, plant and 
+!! stand characteristics among diverse ecosystems. Ecological Monographs, Vol 62, pp 365-392.
+!! - Reich PB, Walters MB, Ellsworth DS (1997) From tropics to tundra: global convergence in plant 
+!!  functioning. Proc Natl Acad Sci USA, 94:13730 13734
+!! - Magnani F., Mencuccini M. & Grace J. 2000. Age-related decline in stand productivity: the role of 
+!! structural acclimation under hydraulic constraints Plant, Cell and Environment 23, 251â263.
+!! - Bloom A.J., Chapin F.S. & Mooney H.A. (1985) Resource limitation in plants. An economic analogy.  
+!! Annual Review Ecology Systematics 16, 363â392.
+!! - Case K.E. & Fair R.C. (1989) Principles of Economics. Prentice Hall, London.
+!! - McDowell, N., Barnard, H., Bond, B.J., Hinckley, T., Hubbard, R.M., Ishii, H., KÃ¶stner, B., 
+!! Magnani, F. Marshall, J.D., Meinzer, F.C., Phillips, N., Ryan, M.G., Whitehead D. 2002. The 
+!! relationship between tree height and leaf area: sapwood area ratio. Oecologia, 132:12â20
+!! - Novick, K., Oren, R., Stoy, P., Juang, F.-Y., Siqueira, M., Katul, G. 2009. The relationship between
+!! reference canopy conductance and simplified hydraulic architecture. Advances in water resources 32,
+!! 809-819.  
+!!
+!! FLOWCHART    :
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE data 
+
+
+    !! 0. Variables and parameter declaration
+
+
+    !! 0.1 Input variables
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                               :: ier             !! Check errors (unitless)
+    LOGICAL                                      :: l_error         !! Check errors (unitless) 
+    INTEGER(i_std)                               :: j               !! Index (unitless)
+    REAL(r_std)                                  :: alpha           !! alpha's : (unitless)
+    REAL(r_std)                                  :: dia             !! Stem diameter (m) 
+    REAL(r_std)                                  :: csa_sap         !! Crown specific area sapling @tex $(m^2.ind^{-1})$ @endtex
+  LOGICAL(i_std),SAVE :: lfirstcall = .TRUE.                        !! see if this is the first call to this routine
+
+!_ ================================================================================================================================
+
+  IF(lfirstcall)THEN
+     ! this makes init errors go away for the whole routine
+     bm_sapl_old(:,icarbres,icarbon) = zero
+     lfirstcall=.FALSE.
+  ENDIF
+
+    IF ( bavard .GE. 1 ) WRITE(numout,*) 'data: PFT characteristics'
+
+    !- pheno_gdd_crit
+    pheno_gdd_crit(:,1) = pheno_gdd_crit_c(:)
+    pheno_gdd_crit(:,2) = pheno_gdd_crit_b(:)         
+    pheno_gdd_crit(:,3) = pheno_gdd_crit_a(:) 
+    !
+    !- senescence_temp
+    senescence_temp(:,1) = senescence_temp_c(:)
+    senescence_temp(:,2) = senescence_temp_b(:)
+    senescence_temp(:,3) = senescence_temp_a(:)
+    !
+    !- maint_resp_slope
+    maint_resp_slope(:,1) = maint_resp_slope_c(:)              
+    maint_resp_slope(:,2) = maint_resp_slope_b(:)
+    maint_resp_slope(:,3) = maint_resp_slope_a(:)
+    !
+    !-coeff_maint_zero
+    coeff_maint_zero(:,ileaf) = cm_zero_leaf(:)
+    coeff_maint_zero(:,isapabove) = cm_zero_sapabove(:)
+    coeff_maint_zero(:,isapbelow) = cm_zero_sapbelow(:)
+    coeff_maint_zero(:,iheartabove) = cm_zero_heartabove(:)
+    coeff_maint_zero(:,iheartbelow) = cm_zero_heartbelow(:)
+    coeff_maint_zero(:,iroot) = cm_zero_root(:)
+    coeff_maint_zero(:,ifruit) = cm_zero_fruit(:)
+    coeff_maint_zero(:,icarbres) = cm_zero_carbres(:)
+    coeff_maint_zero(:,ilabile) = cm_zero_labile(:)
+    
+    !-Allocate parameter based variables for functional allocation
+    l_error = .FALSE.
+
+    ALLOCATE(latosa_height(nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for latosa_height. We stop. We need nvm words = ',nvm
+       STOP 'latosa_height'
+    ENDIF
+
+    ALLOCATE(latosa_ind(nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    IF (l_error) THEN
+       WRITE(numout,*) ' Memory allocation error for latosa_ind. We stop. We need nvm words = ',nvm
+       STOP 'latosa_ind'
+    ENDIF
+
+    IF ( bavard .GE. 1 ) WRITE(numout,*) 'data: PFT characteristics'
+
+    DO j = 2,nvm ! Loop over # PFTS 
+
+       IF ( bavard .GE. 1 ) WRITE(numout,'(a,i3,a,a)') '    > PFT#',j,': ', PFT_name(j)
+
+       !
+       ! 1 tree? (true/false)
+       !
+       IF ( bavard .GE. 1 ) WRITE(numout,*) '       tree: (::is_tree) ', is_tree(j)
+
+       !
+       ! 2 flamability (0-1, unitless)
+       !
+
+       IF ( bavard .GE. 1 ) WRITE(numout,*) '       litter flamability (::flam) :', flam(j)
+
+       !
+       ! 3 fire resistance (unitless)
+       !
+
+       IF ( bavard .GE. 1 ) WRITE(numout,*) '       fire resistance (::resist) :', resist(j)
+
+       !
+       ! 4 specific leaf area per mass carbon = 2 * sla / dry mass (m^2.gC^{-1})
+       !
+
+       ! 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))
+
+       ! Oct 2010 : sla values are prescribed by values given by N.Viovy 
+
+       ! includes conversion from 
+       !!       sla(j) = 2. * 1e-4 * EXP(5.615 - 0.46 * log(12./leaflife_tab(j)))
+       !!\latexonly
+       !!\input{stomate_data_SLA.tex}
+       !!\endlatexonly
+!       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
+
+
+       !+++CHECK+++
+       ! The variable name management is no longer used in sapiens_forestry - but check!
+       ! Either implement a varying sla for all PFT or for none.
+       !DS! New formula for calculation for sla of PFT 6 . Should keep the imposed values of sla ?
+       ! From Cafapietra 2005, average
+!!$       IF ( (management == 4) .AND. .NOT.(is_needleleaf(j)) .AND. (is_temperate(j)) ) &
+!!$            sla(j) = 171.5/260. * 2. * ( 10. ** ( 2.41 - 0.38 * LOG10(12.*tau_leaf(j)/one_year) ) ) *1e-4
+!!$
+!!$       IF ( bavard .GE. 1 ) WRITE(numout,*) '       specific leaf area (m**2/gC) (::sla):', sla(j), 12.*tau_leaf(j)/one_year
+       !+++++++++++
+  
+
+       !
+       ! 5 sapling characteristics
+       !
+       
+       ! 5.1 carbon
+       
+       !calculated leaf to sapwood area ratio from hydraulic architecture or use default value
+       IF ( control%ok_functional_allocation ) THEN
+
+          IF ( is_tree(j) ) THEN
+
+             !+++NOTE+++
+             ! In the final implementation KF is a function of veget which in the
+             ! DOFOCO branch means it is function of light competition. The
+             ! parameters below are no longer needed but were left in the code
+             ! to ensure others can learn from these trials
+
+             ! The ratio of leaf area to spawood area (::k_latosa) is a function of
+             ! tree height (McDowell et al 2002, Novick et al. 2009). However the slope
+             ! of this relationship is not well established so here we recalculate it
+             ! using the tree height of a tree with a diameter of 0.5 m. k_latosa_max
+             ! is based on the literature. k_latosa_min is a fixed fraction of
+             ! k_latosa_max. The range of observed values is huge and are especially
+             ! noisy likely due to space for time substitution. The model is exteremely
+             ! sensitive to the parameter k_latosa.
+             !!$  latosa_height(j) = (k_latosa_max(j) - (k_latosa_min(j))) / &
+             !!$     (pipe_tune2(j)*0.5**pipe_tune3(j))
+
+             ! This implementation results in the wrong behavior: LAI starts to decrease 
+             ! to the point where there are not enough leaves to produce sufficient 
+             ! photosynthates to grow leaves. Either the  observations are problematic
+             ! (space for time substitution) or the model lacks a dynamic response in
+             ! for example, Vcmax, k_leaf, ... It is well established that after a 
+             ! thinning the LAI recovers quite fast so as an alternative to the height 
+             ! dependency we implemented a density dependency. Note that k_latosa was
+             ! made to increase with decreasing density (thus the opposite of the effect 
+             ! with height). 
+             !!$  latosa_ind(j) = (k_latosa_max(j) - k_latosa_min(j)) / (9500 * ha_to_m2)
+
+             ! This approach requires new parameters (i.e. 9500) and results in a bumpy
+             ! increase in LAI. Also maximum LAI is only reached after 40 to 50 years.
+             ! Neverthless adding this depency allows the leaf mass to (partly) 
+             ! recover.
+             !++++++++++
+
+          ELSE ! grasses
+
+          ENDIF ! Trees or grasses
+
+       ! resource limitation model (stomate_alloc)
+       ELSE 
+ 
+          IF ( is_tree(j) ) THEN
+             
+             ! Use parameter values as defined in constants.f90
+             alpha = alpha_tree
+
+             IF ( bavard .GE. 1 ) WRITE(numout,*) '       leaf to sapwood area ratio :', pipe_k1(j)
+             
+             !! Original ORCHIDEE formulation
+             !! \latexonly
+             !! \input{stomate_data_sapl_tree.tex}
+             !! \endlatexonly  
+             bm_sapl_old(j,ileaf,icarbon) = &
+               &     ( ( bm_sapl_leaf(1) * pipe_tune1(j) * ( mass_ratio_heart_sap(j) * bm_sapl_leaf(2) * sla(j) / &
+               &     ( pi * pipe_k1(j) ) ) ** bm_sapl_leaf(3) ) / sla(j) ) ** bm_sapl_leaf(4)
+
+                 
+             IF ( pheno_type(j) .NE. 1 ) THEN
+
+                ! not evergreen
+                bm_sapl_old(j,icarbres,icarbon) = bm_sapl_carbres * bm_sapl_old(j,ileaf,icarbon)
+
+             ELSE
+
+                bm_sapl_old(j,icarbres,icarbon) = zero
+
+             ENDIF ! (pheno_type(j) .NE. 1 )  
+             
+             ! Crown specific area of a sapling (crown area of an individual sapling (m^{2} ind^{-1})
+             ! Given that ::bm_sapl_old is a function of ::sla, ::csa_sap will be identical across all PFTs
+             csa_sap = bm_sapl_old(j,ileaf,icarbon) / ( pipe_k1(j) / sla(j) )   
+  
+             ! Original ORCHIDEE formulation
+             ! dia = ( heartwood_sapwood * csa_sap * 4. / pi ) ** 0.5
+          
+             ! Alternative LPJ formulation
+             dia = ( mass_ratio_heart_sap(j) * csa_sap * dia_coeff(1) / pi ) ** dia_coeff(2)
+
+             ! Sapwood and heartwood mass
+             bm_sapl_old(j,isapabove,icarbon) = bm_sapl_sapabove * pipe_density(j) * &
+                 csa_sap * pipe_tune2(j) * dia ** pipe_tune3(j)
+             bm_sapl_old(j,isapbelow,icarbon) = bm_sapl_old(j,isapabove,icarbon)
+             
+             ! SZ The original LPJ version uses 0.2, not 2 as mentioned in the
+             ! 1.9.5.2 version of ORCHIDEE
+             bm_sapl_old(j,iheartabove,icarbon) = bm_sapl_heartabove * bm_sapl_old(j,isapabove,icarbon)
+             bm_sapl_old(j,iheartbelow,icarbon) = bm_sapl_heartbelow * bm_sapl_old(j,isapbelow,icarbon)
+
+          ELSE ! grasses
+
+             !!\latexonly
+             !!\input{stomate_data_sapl_grass.tex}
+             !!\endlatexonly
+
+             alpha = alpha_grass
+
+             IF ( natural(j) ) THEN
+
+                bm_sapl_old(j,ileaf,icarbon) = init_sapl_mass_leaf_nat / sla(j)
+
+             ELSE
+
+                bm_sapl_old(j,ileaf,icarbon) = init_sapl_mass_leaf_agri / sla(j)
+
+             ENDIF
+
+             bm_sapl_old(j,icarbres,icarbon) = init_sapl_mass_carbres * bm_sapl_old(j,ileaf,icarbon)
+
+             bm_sapl_old(j,isapabove,icarbon) = zero
+             bm_sapl_old(j,isapbelow,icarbon) = zero
+
+             bm_sapl_old(j,iheartabove,icarbon) = zero
+             bm_sapl_old(j,iheartbelow,icarbon) = zero
+
+          ENDIF !Trees or grasses
+
+          ! SZ The original LPJ version uses 1*ltor_max
+          bm_sapl_old(j,iroot,icarbon) = init_sapl_mass_root * (1./alpha) * bm_sapl_old(j,ileaf,icarbon)
+          bm_sapl_old(j,ifruit,icarbon) = init_sapl_mass_fruit  * bm_sapl_old(j,ileaf,icarbon)
+          bm_sapl_old(j,ilabile,icarbon) = zero
+
+          !+++OCN+++
+          ! bm_sapl_old(j,ilabile,icarbon) = 0.1
+          !+++++++++
+
+          IF ( bavard .GE. 1 ) THEN
+             WRITE(numout,*) '       sapling biomass (gC):'
+             WRITE(numout,*) '         leaves: (::bm_sapl_old(j,ileaf,icarbon))',bm_sapl_old(j,ileaf,icarbon)
+             WRITE(numout,*) '         sap above ground: (::bm_sapl_old(j,ispabove,icarbon)):',&
+                  bm_sapl_old(j,isapabove,icarbon)
+             WRITE(numout,*) '         sap below ground: (::bm_sapl_old(j,isapbelow,icarbon))',&
+                  bm_sapl_old(j,isapbelow,icarbon)
+             WRITE(numout,*) '         heartwood above ground: (::bm_sapl_old(j,iheartabove,icarbon))',&
+                  bm_sapl_old(j,iheartabove,icarbon)
+             WRITE(numout,*) '         heartwood below ground: (::bm_sapl_old(j,iheartbelow,icarbon))',&
+                  bm_sapl_old(j,iheartbelow,icarbon)
+             WRITE(numout,*) '         roots: (::bm_sapl_old(j,iroot,icarbon))',bm_sapl_old(j,iroot,icarbon)
+             WRITE(numout,*) '         fruits: (::bm_sapl_old(j,ifruit,icarbon))',bm_sapl_old(j,ifruit,icarbon)
+             WRITE(numout,*) '         carbohydrate reserve: (::bm_sapl_old(j,icarbres,icarbon))',&
+                  bm_sapl_old(j,icarbres,icarbon)
+             WRITE(numout,*) '         labile reserve: (::bm_sapl_old(j,ilabile,icarbon))',bm_sapl_old(j,ilabile,icarbon)
+          ENDIF !( bavard .GE. 1 ) 
+
+      ENDIF !control%ok_functional_allocation
+
+
+
+
+       !
+       ! 6 migration speed (m/year)
+       !
+
+       IF ( is_tree(j) ) THEN
+
+          migrate(j) = migrate_tree
+
+       ELSE
+
+          ! can be any value as grasses are, per *definition*, everywhere (big leaf).
+          migrate(j) = migrate_grass
+
+       ENDIF !( is_tree(j) )
+
+       IF ( bavard .GE. 1 ) WRITE(numout,*) '       migration speed (m/year): (::migrate(j))', migrate(j)
+
+       !
+       ! 7 critical stem diameter: beyond this diameter, the crown area no longer
+       !     increases (m)
+       !
+
+       IF ( is_tree(j) ) THEN
+
+          !!\latexonly
+          !!\input{stomate_data_stem_diameter.tex}
+          !!\endlatexonly
+
+          maxdia(j) = ( ( pipe_tune4(j) / ((pipe_tune2(j)*pipe_tune3(j))/(maxdia_coeff(1)**pipe_tune3(j))) ) &
+               ** ( un / ( pipe_tune3(j) - un ) ) ) * maxdia_coeff(2)
+          !not in OCN
+          !cn_sapl(j) = cn_sapl_init !crown of individual tree, first year
+
+       ELSE
+
+          maxdia(j) = undef
+          !not in OCN
+          !cn_sapl(j)=1
+
+       ENDIF !( is_tree(j) )
+
+       IF ( bavard .GE. 1 ) WRITE(numout,*) '       critical stem diameter (m): (::maxdia(j))', maxdia(j)
+
+       !
+       ! 8 Coldest tolerable temperature (K)
+       !
+
+       IF ( ABS( tmin_crit(j) - undef ) .GT. min_stomate ) THEN
+          tmin_crit(j) = tmin_crit(j) + ZeroCelsius
+       ELSE
+          tmin_crit(j) = undef
+       ENDIF 
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       coldest tolerable temperature (K): (::tmin_crit(j))', 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 *(vernalization)* (K)
+       !
+
+       IF ( ABS ( tcm_crit(j) - undef ) .GT. min_stomate ) THEN
+          tcm_crit(j) = tcm_crit(j) + ZeroCelsius
+       ELSE
+          tcm_crit(j) = undef
+       ENDIF
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       vernalization temperature (K): (::tcm_crit(j))', tcm_crit(j)
+
+       !
+       ! 10 critical values for phenology
+       !
+
+       ! 10.1 model used
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       phenology model used: (::pheno_model(j)) ',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.
+
+
+       IF ( ( bavard .GE. 1 ) .AND. ( ALL(pheno_gdd_crit(j,:) .NE. undef) ) ) THEN
+          WRITE(numout,*) '         critical GDD is a function of long term T (C): (::gdd)'
+          WRITE(numout,*) '          ',pheno_gdd_crit(j,1), &
+               ' + T *',pheno_gdd_crit(j,2), &
+               ' + T^2 *',pheno_gdd_crit(j,3)
+       ENDIF
+
+       ! consistency check
+
+       IF ( ( ( pheno_model(j) .EQ. 'moigdd' ) .OR. &
+            ( pheno_model(j) .EQ. 'humgdd' )       ) .AND. &
+            ( ANY(pheno_gdd_crit(j,:) .EQ. undef) )                      ) THEN
+          STOP 'problem with phenology parameters, critical GDD. (::pheno_model)'
+       ENDIF
+
+       ! 10.3 number of growing days
+
+       IF ( ( bavard .GE. 1 ) .AND. ( ngd_crit(j) .NE. undef ) ) &
+            WRITE(numout,*) '         critical NGD: (::ngd_crit(j))', ngd_crit(j)
+
+       ! 10.4 critical temperature for ncd vs. gdd function in phenology (C)
+
+       IF ( ( bavard .GE. 1 ) .AND. ( ncdgdd_temp(j) .NE. undef ) ) &
+            WRITE(numout,*) '         critical temperature for NCD vs. GDD (C): (::ncdgdd_temp(j))', &
+            ncdgdd_temp(j)
+
+       ! 10.5 humidity fractions (0-1, unitless)
+
+       IF ( ( bavard .GE. 1 ) .AND. ( hum_frac(j) .NE. undef ) ) &
+            WRITE(numout,*) '         critical humidity fraction: (::hum_frac(j))', &
+            &  hum_frac(j)
+
+
+       ! 10.6 minimum time elapsed since moisture minimum (days)
+
+       IF ( ( bavard .GE. 1 ) .AND. ( hum_min_time(j) .NE. undef ) ) &
+            WRITE(numout,*) '         time to wait after moisture min (d): (::hum_min_time(j))', &
+        &    hum_min_time(j)
+
+       !
+       ! 11 critical values for senescence
+       !
+
+       ! 11.1 type of senescence
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       type of senescence: (::senescence_type(j))',senescence_type(j)
+
+       ! 11.2 critical temperature for senescence (C)
+
+       IF ( ( bavard .GE. 1 ) .AND. ( ALL(senescence_temp(j,:) .NE. undef) ) ) THEN
+          WRITE(numout,*) '         critical temperature for senescence (C) is'
+          WRITE(numout,*) '          a function of long term T (C): (::senescence_temp)'
+          WRITE(numout,*) '          ',senescence_temp(j,1), &
+               ' + T *',senescence_temp(j,2), &
+               ' + T^2 *',senescence_temp(j,3)
+       ENDIF
+
+       ! consistency check
+
+       IF ( ( ( senescence_type(j) .EQ. 'cold' ) .OR. &
+            ( senescence_type(j) .EQ. 'mixed' )      ) .AND. &
+            ( ANY(senescence_temp(j,:) .EQ. undef ) )           ) THEN
+          STOP 'problem with senescence parameters, temperature. (::senescence_type)'
+       ENDIF
+
+       ! 11.3 critical relative moisture availability for senescence
+
+       IF ( ( bavard .GE. 1 ) .AND. ( senescence_hum(j) .NE. undef ) ) &
+            WRITE(numout,*)  ' max. critical relative moisture availability for' 
+            WRITE(numout,*)  ' senescence: (::senescence_hum(j))',  &
+            & senescence_hum(j)
+
+       ! consistency check
+
+       IF ( ( ( senescence_type(j) .EQ. 'dry' ) .OR. &
+            ( senescence_type(j) .EQ. 'mixed' )     ) .AND. &
+            ( senescence_hum(j) .EQ. undef )                   ) THEN
+          STOP 'problem with senescence parameters, humidity.(::senescence_type)'
+       ENDIF
+
+       ! 14.3 relative moisture availability above which there is no moisture-related
+       !      senescence (0-1, unitless)
+
+       IF ( ( bavard .GE. 1 ) .AND. ( nosenescence_hum(j) .NE. undef ) ) &
+            WRITE(numout,*) '         relative moisture availability above which there is' 
+            WRITE(numout,*) '             no moisture-related senescence: (::nosenescence_hum(j))', &
+            &  nosenescence_hum(j)
+
+       ! consistency check
+
+       IF ( ( ( senescence_type(j) .EQ. 'dry' ) .OR. &
+            ( senescence_type(j) .EQ. 'mixed' )     ) .AND. &
+            ( nosenescence_hum(j) .EQ. undef )                   ) THEN
+          STOP 'problem with senescence parameters, humidity. (::senescence_type)'
+       ENDIF
+
+       !
+       ! 12 sapwood -> heartwood conversion time (days)
+       !
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       sapwood -> heartwood conversion time (d): (::tau_sap(j))', tau_sap(j)
+
+       !
+       ! 13 fruit lifetime (days)
+       !
+
+       IF ( bavard .GE. 1 ) WRITE(numout,*) '       fruit lifetime (d): (::tau_fruit(j))', tau_fruit(j)
+
+       !
+       ! 14 length of leaf death (days)
+       !      For evergreen trees, this variable determines the lifetime of the leaves.
+       !      Note that it is different from the value given in tau_leaf.
+       !
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       length of leaf death (d): (::leaffall(j))', leaffall(j)
+
+       !
+       ! 15 maximum lifetime of leaves (days)
+       !
+
+       IF ( ( bavard .GE. 1 ) .AND. ( tau_leaf(j) .NE. undef ) ) &
+            WRITE(numout,*) '       critical leaf age (d): (::tau_leaf(j))', tau_leaf(j)
+
+       !
+       ! 16 time constant for leaf age discretisation (days)
+       !
+
+       leaf_timecst(j) = tau_leaf(j) / REAL( nleafages,r_std )
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       time constant for leaf age discretisation (d): (::leaf_timecst(j))', &
+            leaf_timecst(j)
+
+       !
+       ! 17 minimum lai, initial (m^2.m^{-2})
+       !
+
+       IF ( is_tree(j) ) THEN
+          lai_initmin(j) = lai_initmin_tree
+       ELSE
+          lai_initmin(j) = lai_initmin_grass
+       ENDIF !( is_tree(j) )
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       initial LAI: (::lai_initmin(j))', lai_initmin(j)
+
+       !
+       ! 19 maximum LAI (m^2.m^{-2})
+       !
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       critical LAI above which no leaf allocation: (::lai_max(j))', lai_max(j)
+
+       !
+       ! 20 fraction of primary leaf and root allocation put into reserve (0-1, unitless)
+       !
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       reserve allocation factor: (::ecureuil(j))', ecureuil(j)
+
+       !
+       ! 21 maintenance respiration coefficient (g/g/day) at 0 deg C
+       !
+
+
+       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))',coeff_maint_zero(j,ileaf)
+          WRITE(numout,*) '         . sapwood above ground: (::coeff_maint_zero(j,isapabove)) ',&
+                        & coeff_maint_zero(j,isapabove)
+          WRITE(numout,*) '         . sapwood below ground: (::coeff_maint_zero(j,isapbelow))  ',&
+                       & coeff_maint_zero(j,isapbelow)
+          WRITE(numout,*) '         . heartwood above ground: (::coeff_maint_zero(j,iheartabove)) ',&
+                       & coeff_maint_zero(j,iheartabove)
+          WRITE(numout,*) '         . heartwood below ground: (::coeff_maint_zero(j,iheartbelow)) ',&
+                       & coeff_maint_zero(j,iheartbelow)
+          WRITE(numout,*) '         . roots: (::coeff_maint_zero(j,iroot))',coeff_maint_zero(j,iroot)
+          WRITE(numout,*) '         . fruits: (::coeff_maint_zero(j,ifruit)) ',coeff_maint_zero(j,ifruit)
+          WRITE(numout,*) '         . carbohydrate reserve: (::coeff_maint_zero(j,icarbres)) ',&
+                       & coeff_maint_zero(j,icarbres)
+          WRITE(numout,*) '         . labile pool (::coeff_maint_zero(j,ilabile)) ', &
+                       & coeff_maint_zero(j,ilabile)
+          
+
+       ENDIF !( bavard .GE. 1 )
+
+       !
+       ! 22 parameter for temperature sensitivity of maintenance respiration
+       !
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       temperature sensitivity of maintenance respiration (1/K) is'
+       WRITE(numout,*) '          a function of long term T (C): (::maint_resp_slope)'
+       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))', natural(j)
+
+       !
+       ! 24 Vcmax  (umol.m^{-2}.s^{-1}) 
+       !
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       Maximum rate of carboxylation:(::Vcmax25(j))', Vcmax25(j)
+
+
+       !
+       ! 25 constants for photosynthesis temperatures
+       !
+
+
+       IF ( bavard .GE. 1 ) THEN
+          WRITE(numout,*) '       min. temperature for photosynthesis as a function of long term T (C):'
+          WRITE(numout,*) '       (::tphoto_min_c(j))'
+          WRITE(numout,*) '          ',tphoto_min_c(j), &
+               ' + T*',tphoto_min_b(j), &
+               ' + T^2*',tphoto_min_a(j)
+          WRITE(numout,*) '       opt. temperature for photosynthesis as a function of long term T (C):' 
+          WRITE(numout,*) '       (::tphoto_opt_c(j))'
+          WRITE(numout,*) '          ',tphoto_opt_c(j), &
+               ' + T*',tphoto_opt_b(j), &
+               ' + T^2*',tphoto_opt_a(j)
+          WRITE(numout,*) '       max. temperature for photosynthesis as a function of long term T (C):' 
+          WRITE(numout,*)'        (::tphoto_max_c(j))'
+          WRITE(numout,*) '          ',tphoto_max_c(j), &
+               ' + T*',tphoto_max_b(j), &
+               ' + T^2*',tphoto_max_a(j)
+
+
+          !
+          ! 26 Properties
+          !
+
+          WRITE(numout,*) '       C4 photosynthesis: (::is_c4(j))', is_c4(j)
+          WRITE(numout,*) '       Depth constant for root profile (m): (::1./humcste(j))', 1./humcste(j)
+
+       ENDIF !( bavard .GE. 1 ) 
+
+       !
+       ! 27 extinction coefficient of the Monsi and Saeki (1953) relationship 
+       !
+       IF ( bavard .GE. 1 ) THEN
+          WRITE(numout,*) '       extinction coefficient: (::ext_coeff(j))', ext_coeff(j)
+       ENDIF !( bavard .GE. 1 )
+
+    ENDDO ! Loop over # PFTS 
+
+    !
+    ! 29 time scales for phenology and other processes (in days)
+    !
+
+    tau_longterm = coeff_tau_longterm * one_year
+
+    IF ( bavard .GE. 1 ) THEN
+
+       WRITE(numout,*) '   > time scale for ''monthly'' moisture availability (d): (::tau_hum_month)', &
+            tau_hum_month
+       WRITE(numout,*) '   > time scale for ''weekly'' moisture availability (d): (::tau_hum_week)', &
+           tau_hum_week
+       WRITE(numout,*) '   > time scale for ''monthly'' 2 meter temperature (d): (::tau_t2m_month)', &
+            tau_t2m_month
+       WRITE(numout,*) '   > time scale for ''weekly'' 2 meter temperature (d): (::tau_t2m_week)', &
+            tau_t2m_week
+       WRITE(numout,*) '   > time scale for ''weekly'' GPP (d): (::tau_gpp_week)', &
+            tau_gpp_week
+       WRITE(numout,*) '   > time scale for ''monthly'' soil temperature (d): (::tau_tsoil_month)', &
+            tau_tsoil_month
+       WRITE(numout,*) '   > time scale for ''monthly'' soil humidity (d): (::tau_soilhum_month)', &
+            tau_soilhum_month
+       WRITE(numout,*) '   > time scale for vigour calculations (y): (::tau_longterm / one_year)', &
+            tau_longterm / one_year
+
+    ENDIF !( bavard .GE. 1 ) 
+
+    !
+    ! 30 fraction of allocatable biomass which is lost as growth respiration (0-1, unitless)
+    !
+
+    IF ( bavard .GE. 1 ) &
+         WRITE(numout,*) '   > growth respiration fraction: (::frac_growthresp)', frac_growthresp
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving data'
+
+  END SUBROUTINE data
+
+END MODULE stomate_data
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_growth_fun_all.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_growth_fun_all.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_growth_fun_all.f90	(revision 7236)
@@ -0,0 +1,5523 @@
+!=================================================================================================================================
+! MODULE       : stomate_growth_fun_all
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+!                This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         Plant growth and C-allocation among the biomass components (leaves, wood, roots, fruit, reserves, labile) 
+!!               is calculated making use of functional allocation which combines the pipe model and allometric relationships 
+!!               proposed by Sitch et al 2003 and adjusted by Zaehle et al 2010.
+!!
+!!\n DESCRIPTION: This module calculates three processes: (1) daily maintenance respiration based on the half-hourly
+!!               respiration calculated in stomate_resp.f90, (2) the absolute allocation to the different biomass
+!!               components based on functional allocation approach and (3) the allocatable biomass as the residual
+!!               of GPP-Ra. Multiplication of the allocation fractions and allocatable biomass given the changes in
+!!               biomass pools.
+!!
+!! RECENT CHANGE(S): Until 1.9.6 only one allocation scheme was available (now contained in stomate_grwoth_res_lim.f90). 
+!!               This module consists of an alternative formalization of plant growth.
+!!                             
+!! REFERENCE(S)	: - Sitch, S., Smith, B., Prentice, I.C., Arneth, A., Bondeau, A., Cramer, W.,
+!!               Kaplan, J.O., Levis, S., Lucht, W., Sykes, M.T., Thonicke, K., Venevsky, S. (2003), Evaluation of 
+!!               ecosystem dynamics, plant geography and terrestrial carbon cycling in the LPJ Dynamic Global Vegetation 
+!!               Model, Global Change Biology, 9, 161-185.\n 
+!!               - Zaehle, S. and Friend, A.D. (2010), Carbon and nitrogen cycle dynamics in the O-CN land surface model: 1. 
+!!               Model description, site-scale evaluation, and sensitivity to parameter estimates, Global Biogeochemical 
+!!               Cycles, 24, GB1005.\n
+!!               - Magnani F., Mencuccini M. & Grace J. 2000. Age-related decline in stand productivity: the role of 
+!!               structural acclimation under hydraulic constraints Plant, Cell and Environment 23, 251â263.\n
+!!               - Bloom A.J., Chapin F.S. & Mooney H.A. (1985) Resource limitation in plants. An economic analogy.  
+!!               Annual Review Ecology Systematics 16, 363â392.\n
+!!               - Case K.E. & Fair R.C. (1989) Principles of Economics. Prentice Hall, London.\n
+!!               - McDowell, N., Barnard, H., Bond, B.J., Hinckley, T., Hubbard, R.M., Ishii, H., KÃ¶stner, B., 
+!!               Magnani, F. Marshall, J.D., Meinzer, F.C., Phillips, N., Ryan, M.G., Whitehead D. 2002. The 
+!!               relationship between tree height and leaf area: sapwood area ratio. Oecologia, 132:12â20.\n
+!!               - Novick, K., Oren, R., Stoy, P., Juang, F.-Y., Siqueira, M., Katul, G. 2009. The relationship between
+!!               reference canopy conductance and simplified hydraulic architecture. Advances in water resources 32,
+!!               809-819.     
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ===============================================================================================================================
+MODULE stomate_growth_fun_all
+
+  ! Modules used:
+  USE ioipsl_para
+  USE pft_parameters
+  USE stomate_data
+  USE constantes
+  USE constantes_soil
+  USE function_library,    ONLY: wood_to_qmdia, wood_to_qmheight, wood_to_ba_eff, biomass_to_lai,&
+                                 calculate_c0_alloc, wood_to_volume, wood_to_ba
+
+  IMPLICIT NONE
+
+  ! Private & public routines
+
+  PRIVATE
+  PUBLIC growth_fun_all_clear, growth_fun_all
+
+ ! Variables shared by all subroutines in this module
+
+  LOGICAL, SAVE                                             :: firstcall = .TRUE.  !! Is this the first call? (true/false)
+ 
+!!$  !+++TEMP+++
+!!$  INTEGER, SAVE                                             :: istep = 0
+
+CONTAINS
+
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : growth_fun_all_clear
+!!
+!>\BRIEF          Set the flag ::firstcall to .TRUE. and as such activate section 
+!! 1.1 of the subroutine alloc (see below).\n
+!!
+!_ ================================================================================================================================
+
+  SUBROUTINE growth_fun_all_clear
+    firstcall = .TRUE.
+  END SUBROUTINE growth_fun_all_clear
+
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: growth_fun_all
+!!
+!>\BRIEF          Allocate net primary production (= photosynthesis
+!!                minus autothrophic respiration) to: labile carbon pool carbon reserves, aboveground sapwood,
+!!                belowground sapwood, root, fruits and leaves following the pipe model and allometric constraints.
+!!
+!! DESCRIPTION  : Total maintenance respiration for the whole plant is calculated by summing maintenance 
+!!                respiration of the different plant compartments. Maintenance respiration is subtracted 
+!!                from whole-plant allocatable biomass (up to a maximum fraction of the total allocatable biomass). 
+!!                Growth respiration is then calculated as a prescribed (0.75) fraction of the allocatable
+!!                biomass. Subsequently NPP is calculated by substracting total autotrophic  respiration from GPP 
+!!                i.e. NPP = GPP - maintenance resp - growth resp.
+!!
+!!                The pipe model assumes that one unit of leaf mass requires a proportional amount of sapwood to 
+!!                transport water from the roots to the leaves. Also a proportional fraction of roots is needed to 
+!!                take up the water from the soil. The proportional amounts between leaves, sapwood and roots are 
+!!                given by allocation factors. These allocation factors are PFT specific and depend on a parameter 
+!!                quantifying the leaf to sapwood area (::k_latosa_target), the specific laeaf area (::sla), wood 
+!!                density (::pipe_density) and a scaling parameter between leaf and root mass.
+!! 
+!!                Lai is optimised for mean annual radiation use efficiency and the C cost for producing the 
+!!                canopy. The cost-benefit ratio is optimised when the marginal gain / marginal cost = 1 lai target 
+!!                is used to calculate whether the reserves are used. This approach allows plants to get out of 
+!!                senescence and to start developping a canopy in early spring. 
+!!                  
+!!                As soon as a canopy has emerged, C (b_inc_tot) becomes available at the stand level through 
+!!                photosynthesis and, C is allocated at the tree level (b_inc) following both the pipe model and 
+!!                allometric constraints. Mass conservation requires:
+!!                (1) Cs_inc + Cr_inc + Cl_inc = b_inc
+!!                (2) sum(b_inc) = b_inc_tot
+!!
+!!                Wood allocation depends on tree basal area following the rule of Deleuze & Dhote
+!!                delta_ba = gammas*(circ - m*sigmas + sqrt((m*sigmas + circ).^2 - (4*sigmas*circ)))/2
+!!                (3) <=> delta_ba = circ_class_dba*gammas
+!!                Where circ_class_dba = (circ - m*sigmas + sqrt((m*sigmas + circ).^2 - (4*sigmas*circ)))/2
+!! 
+!!                Allometric relationships
+!!                height = pipe_tune2*(dia.^pipe_tune3)
+!!                Re-write this relationship as a function of ba 
+!!                (4) height = pipe_tune2 * (4/pi*ba)^(pipe_tune3/2)
+!!                (5a) Cl/Cs = KF/height for trees
+!!                (5b) Cs = Cl / KF
+!!                (6) Cl = Cr * LF
+!!
+!!                Use a linear approximation to avoid iterations. Given that allocation is calculated daily, a 
+!!                local lineair assumption is fair. Eq (4) can thus be rewritten as:
+!!                s = step/(pipe_tune2*(4/pi*(ba+step)).^(pipe_tune3/2)-pipe_tune2*(4/pi*ba).^(pipe_tune3/2))
+!!                Where step is a small but realistic (for the time step) change in ba
+!!                (7)  <=> delta_height = delta_ba/s
+!!
+!!                Calculate Cs_inc from allometric relationships
+!!                Cs_inc = tree_ff*pipe_density*(ba+delta_ba)*(height+delta_height) - Cs - Ch         
+!!                Cs_inc = tree_ff*pipe_density*(ba+delta_ba)*(height+delta_ba/s) - Cs - Ch
+!!                (8)  <=> Cs_inc = tree_ff*pipe_density*(ba+a*gammas)*(height+(a/s*gammas)) - Cs - Ch
+!!
+!!                Rewrite (5) as 
+!!                Cl_inc = KF*(Cs_inc+Cs)/(height+delta_height) - Cl
+!!                Substitute (7) in (4) and solve for Cl_inc
+!!                Cl_inc = KF*(tree_ff*pipe_density*(ba+circ_class_dba*gammas)*(height+(circ_class_dba/s*gammas)) - Ch)/ & 
+!!                   (height+(circ_class_dba/s*gammas)) - Cl  
+!!                (9)  <=> Cl_inc = KF*tree_ff*pipe_density*(ba+circ_class_dba*gammas) - &
+!!                            (KF*Ch)/(height+(circ_class_dba/s*gammas)) - Cl
+!!
+!!                Rewrite (6) as 
+!!                Cr_inc = (Cl_inc+Cl)/LF - Cr
+!!                Substitute (9) in (6)
+!!                (10)  <=> Cr_inc = KF/LF*tree_ff*pipe_density*(ba+circ_class_dba*gammas) - &
+!!                            (KF*Ch/LF)/(height+(circ_class_dba/s*gammas)) - Cr
+!!
+!!                Depending on the specific case that needs to be solved equations (1) takes one of the following forms:
+!!                (a) b_inc = Cl_inc + Cr_inc + Cs_inc, (b) b_inc = Cl_inc + Cr_inc, (c) b_inc = Cl_inc + Cs_inc or 
+!!                (d) b_inc = Cr_inc + Cs_inc. One of these alternative forms of eq. 1 are then combined with 
+!!                eqs 8, 9 and 10 and solved for gammas. The details for the solution of these four cases are given in the
+!!                code. Once gammas is know, eqs 6 - 10 are used to calculate the allocation to leaves (Cl_inc), 
+!!                roots (Cr_inc) and sapwood (Cs_inc).
+!!
+!!                Because of turnover, biomass pools are not all the time in balance according to rules prescribed
+!!                by the pipe model. To test whether biomass pools are balanced, the target biomasses are calculated 
+!!                and balance is restored whenever needed up to the level that the biomass pools for leaves, sapwood
+!!                and roots are balanced according to the pipe model. Once the balance is restored C is allocated to
+!!                fruits, leaves, sapwood and roots by making use of the pipe model (below this called ordinary 
+!!                allocation).
+!!
+!!                Although strictly speaking allocation factors are not necessary in this scheme (Cl_inc could simply 
+!!                be added to biomass(:,:,ileaf,icarbon), Cr_inc to biomass(:,:,iroot,icarbon), etc.), they are 
+!!                nevertheless calculated because using allocation factors facilitates comparison to the resource 
+!!                limited allocation scheme (stomate_growth_res_lim.f90) and it comes in handy for model-data comparison.
+!!
+!!                Effective basal area, height and circumferences are use in the allocation scheme because their 
+!!                calculations make use of the total (above and belowground) biomass. In forestry the same measures
+!!                exist (and they are also calculated in ORCHIDEE) but only account for the aboverground biomass.
+!! 
+!!
+!! RECENT CHANGE(S): - The code by Sonke Zaehle made use of ::Cl_target that was derived from ::lai_target which in turn 
+!!                was a function of ::rue_longterm. Cl_target was then used as a threshold value to decide whether there 
+!!                was only phenological growth (just leaves and roots) or whether there was full allometric growth to the 
+!!                leaves, roots and sapwood. This approach was inconsistent with the pipe model because full allometric 
+!!                growth can only occur if all three biomass pools are in balance. ::lai_target is no longer used as a 
+!!                criterion to switch between phenological and full allometric growth. Its use is now restricted to trigger
+!!                the use of reserves in spring. 
+!!
+!! MAIN OUTPUT VARIABLE(S): ::npp and :: biomass. Seven different biomass compartments (leaves, roots, above and 
+!!                belowground wood, carbohydrate reserves, labile and fruits).
+!!
+!! REFERENCE(S)	:- Sitch, S., Smith, B., Prentice, I.C., Arneth, A., Bondeau, A., Cramer, W.,
+!!                Kaplan, J.O., Levis, S., Lucht, W., Sykes, M.T., Thonicke, K., Venevsky, S. (2003), Evaluation of 
+!!                ecosystem dynamics, plant geography and terrestrial carbon cycling in the LPJ Dynamic Global Vegetation 
+!!                Model, Global Change Biology, 9, 161-185.\n 
+!!                - Zaehle, S. and Friend, A.D. (2010), Carbon and nitrogen cycle dynamics in the O-CN land surface model: 1. 
+!!                Model description, site-scale evaluation, and sensitivity to parameter estimates, Global Biogeochemical 
+!!                Cycles, 24, GB1005.\n
+!!                - Magnani F., Mencuccini M. & Grace J. 2000. Age-related decline in stand productivity: the role of 
+!!                structural acclimation under hydraulic constraints Plant, Cell and Environment 23, 251â263.
+!!                - Bloom A.J., Chapin F.S. & Mooney H.A. (1985) Resource limitation in plants. An economic analogy. Annual 
+!!                Review Ecology Systematics 16, 363â392.
+!!                - Case K.E. & Fair R.C. (1989) Principles of Economics. Prentice Hall, London.
+!!                - McDowell, N., Barnard, H., Bond, B.J., Hinckley, T., Hubbard, R.M., Ishii, H., KÃ¶stner, B., 
+!!                Magnani, F. Marshall, J.D., Meinzer, F.C., Phillips, N., Ryan, M.G., Whitehead D. 2002. The 
+!!                relationship between tree height and leaf area: sapwood area ratio. Oecologia, 132:12â20
+!!                - Novick, K., Oren, R., Stoy, P., Juang, F.-Y., Siqueira, M., Katul, G. 2009. The relationship between
+!!                reference canopy conductance and simplified hydraulic architecture. Advances in water resources 32,
+!!                809-819.   
+!!
+!! +++++++++++++++++++++
+!! MAKE A NEW FLOW CHART
+!! +++++++++++++++++++++
+!! FLOWCHART    : 
+!!
+!_ ================================================================================================================================
+
+  SUBROUTINE growth_fun_all (npts, dt, veget_max, veget, PFTpresent, &
+       senescence, when_growthinit, t2m, &
+       gpp_daily, gpp_week, resp_maint_part, resp_maint, &
+       resp_growth, npp, biomass, age, &
+       leaf_age, leaf_frac, use_reserve, &
+!!$       leaf_age, leaf_frac, use_reserve, t_photo_stress, &
+       lab_fac, ind, rue_longterm, circ_class_n, &
+       circ_class_biomass, KF, bm_sync, sigma, &
+       gammas, tau_eff_leaf, tau_eff_sap, tau_eff_root, &
+       k_latosa_adapt, forest_managed,moiavail_week, humrel_ddd, psi_leaf, psi_root,stem_plc, circ_class_gains, circ_class_leafgains, circ_class_sapgains)       
+
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                        :: npts                   !! Domain size - number of grid cells 
+                                                                                !! (unitless)
+    REAL(r_std), INTENT(in)                           :: dt                     !! Time step of the simulations for stomate
+                                                                                !! (days)
+    REAL(r_std), DIMENSION(:), INTENT(in)             :: t2m                    !! Temperature at 2 meter (K)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)           :: ind                    !! Number of individuals at the stand level
+                                                                                !! @tex $(m^{-2})$ @endtex     
+    REAL(r_std), DIMENSION(:,:), INTENT(in)           :: veget_max              !! PFT "Maximal" coverage fraction of a PFT 
+                                                                                !! (= ind*cn_ind) 
+                                                                                !! @tex $(m^2 m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(in)           :: veget                  !! Fraction of vegetation type including 
+                                                                                !! non-biological fraction (unitless)   
+    REAL(r_std), DIMENSION(:,:), INTENT(in)           :: when_growthinit        !! Days since beginning of growing season 
+                                                                                !! (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)           :: gpp_week               !! "weekly" (default 7-day) gross primary 
+                                                                                !! productivity 
+                                                                                !! @tex $(gC.m^{-2}dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(in)           :: rue_longterm           !! Longterm "radiation use efficicency"
+                                                                                !! calculated as the ratio of GPP over 
+                                                                                !! the fraction of radiation absorbed
+                                                                                !! by the canopy 
+                                                                                !! @tex $(gC.m^{-2}day^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(in)           :: tau_eff_root           !! Effective root turnover time that accounts
+                                                                                !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)           :: tau_eff_sap            !! Effective sapwood turnover time that accounts
+                                                                                !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)           :: tau_eff_leaf           !! Effective leaf turnover time that accounts
+                                                                                !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)         :: circ_class_n           !! Number of individuals in each circ class
+                                                                                !! @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)         :: resp_maint_part        !! Maintenance respiration of different  
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: moiavail_week                                                                                !! plant parts
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: humrel_ddd
+
+                                                                                !! @tex $(gC.m^{-2}dt^{-1})$ @endtex
+    LOGICAL, DIMENSION(:,:), INTENT(in)               :: senescence             !! Is the PFT senescent?  - only for 
+                                                                                !! deciduous trees (true/false)
+    LOGICAL, DIMENSION(:,:), INTENT(in)               :: PFTpresent             !! PFT exists (true/false)
+
+    INTEGER(i_std), DIMENSION(:,:), INTENT(in)        :: forest_managed         !! Forest management flag: 0 = orchidee 
+                                                                                !! standard, 1= self-thinning only, 2= 
+                                                                                !! high-stand, 3= high-stand smoothed, 4= 
+                                                                                !! coppices
+
+   
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(:,:), INTENT(out)          :: resp_maint             !! PFT maintenance respiration 
+                                                                                !! @tex $(gC.m^{-2}dt^{-1})$ @endtex    
+    REAL(r_std), DIMENSION(:,:), INTENT(out)          :: resp_growth            !! PFT growth respiration 
+                                                                                !! @tex $(gC.m^{-2}dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(out)          :: npp                    !! PFT net primary productivity 
+                                                                                !! @tex $(gC.m^{-2}dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(out)          :: lab_fac                !! Activity of labile pool factor (units??)
+    REAL(r_std), DIMENSION(:,:), INTENT(out)          :: sigma                  !! Threshold for indivudal tree growth in 
+                                                                                !! the equation of Deleuze & Dhote (2004)(m).
+                                                                                !! Trees whose circumference is smaller than 
+                                                                                !! sigma don't grow much
+    REAL(r_std), DIMENSION(:,:), INTENT(out)          :: gammas                  !! Slope for individual tree growth in the 
+                                                                                !! equation of Deleuze & Dhote (2004) (m)
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: gpp_daily              !! PFT gross primary productivity 
+                                                                                !! @tex $(gC.m^{-2}dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: use_reserve            !! Flag to use the reserves to support
+                                                                                !! phenological growth (0 or 1)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: age                    !! PFT age (days)
+!!$    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: t_photo_stress         !! Temperature stress on photosynthesis 
+!!$                                                                                !! (??CEXCHANGE??) (unitless, 0-1)       
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)    :: biomass                !! PFT total biomass 
+                                                                                !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)      :: leaf_age               !! PFT age of different leaf classes 
+                                                                                !! (days)
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)      :: leaf_frac              !! PFT fraction of leaves in leaf age class
+                                                                                !! (0-1, unitless)
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout)  :: circ_class_biomass     !! Biomass components of the model tree  
+                                                                                !! within a circumference class
+                                                                                !! class @tex $(g C ind^{-1})$ @endtex
+   REAL(r_std), DIMENSION(:,:,:), INTENT(out) :: circ_class_gains
+   
+    REAL(r_std), DIMENSION(:,:,:), INTENT(out) :: circ_class_leafgains
+    REAL(r_std), DIMENSION(:,:,:), INTENT(out) :: circ_class_sapgains
+     REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: KF                     !! Scaling factor to convert sapwood mass
+                                                                                !! into leaf mass (m)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: k_latosa_adapt         !! Leaf to sapwood area adapted for long 
+                                                                                !! term water stress (m)
+    REAL(r_std), DIMENSION(:,:,:),INTENT(inout)       :: bm_sync                !! The difference betweeen the
+                                                                                !! biomass in the circ_classes and
+                                                                                !! the total biomass 
+                                                                                !! @tex $(gC m^{-2})$ @endtex
+    
+    !! 0.4 Local variables
+
+    CHARACTER(30)                                     :: var_name               !! To store variable names for I/O
+    REAL(r_std), DIMENSION(npts,nvm)                  :: c0_alloc               !! Root to sapwood tradeoff parameter
+    LOGICAL                                           :: grow_wood=.TRUE.       !! Flag to grow wood
+    INTEGER(i_std)                                    :: ipts,j,k,l,m,ivm,icirc,imed!! Indeces(unitless)
+    INTEGER(i_std)                                    :: ipar, iele, imbc       !! Indeces(unitless)
+    INTEGER(i_std)                                    :: ilev                   !! Indeces(unitless)
+    REAL(r_std)                                       :: frac                   !! No idea??
+    REAL(r_std)                                       :: a,b,c                  !! Temporary variables to solve a
+                                                                                !! quadratic equation (unitless)
+    ! Stand level
+
+    REAL(r_std)                                       :: gtemp                  !! Turnover coefficient of labile C pool
+                                                                                !! (0-1??, units??)
+    REAL(r_std)                                       :: reserve_pool           !! Intentional size of the reserve pool
+                                                                                !! @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std)                                       :: labile_pool            !! Intentional size of the labile apool
+                                                                                !! @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std)                                       :: reserve_scal           !! Protection of the reserve against 
+                                                                                !! overuse (unitless)
+    REAL(r_std)                                       :: use_lab                !! Availability of labile biomass 
+                                                                                !! @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std)                                       :: use_res                !! Availability of resource biomass 
+                                                                                !! @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std)                                       :: use_max                !! Maximum use of labile and resource pool 
+                                                                                !! @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std)                                       :: leaf_meanage           !! Mean age of the leaves (days?)
+    REAL(r_std)                                       :: reserve_time           !! Maximum number of days during which 
+                                                                                !! carbohydrate reserve may be used (days)
+    REAL(r_std)                                       :: b_inc_tot              !! Carbon that needs to allocated in the
+                                                                                !! fixed number of trees (gC)
+    REAL(r_std)                                       :: b_inc_temp             !! Temporary b_inc at the stand-level
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex
+    REAL(r_std)                                       :: scal                   !! Scaling factor between average 
+                                                                                !! individual and individual plant
+                                                                                !! @tex $(plant.m^{-2})$ @endtex
+    REAL(r_std)                                       :: total_inc              !! Total biomass increase
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex
+    REAL(r_std)                                       :: KF_old                 !! Scaling factor to convert sapwood mass
+                                                                                !! into leaf mass (m) at the previous
+                                                                                !! time step
+    REAL(r_std), DIMENSION(nvm)                       :: lai_happy              !! Lai threshold below which carbohydrate 
+                                                                                !! reserve may be used 
+                                                                                !! @tex $(m^2 m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(nvm)                       :: deleuze_p              !! Percentile of trees that will receive 
+                                                                                !! photosynthates. The proxy for intra stand
+                                                                                !! competition. Depends on the management
+                                                                                !! strategy when ncirc < 6
+    REAL(r_std), DIMENSION(npts)                      :: tl                     !! Long term annual mean temperature (C)
+    REAL(r_std), DIMENSION(npts)                      :: bm_add                 !! Biomass increase 
+		                                                                !! @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts)                      :: bm_new                 !! New biomass @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std)                                       :: alloc_sap_above        !! Fraction allocated to sapwood above 
+                                                                                !! ground
+    REAL(r_std), DIMENSION(npts,nvm)                  :: residual               !! Copy of b_inc_tot after all C has been
+                                                                                !! allocated @tex $(gC.m^{-2})$ @endtex
+                                                                                !! if all went well the value should be zero
+    REAL(r_std), DIMENSION(npts,nvm)                  :: lai_target             !! Target LAI @tex $(m^{2}m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                  :: ltor                   !! Leaf to root ratio (unitless)   
+    REAL(r_std), DIMENSION(npts,nvm)                  :: lstress_fac            !! Light stress factor, based on total
+                                                                                !! transmitted light (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,nvm)                  :: k_latosa               !! Target leaf to sapwood area ratio
+    REAL(r_std), DIMENSION(npts,nvm)                  :: LF                     !! Scaling factor to convert sapwood mass
+                                                                                !! into root mass (unitless)
+    REAL(r_std), DIMENSION(npts,nvm)                  :: lm_old                 !! Variable to store leaf biomass from 
+                                                                                !! previous time step 
+                                                                                !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                  :: bm_alloc_tot           !! Allocatable biomass for the whole plant
+                                                                                !! @tex $(gC.m^{-2})$ @endtex  
+    REAL(r_std), DIMENSION(npts,nvm)                  :: leaf_mass_young        !! Leaf biomass in youngest leaf age class 
+                                                                                !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                  :: lai                    !! PFT leaf area index 
+                                                                                !! @tex $(m^2 m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                  :: qm_dia                 !! Quadratic mean diameter of the stand (m)
+    REAL(r_std), DIMENSION(npts,nvm)                  :: qm_height              !! Height of a tree with the quadratic mean
+                                                                                !! diameter (m)
+    REAL(r_std), DIMENSION(npts,nvm)                  :: ba                     !! Basal area. variable for histwrite only (m2)
+    REAL(r_std), DIMENSION(npts,nvm)                  :: wood_volume            !! wood_volume (m3 m-2)
+    REAL(r_std), DIMENSION(npts,nvm,nparts)           :: f_alloc                !! PFT fraction of NPP that is allocated to
+                                                                                !! the different components (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements) :: bm_alloc               !! PFT biomass increase, i.e. NPP per plant  
+                                                                                !! part @tex $(gC.m^{-2}dt^{-1})$ @endtex
+
+    ! Tree level	
+    REAL(r_std), DIMENSION(ncirc)                     :: step                   !! Temporary variables to solve a
+                                                                                !! quadratic equation (unitless)
+    REAL(r_std), DIMENSION(ncirc)                     :: s                      !! tree-level linear relationship between
+                                                                                !! basal area and height. This variable is
+                                                                                !! used to linearize the allocation scheme
+    REAL(r_std), DIMENSION(ncirc)                     :: Cs_inc_est             !! Initial value estimate for Cs_inc. The 
+                                                                                !! value is used to linearize the ba~height
+                                                                                !! relationship 
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                     :: Cl                     !! Individual plant, leaf compartment
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                     :: Cr                     !! Individual plant, root compartment
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                     :: Cs                     !! Individual plant, sapwood compartment
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                     :: Ch                     !! Individual plant, heartwood compartment
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                     :: Cl_inc                 !! Individual plant increase in leaf 
+                                                                                !! compartment
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(ncirc)                     :: Cr_inc                 !! Individual plant increase in root
+                                                                                !! compartment
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(ncirc)                     :: Cs_inc                 !! Individual plant increase in sapwood
+                                                                                !! compartment
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(ncirc)                     :: Cf_inc                 !! Individual plant increase in fruit
+                                                                                !! compartment
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                     :: Cl_incp                !! Phenology related individual plant 
+                                                                                !! increase in leaf compartment
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                     :: Cr_incp                !! Phenology related individual plant 
+                                                                                !! increase in leaf compartment
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                     :: Cs_incp                !! Phenology related individual plant 
+                                                                                !! increase in sapwood compartment
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                     :: Cl_target              !! Individual plant maximum leaf mass given 
+                                                                                !! its current sapwood mass
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                     :: Cr_target              !! Individual plant maximum root mass given 
+                                                                                !! its current sapwood mass
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                     :: Cs_target              !! Individual plant maximum sapwood mass 
+                                                                                !! given its current leaf mass or root mass
+                                                                                !! @tex $(gC.plant^{-1})$ @endtex     
+    REAL(r_std), DIMENSION(ncirc)                     :: delta_ba               !! Change in basal area for a unit
+                                                                                !! investment into sapwood mass (m)
+    REAL(r_std), DIMENSION(ncirc)                     :: delta_height           !! Change in height for a unit
+                                                                                !! investment into sapwood mass (m)
+    REAL(r_std), DIMENSION(ncirc)                     :: circ_class_ba          !! Basal area (forestry definition) of the model 
+                                                                                !! tree in each circ class 
+                                                                                !! @tex $(m^{2} m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(ncirc)                     :: circ_class_ba_eff      !! Effective basal area of the model tree in each
+                                                                                !! circ class @tex $(m^{2} m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(ncirc)                     :: circ_class_dba         !! Share of an individual tree in delta_ba
+                                                                                !! thus, circ_class_dba*gammas = delta_ba
+    REAL(r_std), DIMENSION(ncirc)                     :: circ_class_height_eff  !! Effective tree height calculated from allometric 
+                                                                                !! relationships (m)
+    REAL(r_std), DIMENSION(ncirc)                     :: circ_class_circ_eff    !! Effective circumference of individual trees (m)
+    REAL(r_std)                                       :: woody_biomass          !! Woody biomass. Temporary variable to 
+                                                                                !! calculate wood volume (gC m-2)
+    REAL(r_std)                                       :: temp_share             !! Temporary variable to store the share
+                                                                                !! of biomass of each circumference class
+                                                                                !! to the total biomass            
+    REAL(r_std)                                       :: temp_class_biomass     !! Biomass across parts for a single circ
+                                                                                !! class @tex $(gC m^{-2})$ @endtex
+    REAL(r_std)                                       :: temp_total_biomass     !! Biomass across parts and circ classes
+                                                                                !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc)            :: store_delta_ba         !! Store delta_ba in this variable before writing
+                                                                                !! to the output file (m). Adding this variable
+                                                                                !! was faster than changing the dimensions
+                                                                                !! of delta_ba which would have been the same
+    REAL(r_std), DIMENSION(npts,nvm,ncirc)            :: store_circ_class_ba    !! Store circ_class_ba in this variable before
+                                                                                !! writing to the output file (m). Adding this
+                                                                                !! variable was faster than changing the 
+                                                                                !! dimensions of circ_class_ba_ba which would 
+                                                                                !! have been the same
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements):: check_intern           !! Contains the components of the internal
+                                                                                !! mass balance chech for this routine
+                                                                                !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)        :: closure_intern         !! Check closure of internal mass balance
+                                                                                !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)        :: pool_start, pool_end   !! Start and end pool of this routine 
+                                                                                !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std)                                       :: median_circ            !! Median circumference (m)
+    REAL(r_std)                                       :: deficit                !! Carbon that needs to be respired in 
+                                                                                !! excess of todays gpp  
+                                                                                !! @tex $(gC.m^{-2}dt^{-1})$ @endtex
+    REAL(r_std)                                       :: excess                 !! Carbon that needs to be re-allocated
+                                                                                !! after the needs of the reserve and 
+                                                                                !! labile pool are satisfied  
+                                                                                !! @tex $(gC.m^{-2}dt^{-1})$ @endtex
+    REAL(r_std)                                       :: shortage               !! Shortage in the reserves that needs to 
+                                                                                !! be re-allocated after to minimise the
+                                                                                !! tension between required and available
+                                                                                !! reserves
+                                                                                !! @tex $(gC.m^{-2}dt^{-1})$ @endtex
+    
+    INTEGER                                           :: i,tempi
+    REAL(r_std)   :: ratio_sap
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts)      :: circ_class_carbon
+    REAL(r_std), DIMENSION(npts,nvm,ncirc, nparts)      :: circ_class_frac
+    REAL(r_std), DIMENSION(npts,nvm,ncirc, nparts)      :: circ_class_maint
+    REAL(r_std), DIMENSION(npts,nvm,ncirc)    :: psi_leaf
+    REAL(r_std), DIMENSION(npts,nvm,ncirc)    :: psi_root
+    REAL(r_std), DIMENSION(npts,nvm,ncirc)    :: stem_plc
+!_ ================================================================================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering functional allocation growth'
+
+!! 1. Initialize
+
+    !! 1.1 First call only
+    IF ( firstcall ) THEN
+      
+       firstcall = .FALSE.
+
+    ENDIF ! first call
+
+
+    !! 1.2 Initialize variables at every call
+    qm_height(:,:) = zero
+    delta_ba = zero
+    lai_target(:,:) = zero
+    resp_maint(:,:) = zero
+    resp_growth(:,:) = zero
+    lstress_fac(:,:) = zero
+    sigma(:,:) = zero
+    gammas(:,:) = zero
+    bm_alloc_tot(:,:) = zero
+    k_latosa(:,:) = zero
+    bm_alloc(:,:,:,:) = zero
+    store_circ_class_ba(:,:,:) = zero
+    store_delta_ba(:,:,:) = zero
+    circ_class_carbon(:,:,:,:)=zero
+    circ_class_frac(:,:,:,:)=zero
+    circ_class_maint(:,:,:,:)=zero
+    ! If npp is not initialized, bare soil value is never set.
+    
+    npp(:,:) = zero
+
+    ! Not having this results in an unitilized error
+    ! with valgrid, but I can't figure out why.  It always
+    ! seems to be set before being used.
+    residual(:,:) = val_exp
+
+    ! bare soil never gets set here
+    lab_fac(:,1) = zero
+
+    DO ipts=1,npts
+        DO j=2,nvm
+           DO icirc=1,ncirc
+                 circ_class_carbon(ipts,j,icirc,ileaf)= circ_class_n(ipts,j,icirc) * circ_class_biomass(ipts,j,icirc,ileaf,icarbon) 
+                 circ_class_carbon(ipts,j,icirc,iroot)= circ_class_n(ipts,j,icirc) * circ_class_biomass(ipts,j,icirc,iroot,icarbon)
+                 circ_class_carbon(ipts,j,icirc,isapabove)= circ_class_n(ipts,j,icirc) * circ_class_biomass(ipts,j,icirc,isapabove,icarbon)
+                 circ_class_carbon(ipts,j,icirc,isapbelow)= circ_class_n(ipts,j,icirc) * circ_class_biomass(ipts,j,icirc,isapbelow,icarbon)
+
+           ENDDO
+         ENDDO
+    ENDDO
+    DO ipts=1,npts
+        DO ivm=2,nvm
+            DO icirc=1,ncirc
+                IF ((circ_class_carbon(ipts,ivm,icirc,ileaf) / biomass(ipts,ivm,ileaf,icarbon)) .GT. 0.0001)  THEN 
+                 circ_class_frac(ipts,ivm,icirc,ileaf)=circ_class_carbon(ipts,ivm,icirc,ileaf) / biomass(ipts,ivm,ileaf,icarbon)
+                ELSE 
+                 circ_class_frac(ipts,ivm,icirc,ileaf)=0.0
+                ENDIF
+               
+                 IF ((circ_class_carbon(ipts,ivm,icirc,iroot) / biomass(ipts,ivm,iroot,icarbon)) .GT. 0.0001) THEN
+                   circ_class_frac(ipts,ivm,icirc,iroot)=circ_class_carbon(ipts,ivm,icirc,iroot) / biomass(ipts,ivm,iroot,icarbon) 
+                 ELSE
+                   circ_class_frac(ipts,ivm,icirc,iroot)=0.0
+                 ENDIF
+
+                 IF ((circ_class_carbon(ipts,ivm,icirc,isapabove) / biomass(ipts,ivm,isapabove,icarbon)) .GT. 0.0001) THEN
+                   circ_class_frac(ipts,ivm,icirc,isapabove)=circ_class_carbon(ipts,ivm,icirc,isapabove) / biomass(ipts,ivm,isapabove,icarbon)
+                 ELSE
+                   circ_class_frac(ipts,ivm,icirc,isapabove)=0.0
+                 ENDIF
+
+                IF ((circ_class_carbon(ipts,ivm,icirc,isapbelow) / biomass(ipts,ivm,isapbelow,icarbon)) .GT. 0.0001) THEN
+                   circ_class_frac(ipts,ivm,icirc,isapbelow)=circ_class_carbon(ipts,ivm,icirc,isapbelow) / biomass(ipts,ivm,isapbelow,icarbon)
+                 ELSE
+                   circ_class_frac(ipts,ivm,icirc,isapbelow)=0.0
+                 ENDIF
+
+
+
+
+                !write(*,*) 'circ_class_frac',icirc,'leaf',circ_class_frac(ipts,ivm,icirc,ileaf) 
+                ! write(*,*) 'circ_class_frac',icirc,'root',circ_class_frac(ipts,ivm,icirc,iroot)
+            ENDDO 
+        ENDDO
+    ENDDO
+    !write(*,*) 'frac_flag'
+    !! 1.2.2 Initialize check for mass balance closure
+    !  The mass balance is calculated at the end of this routine
+    !  in section 8
+    pool_start = zero
+    DO ipar = 1,nparts
+       DO iele = 1,nelements
+          !  Initial biomass pool
+          pool_start(:,:,iele) = pool_start(:,:,iele) + &
+               (biomass(:,:,ipar,iele) * veget_max(:,:))
+       ENDDO
+    ENDDO
+
+    !! 1.2.3 Calculate LAI threshold below which carbohydrate reserve is used.
+    !  Lai_max is a PFT-dependent parameter specified in stomate_constants.f90
+    ! +++CHECK+++
+    ! Can we make this a function of Cs or rue_longterm? this double prescribed value does not make
+    ! to much sense to me. It is not really dynamic.
+    lai_happy(:) = lai_max(:) * lai_max_to_happy(:)
+    ! +++++++++++
+    !write(*,*) 'flag 1' 
+
+ !! 2. Use carbohydrate reserve to support growth
+
+    ! Save old leaf mass, biomass got last updated in stomate_phenology.f90
+    lm_old(:,:) = biomass(:,:,ileaf,icarbon)
+
+    ! lai for bare soil is by definition zero
+    lai(:,ibare_sechiba) = zero
+
+    DO j = 2, nvm ! Loop over # PFTs 
+
+       !! 2.1 Calculate demand for carbohydrate reserve to support leaf and root growth.
+       !  Maximum time (days) since start of the growing season during which carbohydrate 
+       !  may be used
+       IF ( is_tree(j) ) THEN
+
+          reserve_time = reserve_time_tree    
+
+       ELSE
+
+          reserve_time = reserve_time_grass
+
+       ENDIF
+
+       ! Growth is only supported by the use of carbohydrate reserves if the following 
+       ! conditions are  statisfied:\n
+       ! - PFT is not senescent;\n
+       ! - LAI must be low (i.e. below ::lai_happy) and\n
+       ! - Day of year of the simulation is in the beginning of the growing season.
+   
+       DO ipts = 1,npts
+
+          ! Calculate lai
+          lai(ipts,j) = biomass_to_lai(biomass(ipts,j,ileaf,icarbon),j)
+
+          ! We might need the c0_alloc factor, so let's calculate it.
+          c0_alloc(ipts,j) = calculate_c0_alloc(ipts, j, tau_eff_root(ipts,j), &
+               tau_eff_sap(ipts,j))
+
+       ENDDO
+
+       WHERE ( ( biomass(:,j,ileaf,icarbon) .GT. min_stomate ) .AND. & 
+            ( .NOT. senescence(:,j) ) .AND. &
+            ( lai(:,j) .LT. lai_happy(j) ) .AND. &
+            ( when_growthinit(:,j) .LT. reserve_time ) )
+          
+          ! Tell the labile and resource pool to use its reserve
+          use_reserve(:,j) = 1.0
+
+       ENDWHERE
+ 
+    ENDDO ! loop over # PFTs
+
+    !write(*,*) 'flag 2'
+
+ 
+ !! 3. Initialize allocation
+
+    DO j = 2, nvm ! Loop over # PFTs 
+ 
+       !!  3.1 Calculate scaling factors, temperature sensitivity, target lai to decide on
+       !!  reserve use, labile fraction, labile biomass and total allocatable biomass 
+       
+       ! Convert long term temperature from K to C
+       tl(:) = t2m(:) - ZeroCelsius
+
+       DO ipts = 1, npts
+
+          IF (veget_max(ipts,j) .LE. min_stomate) THEN
+
+              ! this vegetation type is not present, so no reason to do the 
+              ! calculation. CYCLE will take us out of the innermost DO loop
+               CYCLE
+
+          ENDIF
+
+          !! 3.1 Water stress
+          !  The waterstress factor varies between 0.1 and 1 and is calculated
+          !  from ::moiavail_growingseason. The latter is only used in the allometric 
+          !  allocation and its time integral is determined by tau_sap for trees
+          !  (see constantes_mtc.f90 for tau_sap and see pft_constantes.f90 for 
+          !  the definition of tau_hum_growingseason). The time integral for 
+          !  grasses and crops is a prescribed constant (see constantes.f90). For
+          !  trees KF (and indirecrtly LF) and for grasses LF are multiplied
+          !  by wstress. Because the calculated values are too low for its purpose
+          !  Sonke Zhaele multiply it by two in the N-branch (see stomate_season.f90). 
+          !  This approach maintains the physiological basis of KF while combining it 
+          !  with a simple multiplicative factor for water stress. Clearly after 
+          !  multiplication with 2, wstress is closer to 1 and will thus result in a 
+          !  KF values closer to the physiologically expected KF. We did not see the 
+          !  need to multiply by 2 because the way we now calculate ::moiavail_growingseason
+          !  is less volatile than before. Before it ranged between 0 and 1, now the 
+          !  range is more like 0.4 to 0.9.
+
+          ! Veget is now calculated from Pgap to be fully consistent within the model. Hence
+          ! dividing by veget_max gives a value between 0 and 1 that denotes the amount of 
+          ! light reaching the forest floor.
+          IF (veget_max(ipts,j) .GT. min_stomate) THEN
+
+             lstress_fac(ipts,j) = un - (veget(ipts,j) / veget_max(ipts,j))
+
+          ELSE
+
+             lstress_fac(ipts,j) = zero
+
+          ENDIF
+          !write(*,*) 'flag 3'
+          !+++TEMP+++
+!!$          IF( j == test_pft .AND. ipts == test_grid) &
+!!$               WRITE(numout,'(A,I5,2F16.8)') 'lightstress, lstress_fac, j, ', &
+!!$               j, lstress_fac(ipts,j), veget(ipts,j)
+          !++++++++++
+
+          !! 3.2 Initialize scaling factors
+          ! Stand level scaling factors
+          LF(ipts,j) = 1._r_std
+          !write(*,*) 'flag 3after'
+          ! Tree level scaling factors
+          ltor(ipts,j) = 1._r_std
+          !write(*,*)  'flag3after2'
+          circ_class_height_eff(:) = 1._r_std
+          !write(*,*) 'flag3after3'
+
+          !! 3.3 Calculate structural characteristics
+          !WRITE(*,*) 'flag 3to4'
+          ! Target lai is calculated at the stand level for the tree height of a 
+          ! virtual tree with the mean basal area or the so called quadratic mean diameter
+          qm_dia(ipts,j) = wood_to_qmdia(circ_class_biomass(ipts,j,:,:,icarbon), &
+               circ_class_n(ipts,j,:), j)
+          !write(*,*) 'flag 3to42'
+          qm_height(ipts,j) = wood_to_qmheight(circ_class_biomass(ipts,j,:,:,icarbon), &
+               circ_class_n(ipts,j,:), j)
+
+          !write(*,*) 'flag 4'
+          !! 3.4 Calculate allocation factors for trees and grasses 
+          IF ( SUM(biomass(ipts,j,:,icarbon)) .GT. min_stomate ) THEN
+
+             ! Trees
+             IF (is_tree(j)) THEN
+
+                ! Note that KF may already be calculated in stomate_prescribe.f90 (if called)
+                ! it is recalculated because the biomass pools for grasses and crops
+                ! may have been changed in stomate_phenology.f90. Trees were added to this
+                ! calculation just to be consistent.
+                
+                ! To be fully consistent with the hydraulic limitations and pipe theory,
+                ! k_latosa_zero should be calculated from equation (18) in Magnani et al.
+                ! To do so, total hydraulic resistance and tree height need to known. This
+                ! poses a problem as the resistance depends on the leaf area and the leaf 
+                ! area on the resistance. There is no independent equation and equations 12
+                ! and 18 depend on each other and substitution would be circular. Hence 
+                ! prescribed k_latosa_zero values were obtained from observational records 
+                ! and are given in mtc_parameters.f90.
+
+                ! The relationship between height and k_latosa as reported in McDowell 
+                ! et al 2002 and Novick et al 2009 is implemented to adjust k_latosa for 
+                ! the height of the stand.  The slope of the relationship is calculated in 
+                ! stomate_data.f90 This did NOT result in a realistic model behavior.
+                !!$ k_latosa(ipts,j) = wstress_fac(ipts,j) * & 
+                !!$     (k_latosa_max(j) - latosa_height(j) * qm_height(ipts,j))
+
+                ! Alternatively, k_latosa is also reported to be a function of diameter 
+                ! (i.e. stand thinning, Simonin et al 2006, Tree Physiology, 26:493-503).
+                ! Here the relationship with thinning was interpreted as a realtionship with
+                ! light stress.
+                ! +++CHECK+++
+                ! How dow we want to account for waterstress?
+!!$                k_latosa(ipts,j) = k_latosa_min(j) + (wstress_fac(ipts,j) * lstress_fac(ipts,j) * &
+!!$                     (k_latosa_max(j)-k_latosa_min(j)))
+!!$                k_latosa(ipts,j) = wstress_fac(ipts,j) * (k_latosa_min(j) + (lstress_fac(ipts,j) * &
+!!$                     (k_latosa_max(j)-k_latosa_min(j))))
+                k_latosa(ipts,j) = (k_latosa_adapt(ipts,j) + (lstress_fac(ipts,j) * &
+                     (k_latosa_max(j)-k_latosa_min(j))))
+                ! +++++++++++
+               
+                ! Also k_latosa has been reported to be a function of CO2 concentration 
+                ! (Atwell et al. 2003, Tree Physiology, 23:13-21 and Pakati et al. 2000, 
+                ! Global Change Biology, 6:889-897). This effect is not accounted for in 
+                ! the current code
+
+                ! Scaling factor to convert sapwood mass into leaf mass (KF)
+                ! derived from
+                ! LA_ind = k1 * SA_ind, k1=latosa (pipe-model)
+                ! <=> Cl * vm/ind * sla = k1 * Cs * vm/ind / wooddens / tree_ff / height_new
+                ! <=> Cl = Cs * k1 / wooddens / tree_ff/ height_new /sla
+                ! <=> Cl = Cs * KF / height_new, where KF = k1 / (wooddens * sla * tree_ff)
+                ! (1) Cl = Cs * KF / height_new
+                KF_old = KF(ipts,j) 
+                KF(ipts,j) = k_latosa(ipts,j) / (sla(j) * pipe_density(j) * tree_ff(j))
+                
+                ! KF of the previous time step was stored in ::KF_old to check its absolute 
+                ! change. If this absolute change is too big the whole allocation will crash
+                ! because it will calculate negative increments which are compensated by 
+                ! positive increments that exceed the available carbon for allocation. This 
+                ! would suggest that for examples the plant destructs leaves and uses the 
+                ! available carbon to produce more roots. This is would repesent an unwanted 
+                ! outcome. Large changes from time step to another makes its difficult for 
+                ! the scheme to ever reach allometric balance. This balance is needed for the
+                ! allocation scheme to allow 'ordinary allocation', which in turn is needed
+                ! to make use of the allocation rule of Dhote and Deleuze. It needs to be 
+                ! avoided that the code spends too much time in phenological growth and the 
+                ! if-then statements that help to restore allometric balance. For this reason
+                ! the absolute change in KF from one time step to another are truncated.
+                IF (KF_old - KF(ipts,j) .GT. max_delta_KF ) THEN
+        
+                   IF(ld_warn)THEN
+                      WRITE(numout,*) 'WARNING 2: KF was truncated'
+                      WRITE(numout,*) 'WARNING 2: PFT, ipts: ',j,ipts
+                      WRITE(numout,'(A,3F20.10)') 'WARNING 2: KF_old, KF(ipts,j), max_delta_KF: ',&
+                           KF_old, KF(ipts,j), max_delta_KF
+                   ENDIF
+
+                   ! Add maximum absolute change
+                   KF(ipts,j) = KF_old - max_delta_KF
+                   
+                   IF(ld_warn)THEN
+                      WRITE(numout,'(A,3F20.10)') 'WARNING 2: Reset, KF_old, KF(ipts,j): ',&
+                           KF_old, KF(ipts,j)
+                   ENDIF
+                ELSEIF (KF_old - KF(ipts,j) .LT. -max_delta_KF) THEN
+                   
+                   IF(ld_warn)THEN
+                      WRITE(numout,*) 'WARNING 3: KF was truncated'
+                      WRITE(numout,*) 'WARNING 3: PFT, ipts: ',j,ipts
+                      WRITE(numout,'(A,3F20.10)') 'WARNING 3: KF_old, KF(ipts,j), max_delta_KF: ',&
+                           KF_old, KF(ipts,j), -max_delta_KF
+                   ENDIF
+
+                   ! Remove maximum absolute change
+                   KF(ipts,j) = KF_old + max_delta_KF
+                   
+                   IF(ld_warn)THEN
+                      WRITE(numout,'(A,3F20.10)') 'WARNING 3: Reset, KF_old, KF(ipts,j): ',&
+                        KF_old, KF(ipts,j)
+                   ENDIF
+                ELSE
+                   ! The change in KF is acceptable no action required
+                ENDIF
+                !write(*,*) 'flag 5' 
+                ! Scaling factor to convert sapwood mass into root mass  (LF) 
+                ! derived from 
+                ! Cs = c0 * height * Cr (Magnani 2000)
+                ! Cr = Cs / c0 / height_new
+                ! scaling parameter between leaf and root mass, derived from
+                ! Cr = Cs / c0 / height_new
+                ! let Cs = Cl / KF * height_new
+                ! <=> Cr = ( Cl * height_new / KF ) / ( c0 * height_new )
+                ! <=> Cl = Cr * KF * c0
+                ! <=> Cl = Cr * LF, where LF = KF * c0
+                ! (2) Cl = Cr * LF
+                ! +++CHECK+++
+                ! How do we want to account for waterstress? wstress is accounted for in c0_alloc
+                LF(ipts,j) = c0_alloc(ipts,j) * KF(ipts,j) 
+!!$                LF(ipts,j) = c0_alloc(ipts,j) * KF(ipts,j) * wstress_fac(ipts,j)
+                ! +++++++++++
+
+                ! Calculate non-nitrogen stressed leaf to root ratio to calculate the
+                ! allocation to the reserves. Should be multiplied by a nitrogen stress
+                ! have a look in OCN. This code should be considered as a placeholder
+                ltor(ipts,j) = c0_alloc(ipts,j) * KF(ipts,j)
+
+                !---TEMP---
+               IF (j.EQ.test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
+                   WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
+                   WRITE(numout,*) 'c0_alloc, ', c0_alloc(ipts,j)
+                   WRITE(numout,*) 'tau_root, tau_sap, ', tau_eff_root(ipts,j), tau_eff_sap(ipts,j)
+                   WRITE(numout,*) 'k_root, k_sap, ', k_root(j), k_sap(j)
+                   WRITE(numout,*) 'ltor, ', ltor(ipts,j)
+                   
+                ENDIF
+                !----------
+
+             ! Grasses and crops
+             ELSEIF (.NOT. is_tree(j)) THEN
+                
+                !+++CHECK+++
+                ! Similar to ::k_latosa for trees we defined it for grasses. Note that for trees
+                ! the definition is supported by some observations. For grasses we didn't look very
+                ! hard to check the literature. Someone interested in grasses should invest some
+                ! time in this issue and replace this code by a parameter that can be derived
+                ! from observations. In the end it was decided to use the same variable name for 
+                ! grasses, crops and trees as that allowed us to optimize this parameter.
+                k_latosa(ipts,j) = (k_latosa_adapt(ipts,j) + (lstress_fac(ipts,j) * &
+                     (k_latosa_max(j)-k_latosa_min(j))))
+
+                ! The mass of the structural carbon relates to the mass of the leaves through
+                ! a prescribed parameter ::k_latosa
+                KF(ipts,j) = k_latosa(ipts,j) 
+                !++++++++++
+               
+                ! Stressed root allocation, wstress is accounted for in c0_alloc  
+	        LF(ipts,j) = c0_alloc(ipts,j) * KF(ipts,j)	
+
+	        ! Calculate non-nitrogen stressed leaf to root ratio to calculate the
+                ! allocation to the reserves 
+	        ltor(ipts,j) = c0_alloc(ipts,j) * KF(ipts,j)
+
+                !---TEMP---
+               IF (j.EQ.test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
+                  WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
+                   WRITE(numout,*) 'c0_alloc, ', c0_alloc(ipts,j)
+                   WRITE(numout,*) 'tau_root, tau_sap, ', tau_eff_root(ipts,j), tau_eff_sap(ipts,j)
+                   WRITE(numout,*) 'k_root, k_sap, ', k_root(j), k_sap(j)
+                   WRITE(numout,*) 'ltor, ', ltor(ipts,j)
+                   
+             ENDIF
+                !----------
+                
+             ENDIF
+
+          ENDIF
+
+          !+++CHECK+++
+          !! 3.5 Calculate optimal LAI
+          !  The calculation of the optimal LAI was copied and adjusted from O-CN. In O-CN it
+          !  was also used in the allocation but that seems to be inconsistent with the allometric
+          !  rules that are implemented. Say that the actual LAI is below the optimal LAI then
+          !  the O-CN approach will keep pumping carbon to grow the optimal LAI. If we would apply
+          !  the same method it means that during this phase the rule of Deleuze and Dhote would
+          !  not be used. For that reason we dropped the use of LAI_optimal and replaced it by
+          !  an allometric-based Cl_target value. Initially, lai_target was still calculated as 
+          !  described below and used in the calculation of the reserves.
+          !  Further testing showed that for some parameter sets lai_target was over 8 whereas the
+          !  realized lai was close to 4. This leaves us with a frustrated plant that will invest a
+          !  lot in its reserves but can never use them because it is constrained by the allometric
+          !  rules. To grow an LAI of 8 it would need to have a crazy sapwoodmass.
+          !  At a more fundamental level it is clear why the plant's LAI should not exceed lai_target
+          !  because then it costs more to produce and maintain the leaf than that the new leaf can
+          !  produce but there is no reason why the plant should try to reach lai_target. For these
+          !  reasons it was decided to abandon this approach to lai_target and simply replace 
+          !  lai_target by Cl_target * sla
+
+          !! 3.5.1 Scaling factor
+          !  Scaling factor to convert variables to the individual plant
+          !  Different approach between the DGVM and statitic approach
+          IF (control%ok_dgvm) THEN
+
+             ! The DGVM does currently NOT work with the new allocation, consider this as
+             ! placeholder. The original code had two different transformations to 
+             ! calculate the scalars. Both could be used but the units will differ.
+             ! When fixing the DGVM check which quantities need to be multiplied by scal 
+             ! scal = ind(ipts,j) * cn_ind(ipts,j) / veget_max(ipts,j)
+             scal = veget_max(ipts,j) / ind(ipts,j)  
+
+          ELSE
+
+             ! circ_class_biomass contain the data at the tree level
+             ! no conversion required
+             scal = 1.
+
+          ENDIF
+          !write(*,*) 'flag 6'
+          !! 3.5.2 Calculate lai_target based on the allometric rules
+          IF ( is_tree(j)) THEN
+
+             ! Basal area at the tree level (m2 tree-1)
+             circ_class_ba_eff(:) = wood_to_ba_eff(circ_class_biomass(ipts,j,:,:,icarbon),j)
+
+             ! Current biomass pools per tree (gC tree^-1) 
+             ! We will have different trees so this has to be calculated from the diameter relationships            
+             Cs(:) = ( circ_class_biomass(ipts,j,:,isapabove,icarbon) + &
+                  circ_class_biomass(ipts,j,:,isapbelow,icarbon) ) * scal
+             Cr(:) = circ_class_biomass(ipts,j,:,iroot,icarbon) * scal
+             Cl(:) = circ_class_biomass(ipts,j,:,ileaf,icarbon) * scal
+             Ch(:) = ( circ_class_biomass(ipts,j,:,iheartabove,icarbon) + &
+                  circ_class_biomass(ipts,j,:,iheartbelow,icarbon) ) * scal
+
+             DO l = 1,ncirc 
+
+                !  Calculate tree height
+                circ_class_height_eff(l) = pipe_tune2(j)*(4/pi*circ_class_ba_eff(l))**(pipe_tune3(j)/2)
+
+                !  Do the biomass pools respect the pipe model?
+                !  Do the current leaf, sapwood and root components respect the allometric 
+                !  constraints? Due to plant phenology it is possible that we have too much 
+                !  sapwood compared to the leaf and root mass (i.e. in early spring). 
+                !  Calculate the optimal root and leaf mass, given the current wood mass 
+                !  by using the basic allometric relationships. Calculate the optimal sapwood
+                !  mass as a function of the current leaf and root mass.
+                Cl_target(l) = MAX( KF(ipts,j) * Cs(l) / circ_class_height_eff(l), &
+                     Cr(l) * LF(ipts,j) , Cl(l))
+                Cs_target(l) = MAX( Cl(l) / KF(ipts,j) * circ_class_height_eff(l), &
+                     Cr(l) * LF(ipts,j) / KF(ipts,j) * circ_class_height_eff(l) , Cs(l))
+
+                ! Check dimensions of the trees
+                ! If Cs = Cs_target then ba and height are correct, else calculate the correct dimensions
+                IF ( Cs_target(l) - Cs(l) .GT. min_stomate ) THEN
+
+                   ! If Cs = Cs_target then dia and height are correct. However, if Cl = Cl_target
+                   ! or Cr = Cr_target then dia and height need to be re-estimated. Cs_target should
+                   ! satify the relationship Cl/Cs = KF/height where height is a function of Cs_target
+                   ! <=> (KF*Cs_target)/(pipe_tune2*(Cs_target+Ch)/pi
+                   ! /4)**(pipe_tune3/(2+pipe_tune3)) = Cl_target
+                   ! Search Cs needed to sustain the max of Cl or Cr.
+                   !  Search max of Cl and Cr first 
+                   Cl_target(l) = MAX(Cl(l), Cr(l)*LF(ipts,j))
+
+                   !---TEMP---
+                   IF (j.EQ.test_pft .AND. ld_alloc) THEN
+                      WRITE(numout,*) 'Does the tree needs reshaping? Class: ',l
+                      WRITE(numout,*) 'circ_class_height_eff, ', circ_class_height_eff(l)
+                      WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
+                      WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(l)-Cl(l), Cl_target(l), Cl(l)
+                      WRITE(numout,*) 'Cs, ', Cs(l)
+                      WRITE(numout,*) 'Cr, ', Cr(l)
+                      WRITE(numout,*) 'Ch, ', Ch(l)
+                  ENDIF
+                   !----------
+
+                   Cs_target(l) =  newX(KF(ipts,j), Ch(l),&
+                        & pipe_tune2(j), pipe_tune3(j), Cl_target(l),&
+                        & tree_ff(j)*pipe_density(j)*pi/4*pipe_tune2(j), Cs(l),&
+                        & 2*Cs(l), 2, j, ipts)
+
+             !         WRITE(numout,*) 'New Cs_target, ', Cs_target(l)
+            
+       ! Recalculate height and ba from the correct
+                   !  Cs_target
+                   circ_class_height_eff(l) = Cs_target(l)*KF(ipts,j)&
+                        &/Cl_target(l)
+                   circ_class_ba_eff(l) = pi/4*(circ_class_height_eff(l)&
+                        &/pipe_tune2(j))**(2/pipe_tune3(j))
+                   Cl_target(l) = KF(ipts,j) * Cs_target(l) /&
+                        & circ_class_height_eff(l)
+              !        WRITE(numout,*) 'New Cl_target, ', Cl_target(l)
+
+                   Cr_target(l) = Cl_target(l) / LF(ipts,j)
+               !       WRITE(numout,*) 'New Cr_target,+J ', Cr_target(l), j       
+
+                   !---TEMP---
+                   IF (j.EQ.test_pft .AND. ld_alloc) THEN
+                      WRITE(numout,*) 'New Cl_target, ', Cl_target(l)
+                      WRITE(numout,*) 'New Cs_target, ', Cs_target(l)
+                      WRITE(numout,*) 'New Cr_target,+J ', Cr_target(l), j       
+                   ENDIF
+                   !---------- 
+
+                ENDIF
+
+             ENDDO
+
+             ! Calculate lai_target
+             lai_target(ipts,j) = SUM(Cl_target(:)*circ_class_n(ipts,j,:)) * sla(j)
+
+          ! Grasses and croplands
+          ELSEIF ( .NOT. is_tree(j)) THEN
+             
+             ! Current biomass pools per grass/crop (gC ind^-1)
+             ! Cs has too many dimensions for grass/crops. To have a consistent notation the same variables
+             ! are used as for trees but the dimension of Cs, Cl and Cr i.e. ::ncirc should be ignored            
+             Cs(1) = biomass(ipts,j,isapabove,icarbon) * scal
+             Cr(1) = biomass(ipts,j,iroot,icarbon) * scal
+             Cl(1) = biomass(ipts,j,ileaf,icarbon) * scal
+             Ch(1) = zero
+   
+             ! Do the biomass pools respect the pipe model?
+             ! Do the current leaf, sapwood and root components respect the allometric 
+             ! constraints? Calculate the optimal root and leaf mass, given the current wood mass 
+             ! by using the basic allometric relationships. Calculate the optimal sapwood
+             ! mass as a function of the current leaf and root mass.
+             Cl_target(1) = MAX( Cs(1) * KF(ipts,j) , Cr(1) * LF(ipts,j), Cl(1) )
+             Cs_target(1) = MAX( Cl_target(1) / KF(ipts,j), Cr(1) * LF(ipts,j) / KF(ipts,j), Cs(1) ) 
+             Cr_target(1) = MAX( Cl_target(1) / LF(ipts,j), Cs_target(1) * KF(ipts,j) / LF(ipts,j), Cr(1) )
+
+             ! Calculate lai_target
+             lai_target(ipts,j) = Cl_target(1) * circ_class_n(ipts,j,1) * sla(j)
+
+             !---TEMP---
+             IF (j.EQ.test_pft .AND. ld_alloc) THEN
+                WRITE(numout,*) 'KF, LF, GRASS', KF(ipts,j), LF(ipts,j),j
+             ENDIF
+             !----------
+
+          ENDIF
+
+!!$          !! 3.5 Calculate optimum LAI 
+!!$          !  Lai is optimised for mean annual radiation use efficiency and the C costs
+!!$          !  for producing the canopy. The cost-benefit ratio is optimised when the 
+!!$          !  marginal gain / marginal cost = 1
+!!$          !  Investing 1 gC in the canopy comes at a total cost that is composed by the 
+!!$          !  C required for the canopy in addition to the roots and the sapwood to support
+!!$          !  the canopy. The total cost (C) is thus calculated as C: 
+!!$          !  LAI/sla * ( (one_year/tau_leaf) + (one_year/tau_root)/LF + (one_year/tau_sap)*height/KF))
+!!$          !  The marginal cost for one unit of LAI is then dC/dLAI : 
+!!$          !  (one_year/tau_leaf)/sla + (one_year/tau_root)/LF/sla + (one_year/tau_sap)*height/KF/sla)
+!!$          !  Where, tau_leaf is given by ::tau_leaf in days, tau_root by ::tau_root in
+!!$          !  days and tau_sap by ::tau_sap in days. LF is unitless, KF is expressed in meters
+!!$          !  and sla in m^2.gC^{-1}. The unit of dC/dLAI is thus gC.m^{-2} but all turnover
+!!$          !  times need to be expressed on an annual scale.  
+!!$          !  Investing 1gC in the canopy enables the plant to assimilate more carbon
+!!$          !  The gain (G) can be approximated by using the 'radiation use efficiency' as 
+!!$          !  follows: RUE * one_year ( 1. - exp (-0.5 * LAI ))
+!!$          !  Where, 0.5 is the extinction factor that accounts for the fact the lower parts 
+!!$          !  of the canopy receive less light. Note that RUE has a peculiar definition and is 
+!!$          !  calculated as the ratio of GPP over the fraction of radiation absorbed by the canopy.
+!!$          !  Hence the unit of RUE is gC.m^{-2}.day^{-1}. The marginal gain of one unit of LAI is dG/dLAI: 
+!!$          !  0.5 * one_year * RUE * exp (-0.5 * LAI). 
+!!$          !  Subsequently, the optimal LAI is approximated by
+!!$          !  LAI_opt = -2. * log(2*(dC/dt)/(RUE*one_year))           
+!!$          !  Added the qm_height requirement since for a grass, it had no biomass
+!!$          !  but it did have individuals.  This caused qm_height to be zero and a crash
+!!$          !  in the calculation of lai_target.
+!!$          IF ( (rue_longterm(ipts,j) .GT. min_stomate) .AND. (ind(ipts,j) .NE. zero &
+!!$               .AND. qm_height(ipts,j) .NE. 0) ) THEN
+!!$
+!!$             ! Scheme in line with the documentation
+!!$             lai_target(ipts,j) = -deux* log( (deux * (one_year/tau_leaf(j))/sla(j) + &
+!!$                  ((one_year/tau_root(j))/LF(ipts,j))/sla(j) + &
+!!$                  ((one_year/tau_sap(j))*qm_height(ipts,j)/KF(ipts,j))/sla(j)) / &
+!!$                  (rue_longterm(ipts,j)*one_year))
+!!$             lai_target(ipts,j) = MAX(MIN(lai_target(ipts,j),12.),.5)
+!!$
+!!$          ELSE
+!!$
+!!$             lai_target(ipts,j) = 0.5
+!!$
+!!$          ENDIF
+          !++++++++++
+
+          !! 3.6 Calculate mean leaf age
+          leaf_meanage = zero
+          DO m = 1,nleafages
+          
+             leaf_meanage = leaf_meanage + leaf_age(ipts,j,m) * leaf_frac(ipts,j,m)
+          
+          ENDDO
+             
+
+          !! 3.7 Calculate labile fraction 
+          !  Use constant labile fraction to initiate on-set of leaves in spring
+          IF ( (biomass(ipts,j,ileaf,icarbon) .LE. min_stomate) .AND. &
+               (use_reserve(ipts,j) .GT. min_stomate) ) THEN
+
+             lab_fac(ipts,j) = 0.7
+
+          ! Calculate labile fraction when a canopy is present but its lai is below ::lai_target
+          ! the labile fraction is a function of ::leaf_meanage, the current lai calculated as 
+          ! ::biomass(ipts,j,ileaf,icarbon)*sla(j), the ::lai_target and ::ecureuil. This functions 
+          ! scales lab_fac to a value between 0.1 and 0.7. Its scientific basis remains unclear -
+          ! the original comment did not reflect the code and was therefore removed.    
+          ELSEIF ( (biomass(ipts,j,ileaf,icarbon) .GT. min_stomate) .AND. & 
+               (lai_target(ipts,j) .GT. min_stomate) .AND. (.NOT. senescence(ipts,j)) ) THEN
+
+                lab_fac(ipts,j) = 0.1 + 0.6 * MAX(0.0,1.-MAX(ecureuil(j)*leaf_meanage/45., & 
+                   biomass(ipts,j,ileaf,icarbon)*sla(j)/lai_target(ipts,j)))
+
+          ! If the canopy has reached lai_target or is senescent lab_fac = 0.1
+          ELSE
+
+                lab_fac(ipts,j) = 0.1
+
+          ENDIF
+          !write(*,*) 'flag 7'
+        
+          !! 3.8 Calculate allocatable carbon
+          !  Total allocatable biomass during this time step determined from GPP.
+          !  GPP was calculated as CO2 assimilation in enerbil.f90
+          !  Under some exceptional conditions :gpp could be negative when
+          !  the dark respiration exceeds the photosynthesis. When this happens
+          !  the dark respiration is paid for by the labile and carbres pools
+          IF ( (biomass(ipts,j,ilabile,icarbon) + gpp_daily(ipts,j) * dt) .LT. zero ) THEN
+
+             deficit = (biomass(ipts,j,ilabile,icarbon) + gpp_daily(ipts,j) * dt)
+
+           ! The deficit is less than the carbon reserve
+             IF (-deficit .LE. biomass(ipts,j,icarbres,icarbon)) THEN
+
+              ! Pay the deficit from the reserve pool
+                biomass(ipts,j,icarbres,icarbon) = &
+                     biomass(ipts,j,icarbres,icarbon) + deficit
+                biomass(ipts,j,ilabile,icarbon) = &
+                     biomass(ipts,j,ilabile,icarbon) - deficit
+
+             ELSE
+
+                ! Not enough carbon to pay the deficit, the individual 
+                ! is going to die at the end of this day
+                biomass(ipts,j,ilabile,icarbon) = &
+                     biomass(ipts,j,ilabile,icarbon) + biomass(ipts,j,icarbres,icarbon) 
+                biomass(ipts,j,icarbres,icarbon) = zero
+
+                ! Truncate the dark respiration to the available carbon.  Now we
+                ! should use up all the reserves.  If the plant has no leaves, it
+                ! will die quickly after this.
+                gpp_daily(ipts,j) = - biomass(ipts,j,ilabile,icarbon)/dt 
+
+             ENDIF
+
+          ENDIF
+       
+          ! Labile carbon pool after possible correction for dark respiration
+          biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) + &
+               gpp_daily(ipts,j) * dt
+
+          IF(ld_alloc .AND. ipts == test_grid .AND. j == test_pft)THEN
+             WRITE(numout,*) 'Adding gpp to labile pool'
+             WRITE(numout,*) 'biomass(ipts,j,ilabile,icarbon)',biomass(ipts,j,ilabile,icarbon)
+             WRITE(numout,*) 'gpp_daily(ipts,j)',gpp_daily(ipts,j)
+         ENDIF
+         !write(*,*) 'flag 8'
+          !! 3.9 Calculate activity of labile carbon pool  
+          !  Similar realtionship as that used for the temperature response of 
+          !  maintenance respiration.  The parameters in the equation were calibrated
+          !  to give a fraction of 0.1 of GPP at reference temperature tl (i.e. 10Â°C)
+          !  Note that the temperature response has a lower slope than for respiration
+          !  to avoid too large turnover rates at high temperature.
+
+!WRITE(*,*) "tl",tl(ipts)
+
+          IF (tl(ipts) .GT. -2.) THEN
+
+             gtemp = EXP(308.56/4.*(1.0/56.02-1.0/(tl(ipts)+46.02)))
+
+          ELSE
+
+             gtemp = zero            
+
+          ENDIF
+!WRITE(*,*) "gtemp",gtemp
+
+          !  If there is a plant, and we are either at the very start or in the growing season
+          !  not during senescences, calculate labile pool use for growth
+          IF (ind(ipts,j) .GT. min_stomate .AND. &
+!!$               when_growthinit(ipts,j) .LT. (large_value - un) .AND. &
+               .NOT.senescence(ipts,j)) THEN  
+
+             ! The labile pool is filled. Re-calculate turnover of the labile pool. 
+             ! Only if the labile pool is very small turnover will exceed 0.75 
+             ! and the pool will thus be almost entirely emptied
+             IF (biomass(ipts,j,ilabile,icarbon) .GT. min_stomate) THEN
+
+                 gtemp = MAX(MIN( gtemp * lab_fac(ipts,j), 0.75 ), zero)
+
+             ! The labile pool is empty but the carbohydrate pool is filled. Move carbohydrates to the labile
+             ! pool and recalculate the turnover of the labile pool.
+             ELSEIF (biomass(ipts,j,icarbres,icarbon) .GT. min_stomate) THEN
+
+                biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) + 0.05 * &
+                     biomass(ipts,j,icarbres,icarbon)
+                biomass(ipts,j,icarbres,icarbon) = biomass(ipts,j,icarbres,icarbon) * 0.95
+                gtemp = MAX(MIN(gtemp*lab_fac(ipts,j), 0.75), zero)
+
+                IF(ld_alloc .AND. ipts == test_grid .AND. j == test_pft)THEN
+                   WRITE(numout,*) 'Moving some carbon from carbres to labile pool 1'
+                   WRITE(numout,*) 'biomass(ipts,j,ilabile,icarbon)',biomass(ipts,j,ilabile,icarbon)
+                   WRITE(numout,*) 'biomass(ipts,j,icarbres,icarbon)',biomass(ipts,j,icarbres,icarbon)
+                ENDIF
+
+             ! There is no labile or carbohydrate pool to use carbon from. Labile pool is not used
+             ELSE
+
+                gtemp = zero
+
+             ENDIF
+   
+          ENDIF
+          !write(*,*) 'gtemp',gtemp
+
+          !! 3.10 Calculate allocatable part of the labile pool
+          !  If there is a plant, and we are 
+          !  either at the very start or in the growing season not during 
+          !  senescences and after senescence only if use_reserve > 0., calculate
+          !  labile pool use for growth.
+          IF (ind(ipts,j) .GT. min_stomate .AND. &
+!!$               when_growthinit(ipts,j) .LT. (large_value - un) .AND. &
+               .NOT.senescence(ipts,j)) THEN
+
+             ! Use carbon from the labile pool to allocate. The allometric (or 
+             ! functional) allocation scheme transfers gpp to the labile pool 
+             ! (see above) and then uses the labile pool (gpp + labile(t-1)) to sustain 
+             ! growth. The fraction of the labile pool that can be used is a 
+             ! function of the temperature and phenology. bm_alloc_tot in 
+             ! gC m-2 dt-1
+             bm_alloc_tot(ipts,j) = gtemp * biomass(ipts,j,ilabile,icarbon)
+
+          ! The conditions do not support growth
+          ELSE
+
+             bm_alloc_tot(ipts,j) = zero
+             
+          ENDIF
+          !write(*,*) 'bm_alloc_tot_labile',bm_alloc_tot(ipts,j)
+          ! Update the labile carbon pool 
+          biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) - &
+               bm_alloc_tot(ipts,j)
+
+          IF(ld_alloc .AND. ipts == test_grid .AND. j == test_pft)THEN
+             WRITE(numout,*) "First bm_alloc_tot ", bm_alloc_tot(ipts,j)
+             WRITE(numout,*) "senescence(ipts,j) ", senescence(ipts,j)
+             WRITE(numout,*) "gtemp ", gtemp
+             WRITE(numout,*) "biomass(ipts,j,ilabile,icarbon) ", biomass(ipts,j,ilabile,icarbon)
+             WRITE(numout,*) "biomass(ipts,j,icarbres,icarbon) ", biomass(ipts,j,icarbres,icarbon)
+             WRITE(numout,*) "lab_fac(ipts,j) ", lab_fac(ipts,j)
+             WRITE(numout,*) "tl(ipts) ", tl(ipts)
+         ENDIF
+
+
+          !! 3.11 Maintenance respiration
+          !  First, total maintenance respiration for the whole plant is calculated by 
+          !  summing maintenance respiration of the different plant compartments.
+          !  This simply recalculates the maintenance respiration from stomate_resp.f90   
+          !  Maintenance respiration of the different plant parts is calculated in 
+          !  stomate_resp.f90 as a function of the plant's temperature, the long term 
+          !  temperature and plant coefficients:
+          !  The unit of ::resp_maint is gC m-2 dt-1
+          ! added by yitong yao in Feb 24 2020 17:46 try to increase maintnance
+          ! respiration 
+          !IF (moiavail_week(ipts,j)<0.9) THEN 
+          !     resp_maint_part(ipts,j,ileaf)=resp_maint_part(ipts,j,ileaf)*1.5/moiavail_week(ipts,j)
+          !      resp_maint_part(ipts,j,iroot)=resp_maint_part(ipts,j,iroot)*1.5/moiavail_week(ipts,j)
+          !ENDIF
+          ! maintenance respiration in each circ class 
+          !write(*,*) 'set stop point'
+          !write(*,*) 'leaf_resp_maint', resp_maint_part(1,2,ileaf)
+          !write(*,*) 'root_resp_maint', resp_maint_part(1,2,iroot)
+          DO icirc =1,ncirc
+              circ_class_maint(ipts,j,icirc,ileaf)=resp_maint_part(ipts,j,ileaf) * circ_class_frac(ipts,j,icirc,ileaf)
+         ! write(*,*) 'CIRC_CLASS_MAINT', icirc, 'leaf', circ_class_maint(ipts,j,icirc,ileaf)
+              circ_class_maint(ipts,j,icirc,iroot)=resp_maint_part(ipts,j,iroot) * circ_class_frac(ipts,j,icirc,iroot)
+         ! WRITE(*,*)  'CIRC_CLASS_MAINT', icirc, 'root', circ_class_maint(ipts,j,icirc,iroot)
+          ENDDO
+          ! added by yitong yao March 20 00:39 2020 
+          ! increase maint_resp_leaf by kleaf/kmax_leaf 
+          DO icirc=1,ncirc
+             !circ_class_maint(ipts,j,icirc,ileaf) =circ_class_maint(ipts,j,icirc,ileaf) * MIN(MAX(1.0, psi_leaf(ipts,j,icirc) * pleaf_k + pleaf_b), 6.0) 
+             !circ_class_maint(ipts,j,icirc,iroot) = circ_class_maint(ipts,j,icirc,iroot) * MIN(MAX(1.0, psi_root(ipts,j,icirc) * proot_k +proot_b), 6.0)
+             !write(*,*)  'psi_leaf',icirc,psi_leaf(ipts,j,icirc) 
+             !write(*,*)  'psi_leaf_frac', icirc, MIN(MAX(1.0, 0.0 -psi_leaf(ipts,j,icirc)/2.0), 6.0)
+          ! added by yitong yao  April 27 08:59 
+              IF (stem_plc(ipts,j,icirc) .GT. 50) THEN
+                  circ_class_maint(ipts,j,icirc,ileaf)=circ_class_maint(ipts,j,icirc,ileaf)* (stem_plc(ipts,j,icirc) / hum_plc)
+              ENDIF
+              IF (stem_plc(ipts,j,icirc) .GT. 50) THEN
+                  circ_class_maint(ipts,j,icirc,iroot)=circ_class_maint(ipts,j,icirc,iroot)* (stem_plc(ipts,j,icirc) / hum_plc)
+              ENDIF
+          ! added by yitong yao 
+          ENDDO
+           
+
+          ! yang hui
+         ! IF (humrel_ddd(ipts,j)>=0.2) THEN
+         !       resp_maint_part(ipts,j,ileaf)=resp_maint_part(ipts,j,ileaf)*maint_var/humrel_ddd(ipts,j)
+         !       resp_maint_part(ipts,j,iroot)=resp_maint_part(ipts,j,iroot)*maint_var/humrel_ddd(ipts,j)
+         ! ELSE
+         !       resp_maint_part(ipts,j,ileaf)=resp_maint_part(ipts,j,ileaf)*maint_var/0.2
+         !       resp_maint_part(ipts,j,iroot)=resp_maint_part(ipts,j,iroot)*maint_var/0.2
+         ! ENDIF
+          ! yang hui 
+          ! added by yitong yao sum maint over 20 class 
+          resp_maint_part(ipts,j,ileaf)= sum(circ_class_maint(ipts,j,:,ileaf))
+          resp_maint_part(ipts,j,iroot) =sum(circ_class_maint(ipts,j,:,iroot))
+          ! added by yitong yao March 20 00:37 2020  
+          resp_maint(ipts,j) = resp_maint(ipts,j) + SUM(resp_maint_part(ipts,j,:))
+           
+          ! Following the calculation of hourly maintenance respiration, verify that 
+          ! the PFT has not been killed after calcul of resp_maint_part in stomate.
+          ! Can this generaly calculated ::resp_maint be use under the given
+          ! conditions? Surpress the respiration for deciduous
+          !  PFTs as long as they haven't carried leaves at least once. When 
+          !  starting from scratch there is no budburst in the first year because 
+          !  the longterm phenological parameters are not initialized yet. If
+          !  not surpressed respiration consumes all the reserves before the PFT
+          !  can start growing. The code would establish a new PFT but it was
+          !  decided to surpress this respiration because it has no physiological
+          !  bases.
+          !write(*,*) 'resp_maint_first',resp_maint(ipts,j)
+          IF (ind(ipts,j) .GT. min_stomate .AND. &
+               rue_longterm(ipts,j) .NE. un) THEN
+
+             !+++CHECK+++
+             ! Can the calculated maintenance respiration be used ? Or 
+             ! does it has to be adjusted for special cases. Maintenance 
+             ! respiration should be positive. In case it is very low, use 20%
+             ! (::maint_from_labile) of the active labile carbon pool (gC m-2 dt-1)
+             ! resp_maint(ipts,j) = MAX(zero, MAX(maint_from_labile * gtemp * 
+             ! biomass(ipts,j,ilabile,icarbon), resp_maint(ipts,j)))
+         
+             ! Calculate resp_maint for the labile pool as well, no need to have the
+             ! above threshold. Make sure resp_maint is not zero
+             resp_maint(ipts,j) = MAX(zero, resp_maint(ipts,j))
+             !+++++++++++
+
+             ! Phenological growth makes use of the reserves. Some carbon needs to remain
+             ! to support the growth, hence, respiration will be limited. In this case 
+             ! resp_maint ((gC m-2 dt-1) should not be more than 80% (::maint_from_gpp) 
+             ! of the GPP (gC m-2 s-1) 
+             !write(*,*) 'lab_fac',lab_fac(ipts,j)
+             ! test remvoe limit from GPP May 15 2020 yitong yao 
+             !IF (lab_fac(ipts,j) .GT. 0.3) THEN
+
+             !   resp_maint(ipts,j) = MIN( MAX(zero, maint_from_gpp * gpp_daily(ipts,j) * dt), &
+             !        resp_maint(ipts,j))
+
+             !ENDIF
+             ! test commented by yitong yao May 15 2020
+
+          ELSE
+
+             ! No plants, no respiration
+             resp_maint(ipts,j) = zero
+
+          ENDIF
+          
+          ! commented by yitong yao try to use a new scheme for maintenance
+          ! respiration. commented old version below 
+          !write(*,*) 'resp_maint_loop',resp_maint(ipts,j)
+          ! The calculation of ::resp_maint is solely based on the demand i.e.
+          ! given the biomass and the condition of the plant, how much should be
+          ! respired. It is not sure that this demand can be satisfied i.e. the 
+          ! calculated maintenance respiration may exceed the available carbon
+          !IF ( bm_alloc_tot(ipts,j) - resp_maint(ipts,j) .LT. zero ) THEN
+
+          !   deficit = bm_alloc_tot(ipts,j) - resp_maint(ipts,j)
+
+             ! The deficit is less than the carbon reserve
+          !    IF (-deficit .LE. biomass(ipts,j,icarbres,icarbon)) THEN
+
+                ! Pay the deficit from the reserve pool
+          !      biomass(ipts,j,icarbres,icarbon) = &
+          !           biomass(ipts,j,icarbres,icarbon) + deficit
+          !      bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - deficit
+
+          !   ELSE
+
+                ! Not enough carbon to pay the deficit, the individual 
+                ! is going to die at the end of this day
+          !      bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) + &
+          !           biomass(ipts,j,icarbres,icarbon) 
+          !      biomass(ipts,j,icarbres,icarbon) = zero
+
+                ! Truncate the maintenance respiration to the available carbon
+          !      resp_maint(ipts,j) = bm_alloc_tot(ipts,j)
+
+          !   ENDIF
+
+         !  ENDIF
+         ! write(*,*) 'resp_maint_judge',resp_maint(ipts,j)
+         
+         IF ( bm_alloc_tot(ipts,j) - resp_maint(ipts,j) .LT. zero ) THEN
+         ! new scheme for maintenance respiration is attached below from Nicolas
+         ! May 14 Thu 2020 
+              deficit = bm_alloc_tot(ipts,j) - resp_maint(ipts,j)
+              IF (-deficit .LE. biomass(ipts,j,icarbres,icarbon)*0.8) THEN
+
+                 ! Pay the deficit from the reserve pool
+                 biomass(ipts,j,icarbres,icarbon) = &
+                      biomass(ipts,j,icarbres,icarbon) + deficit
+                 bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - deficit
+
+              ELSE 
+              !too much respiration for reserve pool, so we limit the 
+              !harvest to 0.8 and will try to take te rest from total sapwood
+                 deficit=deficit+biomass(ipts,j,icarbres,icarbon)*0.8
+                 bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) + biomass(ipts,j,icarbres,icarbon)*0.8
+                 biomass(ipts,j,icarbres,icarbon) = &
+                      biomass(ipts,j,icarbres,icarbon) * 0.2
+                 IF (-deficit .LE. (biomass(ipts,j,isapabove,icarbon)+biomass(ipts,j,isapbelow,icarbon))) THEN
+                    ratio_sap=0
+                    IF (biomass(ipts,j,isapabove,icarbon)+biomass(ipts,j,isapbelow,icarbon) .GT. min_stomate) THEN
+                        ratio_sap=biomass(ipts,j,isapbelow,icarbon)/(biomass(ipts,j,isapabove,icarbon)+biomass(ipts,j,isapbelow,icarbon))
+                         biomass(ipts,j,isapbelow,icarbon) = &
+                               biomass(ipts,j,isapbelow,icarbon) + deficit*ratio_sap
+                         biomass(ipts,j,isapabove,icarbon) = &
+                               biomass(ipts,j,isapabove,icarbon) + deficit*(1-ratio_sap) 
+
+                         ! allocated to each cohorts 
+                         DO icirc=1,ncirc 
+                            circ_class_biomass(ipts,j,icirc,isapabove,icarbon)=circ_class_biomass(ipts,j,icirc,isapabove,icarbon) + deficit*(1-ratio_sap)*circ_class_frac(ipts,j,icirc,isapabove) / circ_class_n(ipts,j,icirc)
+                            circ_class_biomass(ipts,j,icirc,isapbelow,icarbon)=circ_class_biomass(ipts,j,icirc,isapbelow,icarbon) + deficit*ratio_sap*circ_class_frac(ipts,j,icirc,isapbelow) / circ_class_n(ipts,j,icirc)
+                         ENDDO
+                         ! above lines allocated to each cohorts
+                         bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - deficit
+                     ENDIF
+                 ELSE
+                    ! Not enough carbon to pay the deficit, the individual
+                    ! is going to die at the end of this day
+                    bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) + &
+                         biomass(ipts,j,icarbres,icarbon)
+                    biomass(ipts,j,icarbres,icarbon) = zero
+                    ! Truncate the maintenance respiration to the available carbon
+                    resp_maint(ipts,j) = bm_alloc_tot(ipts,j)
+                 ENDIF
+              
+             ENDIF
+
+         ! above lines are test for new scheme 
+        ENDIF
+
+
+
+ 
+          ! Final ::resp_maint is known
+          bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - resp_maint(ipts,j)
+          IF(ld_alloc .AND. ipts == test_grid .AND. j == test_pft)THEN
+             WRITE(numout,*) "resp_maint ", resp_maint(ipts,j)
+          ENDIF
+          !write(*,*) 'bm_alloc_tot_maint',bm_alloc_tot(ipts,j)
+
+          !! 3.12 Growth respiration
+          !  Calculate total growth respiration and update allocatable carbon
+          !  Growth respiration is a tax on productivity, not actual allocation
+          !  Total growth respiration has be calculated before the allocation 
+          !  takes place because the allocation itself is not linear. After 
+          !  the allocation has been calculated, growth respiration can be 
+          !  calculated for each biomass component separatly. The unit of
+          !  resp_growth is gC m-2 dt-1. Surpress the respiration for deciduous
+          !  PFTs as long as they haven't carried leaves at least once. When 
+          !  starting from scratch there is no budburst in the first year because 
+          !  the longterm phenological parameters are not initialized yet. If
+          !  not surpressed respiration consumes all the reserves before the PFT
+          !  can start growing. The code would establish a new PFT but it was
+          !  decided to surpress this respiration because it has no physiological
+          !  bases.
+          IF (ind(ipts,j) .GT. min_stomate .AND. &
+               rue_longterm(ipts,j) .NE. un) THEN
+
+             resp_growth(ipts,j) = frac_growthresp(j) * MAX(zero, bm_alloc_tot(ipts,j))
+             bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - resp_growth(ipts,j)
+
+          ENDIF
+          !write(*,*) 'bm_alloc_tot_growth',bm_alloc_tot(ipts,j) 
+          !write(*,*) 'resp_growth_first',resp_growth(ipts,j)
+          IF(ld_alloc .AND. j == test_pft .AND. ipts == test_grid)THEN
+             WRITE(numout,*) 'initial bm_alloc_tot, ', bm_alloc_tot(ipts,j) + resp_growth(ipts,j)
+             WRITE(numout,*) 'growth_resp, ', resp_growth(ipts,j) 
+             WRITE(numout,*) 'bm_alloc_tot after growth resp ',bm_alloc_tot(ipts,j)
+             WRITE(numout,*) 'gpp_daily: ',gpp_daily(ipts,j)
+          ENDIF
+
+          ! Occasionally, there is a very special situation which arises, where
+          ! bm_alloc_tot is greater than min_stomate before accounting for growth respiration,
+          ! but not afterwards.  This causes a mass balance error because growth respiration is
+          ! non-zero but bm_alloc_tot is too small to trigger loops below, so nothing is
+          ! done with that carbon.  In this situation, the amout of carbon to allocate
+          ! is so low that nothing really changes.  We set the growth respiration
+          ! to zero in this special case to avoid mass imbalance, even though this
+          ! will not effect the trajectory of the plant.  It seems to happen on
+          ! the same day as leaves start growing, before any GPP is calculated.
+          IF(((bm_alloc_tot(ipts,j) + resp_growth(ipts,j)) .GT. min_stomate) .AND. &
+               (bm_alloc_tot(ipts,j) .LT. min_stomate))THEN
+
+             bm_alloc_tot(ipts,j)=bm_alloc_tot(ipts,j) + resp_growth(ipts,j)
+             resp_growth(ipts,j)=zero
+             
+          ENDIF
+
+          !! 3.12 Distribute stand level ilabile and icarbres at the tree level
+          !  The labile and carbres pools are calculated at the stand level but
+          !  are then redistributed at the tree level. This has the advantage 
+          !  that biomass and circ_class_biomass have the same dimensions for 
+          !  nparts which comes in handy when phenology and mortality are
+          !  calculated.
+          IF ( is_tree(j) ) THEN
+
+             ! Reset to zero to enable a loop over nparts
+             circ_class_biomass(ipts,j,:,ilabile,:) = zero
+             circ_class_biomass(ipts,j,:,icarbres,:) = zero
+
+             ! Distribute labile and reserve pools over the circumference classes 
+             DO m = 1,nelements
+
+                ! Total biomass across parts and circumference classes
+                temp_total_biomass = zero
+
+                DO l = 1,ncirc 
+
+                   DO k = 1,nparts
+
+                      temp_total_biomass = temp_total_biomass + &
+                           circ_class_biomass(ipts,j,l,k,m) * circ_class_n(ipts,j,l)
+
+                   ENDDO
+
+                ENDDO
+
+                ! Total biomass across parts but for a specific circumference class
+                DO l = 1,ncirc
+
+                   temp_class_biomass = zero
+
+                   DO k = 1,nparts
+
+                      temp_class_biomass = temp_class_biomass + &
+                           circ_class_biomass(ipts,j,l,k,m) * circ_class_n(ipts,j,l)
+
+                   ENDDO
+    
+                   IF (temp_total_biomass .NE. zero) THEN
+
+                      ! Share of this circumference class to the total biomass                      
+                      temp_share = temp_class_biomass / temp_total_biomass
+
+                      ! Allocation of ilabile at the tree level (gC tree-1)
+                      circ_class_biomass(ipts,j,l,ilabile,m) = temp_share * &
+                           biomass(ipts,j,ilabile,m) / circ_class_n(ipts,j,l)
+
+                      ! Allocation of icarbres at the tree level (gC tree-1)
+                      circ_class_biomass(ipts,j,l,icarbres,m) = temp_share * &
+                           biomass(ipts,j,icarbres,m) / circ_class_n(ipts,j,l)
+
+                   ELSE
+
+                      circ_class_biomass(ipts,j,l,ilabile,m) = zero
+                      circ_class_biomass(ipts,j,l,icarbres,m) = zero
+                      
+                   ENDIF
+
+                ENDDO ! ncirc
+
+             ENDDO  ! nelements
+
+          ! Grasses and crops
+          ELSE
+
+             DO m = 1,nelements
+
+                ! synchronize biomass and circ_class_biomass
+                IF (ind(ipts,j) .GT. zero) THEN
+
+                   circ_class_biomass(ipts,j,1,:,m) = biomass(ipts,j,:,m) / ind(ipts,j)
+
+                ELSE
+
+                   circ_class_biomass(ipts,j,1,:,m) = zero
+
+                ENDIF
+
+             ENDDO
+
+          ENDIF ! is_tree
+
+       ENDDO ! pnts
+
+
+ !! 5. Allometric allocation
+
+       DO ipts = 1, npts
+
+          !!  5.1 Initialize allocated biomass pools
+          f_alloc(ipts,j,:) = zero
+          Cl_inc(:) = zero
+          Cs_inc(:) = zero
+          Cr_inc(:) = zero
+          Cf_inc(:) = zero
+          Cl_incp(:) = zero
+          Cs_incp(:) = zero
+          Cr_incp(:) = zero 
+          Cs_inc_est(:) = zero
+          Cl_target(:) = zero
+          Cr_target(:) = zero
+          Cs_target(:) = zero
+ 
+          !! 5.2 Calculate allocated biomass pools for trees
+
+          !! 5.2.1 Stand to tree allocation rule of Deleuze & Dhote
+          IF ( is_tree(j) .AND. bm_alloc_tot(ipts,j) .GT. min_stomate ) THEN
+
+             !  Basal area at the tree level (m2 tree-1)
+             circ_class_ba_eff(:) = wood_to_ba_eff(circ_class_biomass(ipts,j,:,:,icarbon),j)
+             circ_class_circ_eff(:) = 2 * pi * SQRT(circ_class_ba_eff(:)/pi)
+
+             ! According to equation (-) in Bellasen et al 2010. 
+             ! ln(sigmas) = a_sig * ln(circ_med) + b_sig
+             ! sigmas = exp(a_sig*log(median(circ_med))+b_sig);
+             ! However, in the code (sapiens_forestry.f90) a different expression was used
+             ! sigmas = 0.023+0.58*prctile(circ_med,0.05);
+             ! Any of these implementations could work but seem to be more suited for 
+             ! continues or nearly continuous diameter distributions, say n_circ > 10
+             ! For a small number of diameter classes sigma depends on a prescribed
+             ! circumference percentile.
+             IF (ncirc .GE. 6) THEN          
+               
+                ! Calculate the median circumference
+                DO l = 1,ncirc
+                   
+                      IF (SUM(circ_class_n(ipts,j,1:l)) .GE. 0.5 * ind(ipts,j)) THEN
+                         
+                         median_circ  = circ_class_circ_eff(l) - 5 * min_stomate
+                      
+                         EXIT
+                      
+                      ENDIF
+                   
+                ENDDO
+
+                sigma(ipts,j) = deleuze_a(j) + deleuze_b(j) * median_circ
+                !write(*,*) 'sigma',sigma(ipts,j)         
+             ELSE
+                
+                ! The X percentile of the trees that will receive the photosynthates
+                ! depends on the FM type. In a coppice stand there is a lot of 
+                ! competition between the shoots and only the top half of the shoots
+                ! will receive GPP, the other half receives only little GPP. This was 
+                ! implemnted to get a reasonable diameter growth of coppice stands. 
+                ! If deleuze_p is independent from FM, FM strategies with high densities
+                ! have very slow diameter growth because the GPP has to be distributed 
+                ! over a large number of individuals. 
+                IF (forest_managed(ipts,j) == 3) THEN
+
+                   deleuze_p(j) = deleuze_p_coppice(j)
+
+                ELSEIF (forest_managed(ipts,j) == 1 .OR. &
+                     forest_managed(ipts,j) == 2 .OR. forest_managed(ipts,j) == 4) THEN
+                   
+                   deleuze_p(j) = deleuze_p_all(j)
+
+                ELSE
+                   
+                   WRITE(numout, *) 'forest management, ', forest_managed(ipts,j)
+                   CALL ipslerr_p (3,'growth_fun_all', &
+                        'Forest management strategy does not exist','','')
+
+                ENDIF
+                ! Search for the X percentile, where X is given by ::deleuze_p
+                ! Substract a very small number (5*min_stomate) just to be sure that 
+                ! the circ_class will be corectly accounted for in GE or LE statements
+                DO l = 1,ncirc
+                   
+                      IF (SUM(circ_class_n(ipts,j,1:l)) .GE. deleuze_p(j) * ind(ipts,j)) THEN
+                         
+                         sigma(ipts,j) = circ_class_circ_eff(l) - 5 * min_stomate
+                      
+                         EXIT
+                      
+                      ENDIF
+                   
+                ENDDO
+                
+             ENDIF
+
+          
+             !! 5.2 Calculate allocated biomass pools for trees
+             !  Only possible if there is biomass to allocate
+             !  Use sigma and m_dv to calculate a single coefficient that can be
+             !  used in the subsequent allocation scheme.
+             circ_class_dba(:) = (circ_class_circ_eff(:) - m_dv(j)*sigma(ipts,j) + &
+                  SQRT((m_dv(j)*sigma(ipts,j) + circ_class_circ_eff(:))**2 - &
+                  (4*sigma(ipts,j)*circ_class_circ_eff(:)))) / 2
+
+             !! 5.2.2 Scaling factor to convert variables to the individual plant
+             !  Allocation is on an individual basis. Stand-level variables need to convert to a 
+             !  single individual. Different approach between the DGVM and statitic approach
+             IF (control%ok_dgvm) THEN
+
+                ! The DGVM does currently NOT work with the new allocation, consider this as
+                ! placeholder. The original code had two different transformations to 
+                ! calculate the scalars. Both could be used but the units will differ.
+                ! When fixing the DGVM check which quantities need to be multiplied by scal 
+                ! scal = ind(ipts,j) * cn_ind(ipts,j) / veget_max(ipts,j)
+                scal = veget_max(ipts,j) / ind(ipts,j)  
+             
+             ELSE
+             
+                ! circ_class_biomass contain the data at the tree level
+                ! no conversion required
+                scal = 1.
+             
+             ENDIF
+             !write(*,*) 'control%ok_dgvm',control%ok_dgvm          
+             !! 5.2.3 Current biomass pools per tree (gC tree^-1) 
+             ! We will have different trees so this has to be calculated from the 
+             ! diameter relationships            
+             Cs(:) = ( circ_class_biomass(ipts,j,:,isapabove,icarbon) + &
+                  circ_class_biomass(ipts,j,:,isapbelow,icarbon) ) * scal
+             Cr(:) = circ_class_biomass(ipts,j,:,iroot,icarbon) * scal
+             Cl(:) = circ_class_biomass(ipts,j,:,ileaf,icarbon) * scal
+             Ch(:) = ( circ_class_biomass(ipts,j,:,iheartabove,icarbon) + &
+                  circ_class_biomass(ipts,j,:,iheartbelow,icarbon) ) * scal
+ 
+             ! Total amount of carbon that needs to ba allocated (::bm_alloc_tot). 
+             ! bm_alloc_tot is in gC m-2 day-1. At 1 m2 there are ::ind number of 
+             ! trees. We calculate the allocation for ::ncirc trees. Hence b_inc_tot 
+             ! needs to be scaled in the allocation routines. For all cases were 
+             ! allocation takes place for a single circumference class, scaling 
+             ! could be done before the allocation. In the ordinary allocation 
+             ! allocation takes place to all circumference classes at the same time. 
+             ! Hence scaling takes place in that step for consistency we scale during 
+             ! allocation. Note that b_inc (the carbon allocated to an individual 
+             ! circumference class cannot be estimates at this point.
+             b_inc_tot = bm_alloc_tot(ipts,j)
+             
+             !write(*,*) 'b_inc_tot',b_inc_tot
+             !! 5.2.4 C-allocation for trees
+             !  The mass conservation equations are detailed in the header of this subroutine.
+             !  The scheme assumes a functional relationships between leaves, sapwood and 
+             !  roots. When carbon is added to the leaf biomass pool, an increase in the root
+             !  biomass is to be expected to sustain water transport from the roots to the 
+             !  leaves. Also sapwood is needed to sustain this water transport and to support
+             !  the leaves.
+             DO l = 1,ncirc 
+
+                !! 5.2.4.1 Calculate tree height
+                circ_class_height_eff(l) = pipe_tune2(j)* & 
+                     (4/pi*circ_class_ba_eff(l))**(pipe_tune3(j)/2)
+
+
+                !! 5.2.4.2 Do the biomass pools respect the pipe model?
+                !  Do the current leaf, sapwood and root components respect the allometric 
+                !  constraints? Due to plant phenology it is possible that we have too much 
+                !  sapwood compared to the leaf and root mass (i.e. in early spring). 
+                !  Calculate the optimal root and leaf mass, given the current wood mass 
+                !  by using the basic allometric relationships. Calculate the optimal sapwood
+                !  mass as a function of the current leaf and root mass.
+                Cl_target(l) = MAX( KF(ipts,j) * Cs(l) / circ_class_height_eff(l), &
+                     Cr(l) * LF(ipts,j) , Cl(l))
+                Cr_target(l) = MAX( Cl_target(l) / LF(ipts,j), &
+                     Cs(l) * KF(ipts,j) / LF(ipts,j) / circ_class_height_eff(l) , Cr(l))
+                Cs_target(l) = MAX( Cl(l) / KF(ipts,j) * circ_class_height_eff(l), &
+                     Cr(l) * LF(ipts,j) / KF(ipts,j) * circ_class_height_eff(l) , Cs(l))
+
+                !---TEMP---
+                IF (j.EQ.test_pft .AND. ld_alloc) THEN
+                   WRITE(numout,*) 'bm_alloc_tot, ', bm_alloc_tot(ipts,j)
+                   WRITE(numout,*) 'Does the tree needs reshaping? Class: ',l
+                   WRITE(numout,*) 'circ_class_height_eff, ', circ_class_height_eff(l)
+                   WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
+                   WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(l)-Cl(l), Cl_target(l), Cl(l)
+                   WRITE(numout,*) 'Cs_target-Cs, ', Cs_target(l)-Cs(l), Cs_target(l), Cs(l)
+                   WRITE(numout,*) 'Cr_target-Cr, ', Cr_target(l)-Cr(l), Cr_target(l), Cr(l)
+               ENDIF
+                !----------
+
+                !! 5.2.4.2 Check dimensions of the trees
+                ! If Cs = Cs_target then ba and height are correct, else calculate 
+                ! the correct dimensions
+                IF ( Cs_target(l) - Cs(l) .GT. min_stomate ) THEN
+
+                   ! If Cs = Cs_target then dia and height are correct. However, 
+                   ! if Cl = Cl_target or Cr = Cr_target then dia and height need 
+                   ! to be re-estimated. Cs_target should satify the relationship 
+                   ! Cl/Cs = KF/height where height is a function of Cs_target
+                   ! <=> (KF*Cs_target)/(pipe_tune2*(Cs_target+Ch)/pi/4)**&
+                   ! (pipe_tune3/(2+pipe_tune3)) = Cl_target. Search Cs needed to 
+                   ! sustain the max of Cl or Cr. Search max of Cl and Cr first 
+                   Cl_target(l) = MAX(Cl(l), Cr(l)*LF(ipts,j))
+                   Cs_target(l) =  newX(KF(ipts,j), Ch(l), pipe_tune2(j), &
+                        pipe_tune3(j), Cl_target(l), &
+                        tree_ff(j)*pipe_density(j)*pi/4*pipe_tune2(j), &
+                        Cs(l), 2*Cs(l), 2, j, ipts)
+
+                   ! Recalculate height and ba from the correct Cs_target
+                   circ_class_height_eff(l) = Cs_target(l)*KF(ipts,j)/Cl_target(l)
+                   circ_class_ba_eff(l) = pi/4*(circ_class_height_eff(l)/ & 
+                        pipe_tune2(j))**(2/pipe_tune3(j))
+                   Cl_target(l) = KF(ipts,j) * Cs_target(l) / circ_class_height_eff(l)
+                   Cr_target(l) = Cl_target(l) / LF(ipts,j)
+
+                ENDIF
+
+                !---TEMP---
+                IF (j.EQ.test_pft .AND. ld_alloc) THEN
+                   WRITE(numout,*) 'height_fin, ba_fin, ', circ_class_height_eff(:), &
+                        circ_class_ba_eff(:)
+                   WRITE(numout,*) 'Cl_target, Cs_target, Cr_target, ', Cl_target(:), &
+                        Cs_target(:), Cr_target(:)
+                   WRITE(numout,*) 'New target values'
+                   WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(l)-Cl(l), Cl_target(l), Cl(l)
+                   WRITE(numout,*) 'Cs_target-Cs, ', Cs_target(l)-Cs(l), Cs_target(l), Cs(l)
+                   WRITE(numout,*) 'Cr_target-Cr, ', Cr_target(l)-Cr(l), Cr_target(l), Cr(l)
+                ENDIF
+                !-----------
+
+             ENDDO
+
+             ! The step estimate is used to linearalize the diameter vs height relationship.
+             ! Use a prior to distribute b_inc_tot over the individual trees. The share of
+             ! the total sapwood mass is used as a prior. Subsequently, estimate the change in 
+             ! diameter by assuming all the available C for allocation will be used in Cs.  
+             ! Hence, this represents the maximum possible diameter increase. It was not tested
+             ! whether this is the best prior but it seems to work OK although it often results
+             ! in very small (1e-8) negative values, with even more rare 1e-6 negative values. 
+             ! A C-balance closure check could reveal 
+             ! whether this is a real issue and requires to change the prior or not.
+             ! Calculate the linear slope (::s) of the relationship between ba and h as 
+             ! (1) s = (ba2-ba)/(height2-height). 
+             ! The goal is to approximate the ba2 that
+             ! is predicted through the non-linear ordinary allocation approach, as this will 
+             ! keep the trees in allometric balance. In the next time step, allometric 
+             ! balance is recalculated and can be corrected through the so-called phenological 
+             ! growth; hence, small deviations resulting from the linearization will not 
+             ! accumulate with time.
+             ! Note that ba2 = ba + delta_ba and that height and ba are related as
+             ! (2) height = k2*(4*ba/pi)**(k3/2)
+             ! At this stage the only information we have is that there is b_inc_tot (gC m-2) 
+             ! available for allocation. There are two obvious approximations both making use
+             ! of the same assumption, i.e. that for the initial estimate of delta_ba height is
+             ! constant. The first approximation is crude and assumes that all the available C
+             ! is used in Cs_inc (thus Cs_inc = b_inc_tot / ind ). The second approximation,
+             ! implemented here, makes use of the allometric rules and thus accounts for the
+             ! knowledge that allocating one unit the sapwood comes with a cost in leaves and 
+             ! roots thus:
+             ! b_inc_temp = Cs_inc+Cl_inc+Cr_inc
+             ! (3) <=> b_inc_temp ~= (Cs_inc_est+Cs) + KF*(Cs_inc_est+Cs)/H + ...
+             !    KF/LF*(Cs_inc_est+Cs)/H - Cs - Cl - Cr
+             ! b_inc_temp is the amount of carbon that can be allocated to each diameter class.
+             ! However, only the total amount i.e. b_inc_tot is known. Total allocatable carbon
+             ! is distributed over the different diameter classes proportional to their share
+             ! of the total wood biomass. Divide by circ_class_n to get the correct units 
+             ! (gC tree-1)
+             ! (4)  b_inc_temp ~= b_inc_tot / circ_class_n * (circ_class_n * ba**(1+k3)) / ...
+             !    sum(circ_class_n * ba**(1+k3))
+             ! By substituting (4) in (3) an expression is obtained to approximate the carbon
+             ! that will be allocated to sapwood growth per diameter class ::Cs_inc_est. This
+             ! estimate is then used to calculate delta_ba (called ::step) as
+             ! step = (Cs+Ch+Cs_inc_set)/(tree_ff*pipe_density*height) - ba where height is 
+             ! calculated from (2) after replacing ba by ba+delta_ba
+             
+             !+++CHECK+++
+             !Alternative decribed in the documentation - most complete
+             Cs_inc_est(:) = ( b_inc_tot / circ_class_n(ipts,j,:) * &
+                  (circ_class_n(ipts,j,:) * circ_class_ba_eff(:)**(un+pipe_tune3(j))) / &
+                  (SUM(circ_class_n(ipts,j,:) * circ_class_ba_eff(:)**(un+pipe_tune3(j)))) + &
+                  Cs(:) + Cl(:) + Cr(:)) * circ_class_height_eff(:) / &
+                  (circ_class_height_eff(:) + KF(ipts,j) + KF(ipts,j)/LF(ipts,j)) - Cs(:)
+             !Keep it simple
+             !Cs_inc_est(:) = ( b_inc_tot / circ_class_n(ipts,j,:) * &
+             !     (circ_class_n(ipts,j,:) * circ_class_ba_eff(:)**(un+pipe_tune3(j))) / &
+             !     (SUM(circ_class_n(ipts,j,:) * circ_class_ba_eff(:)**(un+pipe_tune3(j)))))
+             !+++++++++++
+
+             step(:) = ((Ch(:)+Cs(:)+Cs_inc_est(:)) / (tree_ff(j)*pipe_density(j)* &
+                  circ_class_height_eff(:))) - circ_class_ba_eff(:)
+
+             !++++ CHECK ++++++
+             ! It can happen that step is equal to zero sometimes.  I'm not sure why, but 
+             ! there was a case where it was nonzero for circ classes 1 and 3, and zero 
+             ! for 2.  This causes s to be zero and provokes a divide by zero error later 
+             ! on.  What if we make it not zero?  This might cause a small mass balance
+             ! error for this timestep, but I would rather have that than getting an 
+             ! infinite biomass, which is what happened in the other case.  These limits 
+             ! are arbitrary and adjusted by hand.  If the output file doesn't show this 
+             ! warning very often, I think we're okay, since the amount of carbon is really
+             ! small.
+             DO l=1,ncirc
+                IF(step(l) .LT. min_stomate*0.01 .AND. step(l) .GT. zero)THEN
+                   step(l)=min_stomate*0.02
+                   IF (ld_alloc) THEN
+                      WRITE(numout,*) 'WARNING: Might cause mass balance problems in fun_all, position 1'
+                      WRITE(numout,*) 'WARNING: ips,j ',ipts,j
+                   END IF
+                ELSEIF(step(l) .GT. -min_stomate*0.01 .AND. step(l) .LT. zero)THEN
+                   step(l)=-min_stomate*0.02
+                   IF (ld_alloc) THEN
+                      WRITE(numout,*) 'WARNING: Might cause mass balance problems in fun_all, position 2'
+                      WRITE(numout,*) 'WARNING: ips,j ',ipts,j
+                   END IF
+                ENDIF
+             ENDDO
+             !+++++++++++++++++
+             s(:) = step(:)/(pipe_tune2(j)*(4.0_r_std/pi*(circ_class_ba_eff(:)+step(:)))**&
+                  (pipe_tune3(j)/deux) - &
+                  pipe_tune2(j)*(4.0_r_std/pi*circ_class_ba_eff(:))**(pipe_tune3(j)/deux))
+
+             !! 5.2.4.3 Phenological growth
+             !  Phenological growth and reshaping of the tree in line with the pipe model. 
+             !  Turnover removes C from the different plant components but at a 
+             !  component-specific rate, as such the allometric constraints are distorted 
+             !  at every time step and should be restored before ordinary growth can 
+             !  take place
+             l = ncirc
+             DO WHILE ( (l .GT. zero) .AND. (b_inc_tot .GT. min_stomate) )
+
+                !! 5.2.4.3.1 The available wood can sustain the available leaves and roots
+                !  Calculate whether the wood is in allometric balance. The target values 
+                !  should always be larger than the current pools so the use of ABS is 
+                !  redundant but was used to be on the safe side (here and in the rest 
+                !  of the module) as it could help to find logical flaws.
+                IF ( ABS(Cs_target(l) - Cs(l)) .LT. min_stomate ) THEN
+
+                   ! Use the difference between the target and the actual to
+                   ! ensure mass balance closure because l times a values 
+                   ! smaller than min_stomate can still add up to a value 
+                   ! exceeding min_stomate.
+                   Cs_incp(l) = MAX(zero, Cs_target(l) - Cs(l))
+                   ! yitong explain: target<current means this tissue is
+                   ! enoug,increase=0 cannot be negative
+                   ! Enough leaves and wood, only grow roots
+                   IF ( ABS(Cl_target(l) - Cl(l))  .LT. min_stomate ) THEN
+
+                      ! Allocate at the tree level to restore allometric balance
+                      ! Some carbon may have been used for Cs_incp and Cl_incp
+                      ! adjust the total allocatable carbon
+                      Cl_incp(l) = MAX(zero, Cl_target(l) - Cl(l))
+                      Cr_incp(l) = MAX( MIN(b_inc_tot / circ_class_n(ipts,j,l) - &
+                           Cs_incp(l) - Cl_incp(l), Cr_target(l) - Cr(l)), zero )
+
+                      ! Write debug comments to output file
+                      IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                         CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
+                              delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
+                              KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
+                              circ_class_n, ind, 1)
+                      ENDIF
+
+                   ! Sufficient wood and roots, allocate C to leaves
+                   ELSEIF ( ABS(Cr_target(l) - Cr(l)) .LT. min_stomate ) THEN
+
+                      ! Allocate at the tree level to restore allometric balance
+                      ! Some carbon may have been used for Cs_incp and Cr_incp
+                      ! adjust the total allocatable carbon
+                      Cr_incp(l) = MAX(zero, Cr_target(l) - Cr(l))
+                      Cl_incp(l) = MAX( MIN(b_inc_tot / circ_class_n(ipts,j,l) - &
+                           Cs_incp(l) - Cr_incp(l), Cl_target(l) - Cl(l)), zero )
+
+                      ! Write debug comments to output file
+                      IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                         CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
+                              delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
+                              KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
+                              grow_wood, circ_class_n, ind, 2)
+                      ENDIF
+                      
+                   ! Both leaves and roots are needed to restore the allometric relationships
+                   ELSEIF ( ABS(Cl_target(l) - Cl(l)) .GT. min_stomate .AND. &
+                        ABS(Cr_target(l) - Cr(l)) .GT. min_stomate ) THEN                 
+
+                      ! Allocate at the tree level to restore allometric balance
+                      !  The equations can be rearanged and written as
+                      !  (i) b_inc = Cl_inc + Cr_inc
+                      !  (ii) Cr_inc = (Cl_inc+Cl)/LF - Cr
+                      !  Substitue (ii) in (i) and solve for Cl_inc
+                      !  <=> Cl_inc = (LF*(b_inc+Cr)-Cl)/(1+LF)
+                      Cl_incp(l) = MIN( ((LF(ipts,j) * ((b_inc_tot/circ_class_n(ipts,j,l) - &
+                           Cs_incp(l)) + Cr(l))) - Cl(l)) / & 
+                           (1 + LF(ipts,j)), Cl_target(l) - Cl(l) )
+                      Cr_incp(l) = MIN ( ((Cl_incp(l) + Cl(l)) / LF(ipts,j)) - Cr(l), &
+                           Cr_target(l) - Cr(l))
+
+                      ! The imbalance between Cr and Cl can be so big that (Cl+Cl_inc)/LF 
+                      ! is still less then the available root carbon (observed!). This would 
+                      ! result in a negative Cr_incp
+                      IF ( Cr_incp(l) .LT. zero ) THEN
+
+                         Cl_incp(l) = MIN( b_inc_tot/circ_class_n(ipts,j,l) - Cs_incp(l), &
+                              Cl_target(l) - Cl(l) )
+                         Cr_incp(l) = (b_inc_tot/circ_class_n(ipts,j,l)) - Cs_incp(l) - &
+                              Cl_incp(l)
+
+                      ELSEIF (Cl_incp(l) .LT. zero) THEN
+
+                         Cr_incp(l) = MIN( b_inc_tot/circ_class_n(ipts,j,l) - Cs_incp(l), &
+                              Cr_target(l) - Cr(l) )
+                         Cl_incp(l) = (b_inc_tot/circ_class_n(ipts,j,l)) - &
+                              Cs_incp(l) - Cr_incp(l)
+
+                      ENDIF                          
+
+                      ! Write debug comments to output file
+                      IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                         CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
+                              delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
+                              KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
+                              grow_wood, circ_class_n, ind, 3)
+                      ENDIF      
+
+                   ELSE
+
+                      WRITE(numout,*) 'Exc 1-3: unexpected exception' 
+                      IF(ld_stop)THEN
+                         CALL ipslerr_p (3,'growth_fun_all',&
+                              'Exc 1-3: unexpected exception','','')
+                      ENDIF
+
+                   ENDIF
+
+                !! 5.2.4.3.2 Enough leaves to sustain the wood and roots
+                ELSEIF ( ABS(Cl_target(l) - Cl(l)) .LT. min_stomate ) THEN
+
+                   ! Use the difference between the target and the actual to
+                   ! ensure mass balance closure because l times a values 
+                   ! smaller than min_stomate can still add up to a value 
+                   ! exceeding min_stomate.
+                   Cl_incp(l) = MAX(zero, Cl_target(l) - Cl(l))
+
+                   ! Enough leaves and wood, only grow roots
+                   ! This duplicates Exc 1 and these lines should never be called 
+                   IF ( ABS(Cs_target(l) - Cs(l)) .LT. min_stomate ) THEN
+
+                      ! Allocate at the tree level to restore allometric balance
+                      ! Some carbon may have been used for Cs_incp and Cl_incp
+                      ! adjust the total allocatable carbon
+                      Cs_incp(l) = MAX(zero, ABS(Cs_target(l) - Cs(l)))
+                      Cr_incp(l) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,l) - &
+                           Cl_incp(l) - Cs_incp(l), Cr_target(l) - Cr(l)), zero )
+
+                      ! Write debug comments to output file
+                      IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                         CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
+                              delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
+                              KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
+                              circ_class_n, ind, 4)
+                      ENDIF
+
+                   ! Enough leaves and roots. Need to grow sapwood to support the available 
+                   ! canopy and roots
+                   ELSEIF ( ABS(Cr_target(l) - Cr(l)) .LT. min_stomate ) THEN
+
+                      ! In truth, there might be a little root carbon to allocate here,
+                      ! since min_stomate is not equal to zero.  If there is
+                      ! enough of this small carbon in every circ class, and there
+                      ! are enough circ classes, ordinary allocation will be skipped
+                      ! below and we might try to force allocation, which is silly
+                      ! if the different in the root masses is around 1e-8. This
+                      ! means we will allocate a tiny amount to the roots to make
+                      ! sure they are exactly in balance.                  
+                      Cr_incp(l) = MAX(zero, ABS(Cr_target(l) - Cr(l)))
+                      Cs_incp(l) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,l) - &
+                           Cl_incp(l) - Cr_incp(l), Cs_target(l) - Cs(l)), zero )
+
+                      ! Write debug comments to output file
+                      IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                         CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
+                              delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
+                              KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
+                              grow_wood, circ_class_n, ind, 5)
+                      ENDIF                     
+
+                   ! Need both wood and roots to restore the allometric relationships
+                   ELSEIF ( ABS(Cs_target(l) - Cs(l) ) .GT. min_stomate .AND. &
+                        ABS(Cr_target(l) - Cr(l)) .GT. min_stomate ) THEN
+
+                      ! circ_class_ba_eff and circ_class_height_eff are already calculated
+                      ! for a tree in balance. It would be rather complicated to follow
+                      ! the allometric rules for wood allocation (implying changes in height 
+                      ! and basal area) because the tree is not in balance yet. First try 
+                      ! if we can simply satisfy the allocation needs
+                      IF (Cs_target(l) - Cs(l) + Cr_target(l) - Cr(l) .LE. &
+                           b_inc_tot/circ_class_n(ipts,j,l) - Cl_incp(l)) THEN
+                         
+                         Cr_incp(l) = Cr_target(l) - Cr(l)
+                         Cs_incp(l) = Cs_target(l) - Cs(l)
+
+                      ! Try to satisfy the need for roots
+                      ELSEIF (Cr_target(l) - Cr(l) .LE. b_inc_tot/circ_class_n(ipts,j,l) - &
+                           Cl_incp(l)) THEN
+
+                         Cr_incp(l) = Cr_target(l) - Cr(l)
+                         Cs_incp(l) = b_inc_tot/circ_class_n(ipts,j,l) - &
+                              Cl_incp(l) - Cr_incp(l)
+                         
+                      ! There is not enough use whatever is available
+                      ELSE
+                         
+                         Cr_incp(l) = b_inc_tot/circ_class_n(ipts,j,l) - Cl_incp(l)
+                         Cs_incp(l) = zero
+                         
+                      ENDIF
+
+                      ! Write debug comments to output file
+                      IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                         CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
+                              delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
+                              KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
+                              circ_class_n, ind, 6)
+                      ENDIF   
+
+                   ELSE
+
+                      WRITE(numout,*) 'Exc 4-6: unexpected exception'
+                      IF(ld_stop)THEN
+                         CALL ipslerr_p (3,'growth_fun_all',&
+                              'Exc 4-6: unexpected exception','','')
+                      ENDIF
+                      
+                   ENDIF
+
+
+                !! 5.2.4.3.3 Enough roots to sustain the wood and leaves
+                ELSEIF ( ABS(Cr_target(l) - Cr(l)) .LT. min_stomate ) THEN
+
+                   ! Use the difference between the target and the actual to
+                   ! ensure mass balance closure because l times a values 
+                   ! smaller than min_stomate can still add up to a value 
+                   ! exceeding min_stomate.
+                   Cr_incp(l) = MAX(zero, Cr_target(l) - Cr(l))
+
+                   ! Enough roots and wood, only grow leaves
+                   ! This duplicates Exc 2 and these lines should thus never be called 
+                   IF ( ABS(Cs_target(l) - Cs(l)) .LT. min_stomate ) THEN
+
+                      ! Allocate at the tree level to restore allometric balance
+                      Cs_incp(l) = MAX(zero, Cs_target(l) - Cs(l))
+                      Cl_incp(l) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,l) - &
+                           Cs_incp(l) - Cr_incp(l), &
+                           Cl_target(l) - Cl(l)), zero )
+
+                      ! Write debug comments to output file
+                      IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                         CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
+                              delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
+                              KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
+                              circ_class_n, ind, 7)
+                      ENDIF
+
+                   ! Enough leaves and roots. Need to grow sapwood to support the 
+                   ! available canopy and roots. Duplicates Exc. 4 and these lines 
+                   ! should thus never be called 
+                   ELSEIF ( ABS(Cl_target(l) - Cl(l)) .LT. min_stomate ) THEN
+
+                      ! Allocate at the tree level to restore allometric balance
+                      Cl_incp(l) = MAX(zero, Cl_target(l) - Cl(l))
+                      Cs_incp(l) = MAX( MIN(b_inc_tot/circ_class_n(ipts,j,l) - &
+                           Cr_incp(l) - Cl_incp(l), Cs_target(l) - Cs(l) ), zero )
+
+                      ! Write debug comments to output file
+                      IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                         CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
+                              delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
+                              KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
+                              circ_class_n, ind, 8)
+                      ENDIF
+
+                   ! Need both wood and leaves to restore the allometric relationships
+                   ELSEIF ( ABS(Cs_target(l) - Cs(l)) .GT. min_stomate .AND. &
+                        ABS(Cl_target(l) - Cl(l)) .GT. min_stomate ) THEN
+
+                      ! circ_class_ba_eff and circ_class_height_eff are already calculated
+                      ! for a tree in balance. It would be rather complicated to follow
+                      ! the allometric rules for wood allocation (implying changes in height 
+                      ! and basal area) because the tree is not in balance.First try if we 
+                      ! can simply satisfy the allocation needs
+                      IF (Cs_target(l) - Cs(l) + Cl_target(l) - Cl(l) .LE. &
+                           b_inc_tot/circ_class_n(ipts,j,l) - Cr_incp(l)) THEN
+
+                         Cl_incp(l) = Cl_target(l) - Cl(l)
+                         Cs_incp(l) = Cs_target(l) - Cs(l)
+
+                      ! Try to satisfy the need for leaves
+                      ! yitong explain: after root already, satisfy the leaves
+                      ! first
+                      ELSEIF (Cl_target(l) - Cl(l) .LE. b_inc_tot/circ_class_n(ipts,j,l) - &
+                           Cr_incp(l)) THEN
+
+                         Cl_incp(l) = Cl_target(l) - Cl(l)
+                         Cs_incp(l) = b_inc_tot/circ_class_n(ipts,j,l) - &
+                              Cr_incp(l) - Cl_incp(l)
+
+                      ! There is not enough use whatever is available
+                      ELSE
+
+                         Cl_incp(l) = b_inc_tot/circ_class_n(ipts,j,l) - Cr_incp(l)
+                         Cs_incp(l) = zero
+
+                      ENDIF
+
+                      ! Write debug comments to output file
+                      IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                         CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
+                              delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
+                              KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
+                              circ_class_n, ind, 9)
+                      ENDIF
+
+                   ELSE
+
+                      WRITE(numout,*) 'Exc 7-9: unexpected exception'
+                      IF(ld_stop)THEN
+                         CALL ipslerr_p (3,'growth_fun_all',&
+                              'Exc 7-9: unexpected exception','','')
+                      ENDIF
+
+                   ENDIF
+
+                ! Either Cl_target, Cs_target or Cr_target should be zero
+                ELSE
+
+                   ! Something possibly important was overlooked
+                   WRITE(numout,*) 'WARNING 4: logical flaw in the phenological allocation, PFT, class: ', j, l
+                   WRITE(numout,*) 'WARNING 4: PFT, ipts: ',j,ipts
+                   WRITE(numout,*) 'Cs - Cs_target', Cs(l), Cs_target(l)
+                   WRITE(numout,*) 'Cl - Cl_target', Cl(l), Cl_target(l)
+                   WRITE(numout,*) 'Cr - Cr_target', Cr(l), Cr_target(l)
+                   IF(ld_stop)THEN
+                       CALL ipslerr_p (3,'growth_fun_all',&
+                            'WARNING 4: logical flaw in the phenological allocation','','')
+                   ENDIF
+
+                ENDIF
+
+                !! 5.2.4.4 Wrap-up phenological allocation
+                IF ( Cl_incp(l) .GE. zero .OR. Cr_incp(l) .GE. zero .OR. &
+                     Cs_incp(l) .GE. zero) THEN
+
+                   ! Fake allocation for less messy equations in next case, 
+                   ! incp needs to be added to inc at the end
+                   Cl(l) = Cl(l) + Cl_incp(l)
+                   Cr(l) = Cr(l) + Cr_incp(l)
+                   Cs(l) = Cs(l) + Cs_incp(l)
+                   b_inc_tot = b_inc_tot - (circ_class_n(ipts,j,l) * &
+                        (Cl_incp(l) + Cr_incp(l) + Cs_incp(l)))             
+
+                   ! Something is wrong with the calculations
+                   IF (b_inc_tot .LT. -min_stomate) THEN
+
+                      WRITE(numout,*) 'WARNING 5: numerical problem, overspending in phenological allocation'
+                      WRITE(numout,*) 'WARNING 5: PFT, ipts: ',j,ipts
+                      CALL ipslerr_p (3,'growth_fun_all',&
+                           'WARNING 5: numerical problem, overspending in phenological allocation','','')
+                   ENDIF
+
+                ELSE
+
+                   ! The code was written such that the increment pools should be 
+                   ! greater than or equal to zero. If this is not the case, something 
+                   ! fundamental is wrong with the if-then constructs under Â§5.2.4.3
+                   WRITE(numout,*) 'WARNING 6: PFT, ipts: ',j,ipts
+                   CALL ipslerr_p (3,'growth_fun_all',&
+                        'WARNING 6: numerical problem, one of the increment pools is less than zero','','')
+                ENDIF
+
+                ! Set counter for next circumference class
+                l = l-1
+
+             ENDDO ! DO WHILE l.GE.1 .AND. b_inc_tot .GT. min_stomate
+             !write(*,*) 'b_inc_tot_pheno',b_inc_tot
+
+             !! 5.2.5 Calculate the expected size of the reserve pool 
+             !  use the minimum of either (1) 2% of the total sapwood biomass or 
+             !  (2) the amount of carbon needed to develop the optimal LAI and the roots
+             !  This reserve pool estimate is only used to decide whether wood should be
+             !  grown or not. When really dealing with the reserves the reserve pool is 
+             !  recalculated. See further below Â§7.1. 
+             reserve_pool = MIN( 0.02 * ( biomass(ipts,j,isapabove,icarbon) + &
+                  biomass(ipts,j,isapbelow,icarbon)), &
+                  lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j))) 
+             grow_wood = .TRUE.
+
+             ! If the carbohydrate pool is too small, don't grow wood
+             IF ( (pheno_type(j) .NE. 1) .AND. &
+                  (biomass(ipts,j,icarbres,icarbon) .LE. reserve_pool) ) THEN
+
+                grow_wood = .FALSE.
+
+             ENDIF
+
+             ! Write debug comments to output file
+             IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
+                     delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
+                     KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
+                     circ_class_n, ind, 10)
+             ENDIF
+
+
+             !! 5.2.6 Ordinary growth
+             !  Allometric relationship between components is respected, sustain 
+             !  ordinary growth and allocate
+             !  biomass to leaves, wood, roots and fruits.
+             IF ( (SUM( ABS(Cl_target(:) - Cl(:)) ) .LE. min_stomate) .AND. &
+                  (SUM( ABS(Cs_target(:) - Cs(:)) ) .LE. min_stomate) .AND. &
+                  (SUM( ABS(Cr_target(:) - Cr(:)) ) .LE. min_stomate) .AND. &
+                  (grow_wood) .AND. (b_inc_tot .GT. min_stomate) ) THEN
+
+                ! Allocate fraction of carbon to fruit production (at the tree level)
+                Cf_inc(:) = b_inc_tot / SUM(circ_class_n(ipts,j,:)) * fruit_alloc(j)
+
+                ! Residual carbon is allocated to the other components (b_inc_tot is
+                ! at the stand level)
+                b_inc_tot = b_inc_tot * (un-fruit_alloc(j))
+
+                ! Substitute (7), (8) and (9) in (1) 
+                ! b_inc = tree_ff*pipe_density*(ba+circ_class_dba*gammas)*...
+                ! (height+(circ_class_dba/s*gammas)) - Cs - Ch + ...
+                !    KF*tree_ff*pipe_density*(ba+circ_class_dba*gammas) - ... 
+                !    (KF*Ch)/(height+(circ_class_dba/s*gammas)) - Cl + ...
+                !    KF/LF*tree_ff*pipe_density*(ba+circ_class_dba*gammas) - ...
+                !    (KF*Ch/LF)/(height+(circ_class_dba/s*gammas)) - Cr
+                !
+                ! b_inc+Cs+Ch+Cl+Cr = tree_ff*pipe_density*(ba+circ_class_dba*gammas)*...
+                !    (height+(circ_class_dba/s*gammas))  + ...
+                !    KF*tree_ff*pipe_density*(ba+circ_class_dba*gammas) - ...
+                !    (KF*Ch)/(height+(circ_class_dba/s*gammas)) + ...
+                !    KF/LF*tree_ff*pipe_density*(ba+circ_class_dba*gammas) - ...
+                !    (KF*Ch/LF)/(height+(circ_class_dba/s*gammas))
+                ! <=> b_inc+Cs+Ch+Cl+Cr = circ_class_dba^2/s*tree_ff*...
+                !    pipe_density*gammas^2 + circ_class_dba/s*ba*tree_ff*...
+                !    pipe_density*gammas + ...
+                !    circ_class_dba*height*tree_ff*pipe_density*gammas + ...
+                !    bcirc_class_dba*height*tree_ff*pipe_density - ...
+                !    (Ch*KF*s)/(circ_class_dba*gammas+height*s) + ...
+                !    circ_class_dba*KF*tree_ff*pipe_density*gammas + ...
+                !    ba*KF*tree_ff*pipe_density - ...
+                !    (Ch*KF*s)/(LF*(circ_class_dba*gammas+height*s)) + ...
+                !    circ_class_dba*KF/LF*tree_ff*pipe_density*gammas + ...
+                !    ba*KF/LF*tree_ff*pipe_density
+                ! (10) b_inc+Cs+Ch+Cl+Cr = (circ_class_dba^2/s*tree_ff*...
+                !    pipe_density)*gammas^2 + ...
+                !    (circ_class_dba/s*ba*tree_ff*pipe_density + ...
+                !    circ_class_dba*height*tree_ff*pipe_density + ...
+                !    circ_class_dba*KF*tree_ff*pipe_density + ...
+                !    circ_class_dba*KF/LF*tree_ff*pipe_density)*gammas - ...
+                !    (Ch*KF*s)(1+1/LF)/(circ_class_dba*gammas+height*s) + ...
+                !    bcirc_class_dba*height*tree_ff*pipe_density + ...
+                !    ba*KF*tree_ff*pipe_density + ba*KF/LF*tree_ff*pipe_density
+                !
+                ! Note that b_inc is not known, only b_inc_tot (= sum(b_inc) is known. 
+                ! The above equations are for individual trees, at the stand level we 
+                ! have to take the sum over the individuals which is 
+                ! equivalant to substituting (10) in (2) 
+                ! (11) sum(b_inc) + sum(Cs+Ch+Cl+Cr) = ...
+                !    sum(circ_class_dba^2/s*tree_ff*pipe_density) * gammas^2 + ...
+                !    sum(circ_class_dba/s*ba*tree_ff*pipe_density + ...
+                !    circ_class_dba*height*tree_ff*pipe_density + ...
+                !    circ_class_dba*KF*tree_ff*pipe_density + ...
+                !    circ_class_dba*KF/LF*tree_ff*pipe_density) * gammas - ...
+                !    sum[(Ch*KF*s)(1+1/LF)/(circ_class_dba*gammas+height*s)] + ...
+                !    sum(bcirc_class_dba*height*tree_ff*pipe_density + ...
+                !    ba*KF*tree_ff*pipe_density + ba*KF/LF*tree_ff*pipe_density)
+                !
+                ! The term sum[(Ch*KF*s)(1+1/LF)/(circ_class_dba*gammas+height*s)] 
+                ! can be approximated by a series expansion
+                ! (12) sum((Ch*KF*s)(1+1/LF)/(height*s) + ...
+                !    sum((Ch*KF*s)(1+1/LF)*circ_class_dba/(height*s)^2)*gammas + ...
+                !    sum((Ch*KF*s)(1+1/LF)*circ_class_dba^2/(height*s)^3)*gammas^2
+                !
+                ! Substitute (12) in (11)
+                ! sum(b_inc) + sum(Cs+Ch+Cl+Cr) = ...
+                !    sum(circ_class_dba^2/s*tree_ff*pipe_density - ...
+                !    (Ch*KF*s)*(1+1/LF)*circ_class_dba^2/(height*s)^3) * gammas^2 + ...
+                !    sum(circ_class_dba/s*ba*tree_ff*pipe_density + ...
+                !    circ_class_dba*height*tree_ff*pipe_density + ...
+                !    circ_class_dba*KF*tree_ff*pipe_density + ...
+                !    circ_class_dba*KF/LF*tree_ff*pipe_density + ...
+                !    (Ch*KF*s)*(1+1/LF)*circ_class_dba/(height*s)^2) * gammas + ...
+                !    sum(bcirc_class_dba*height*tree_ff*pipe_density + ...
+                !    ba*KF*tree_ff*pipe_density + ba*KF/LF*tree_ff*pipe_density - ...
+                !    (Ch*KF*s)*(1+1/LF)/(height*s))
+                !
+                ! Solve this quadratic equation for gammas.
+                a = SUM( circ_class_n(ipts,j,:) * &
+                     (circ_class_dba(:)**2/s(:)*tree_ff(j)*pipe_density(j) - &
+                     (Ch(:)*KF(ipts,j)*s(:))*(1+1/LF(ipts,j))*&
+                     (circ_class_dba(:)**2/(circ_class_height_eff(:)*s(:))**3)) )
+                b = SUM( circ_class_n(ipts,j,:) * &
+                     (circ_class_dba(:)/s(:)*circ_class_ba_eff(:)*tree_ff(j)*pipe_density(j) + &
+                     circ_class_dba(:)*circ_class_height_eff(:)*tree_ff(j)*pipe_density(j) + &
+                     circ_class_dba(:)*KF(ipts,j)*tree_ff(j)*pipe_density(j) + &
+                     circ_class_dba(:)*KF(ipts,j)/LF(ipts,j)*tree_ff(j)*pipe_density(j) + &
+                     (Ch(:)*KF(ipts,j)*s(:))*(1+1/LF(ipts,j))*circ_class_dba(:)/&
+                     (circ_class_height_eff(:)*s(:))**2) )
+                c = SUM( circ_class_n(ipts,j,:) * &
+                     (circ_class_ba_eff(:)*circ_class_height_eff(:)*&
+                     tree_ff(j)*pipe_density(j) + &
+                     circ_class_ba_eff(:)*KF(ipts,j)*tree_ff(j)*pipe_density(j) + &
+                     circ_class_ba_eff(:)*KF(ipts,j)/LF(ipts,j)*tree_ff(j)*pipe_density(j) - &
+                     (Ch(:)*KF(ipts,j)*s(:))*(1+1/LF(ipts,j))/&
+                     (circ_class_height_eff(:)*s(:)) - &
+                     (Cs(:) + Ch(:) + Cl(:) + Cr(:))) ) - b_inc_tot
+
+                ! Solve the quadratic equation a*gammas2 + b*gammas + c = 0, for gammas.
+                gammas(ipts,j) = (-b + sqrt(b**2-4*a*c)) / (2*a)  
+
+                !++++++ TEMP ++++++
+!!$                IF(test_pft == j .AND. test_grid ==ipts)THEN
+!!$                   WRITE(numout,*) 'Testing for the slope'
+!!$                   DO i=1,100
+!!$                      tempi=1
+!!$                      delta_ba(tempi) = circ_class_dba(tempi) * gammas * REAL(i)/50.0
+!!$                      delta_height(tempi) = delta_ba(tempi)/s(tempi)
+!!$                      Cs_inc(tempi) = tree_ff(j)*pipe_density(j)*(circ_class_ba_eff(tempi) + delta_ba(tempi))*(circ_class_height_eff(tempi) + &
+!!$                           delta_height(tempi)) - Cs(tempi) - Ch(tempi)
+!!$                      Cl_inc(tempi) = KF(ipts,j)*tree_ff(j)*pipe_density(j)*(circ_class_ba_eff(tempi)+delta_ba(tempi)) - &
+!!$                           (KF(ipts,j)*Ch(tempi))/(circ_class_height_eff(tempi)+delta_height(tempi)) - Cl(tempi)
+!!$                      Cr_inc(tempi) = KF(ipts,j)/LF(ipts,j)*tree_ff(j)*pipe_density(j)*(circ_class_ba_eff(tempi)+delta_ba(tempi)) - &
+!!$                           (KF(ipts,j)*Ch(tempi)/LF(ipts,j))/(circ_class_height_eff(tempi)+delta_height(tempi)) - Cr(tempi)    
+!!$                      WRITE(numout,'(10F20.10)') delta_height(tempi),delta_ba(tempi),Cs_inc(tempi),Cl_inc(tempi),Cr_inc(tempi)
+!!$                   ENDDO
+!!$                   WRITE(numout,*) 'End testing for the slope'
+!!$                END IF
+                !+++++++++++++++++
+                
+                ! The solution for gammas is then used to calculate delta_ba (eq. 3), 
+                ! delta_height (eq. 6), Cs_inc (eq. 7), Cl_inc (eq. 8) and Cr_inc (eq. 9). 
+                ! See comment on the calculation of delta_height and its implications on 
+                ! numerical consistency at the similar statement in Â§5.2.4.3.1
+                delta_ba(:) = circ_class_dba(:) * gammas(ipts,j)
+                store_delta_ba(ipts,j,:) = delta_ba(:)
+                delta_height(:) = delta_ba(:)/s(:)              
+                Cs_inc(:) = tree_ff(j)*pipe_density(j)*(circ_class_ba_eff(:) + &
+                     delta_ba(:))*(circ_class_height_eff(:) + &
+                     delta_height(:)) - Cs(:) - Ch(:)
+                Cl_inc(:) = KF(ipts,j)*tree_ff(j)*pipe_density(j)*&
+                     (circ_class_ba_eff(:)+delta_ba(:)) - &
+                     (KF(ipts,j)*Ch(:))/(circ_class_height_eff(:)+delta_height(:)) - Cl(:)
+                Cr_inc = KF(ipts,j)/LF(ipts,j)*tree_ff(j)*pipe_density(j)*&
+                     (circ_class_ba_eff(:)+delta_ba(:)) - &
+                     (KF(ipts,j)*Ch(:)/LF(ipts,j))/(circ_class_height_eff(:)+&
+                     delta_height(:)) - Cr(:)
+
+                ! After thousands of simulation years we had a single pixel where 
+                ! one of the three circ_class got a negative growth. The cause is not
+                ! is not entirely clear but could be related to the fact that KF
+                ! changes from one day to another in combination with a low b_inc.
+                ! If this happens, we don't allocate and simply leave the carbon
+                ! in the labile pool. We will try again with more carbon the next day.
+                ! This case is dealt with later in the code - see warning 10
+                
+
+                ! Write debug comments to output file
+                IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                   WRITE(numout,*) 'a, b, c, gammas, ', a, b, c, gammas(ipts,j)
+                   WRITE(numout,*) 'delta_height, ', delta_height(:)
+                   CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
+                        delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
+                        KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
+                        circ_class_n, ind, 11)
+                ENDIF
+
+                ! Wrap-up ordinary growth  
+                ! Calculate C that was not allocated, note that Cf_inc was already substracted
+                b_inc_tot = b_inc_tot - &
+                     SUM(circ_class_n(ipts,j,:)*(Cl_inc(:) + Cr_inc(:) + Cs_inc(:)))
+                !---TEMP---
+                IF (j.EQ.test_pft .AND. ld_alloc) THEN
+                   WRITE(numout,*) 'wrap-up ordinary allocation, left b_in_tot, ', b_inc_tot 
+                ENDIF
+                !----------
+
+
+             !! 5.2.7 Don't grow wood, use C to fill labile pool
+             ELSEIF ( (.NOT. grow_wood) .AND. (b_inc_tot .GT. min_stomate) ) THEN
+
+                ! Calculate the C that needs to be distributed to the 
+                ! labile pool. The fraction is proportional to the ratio 
+                ! between the total allocatable biomass and the unallocated 
+                ! biomass per tree (b_inc now contains the unallocated 
+                ! biomass). At the end of the allocation scheme bm_alloc_tot 
+                ! is substracted from the labile biomass pool to update the 
+                ! biomass pool (biomass(:,:,ilabile) = biomass(:,:,ilabile) - 
+                ! bm_alloc_tot(:,:)). At that point, the scheme puts the 
+                ! unallocated b_inc into the labile pool. What we 
+                ! want is that the unallocated fraction is removed from 
+                ! ::bm_alloc_tot such that only the allocated C is removed 
+                ! from the labile pool. b_inc_tot will be moved back into
+                ! the labile pool in 5.2.11
+                bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - b_inc_tot
+                biomass(ipts,j,ilabile,icarbon) = &
+                     biomass(ipts,j,ilabile,icarbon) + b_inc_tot 
+
+                ! Wrap-up ordinary growth  
+                ! Calculate C that was not allocated (b_inc_tot), the 
+                ! equation should read b_inc_tot = b_inc_tot - b_inc_tot 
+                ! note that Cf_inc was already substracted
+                b_inc_tot = zero 
+
+                !---TEMP---
+                IF (j.EQ.test_pft .AND. ld_alloc) THEN
+                   WRITE(numout,*) 'No wood growth, move remaining C to labile pool'
+                   WRITE(numout,*) 'bm_alloc_tot_new, ',bm_alloc_tot(ipts,j)
+                   WRITE(numout,*) 'wrap-up ordinary allocation, left b_inc_tot, ', b_inc_tot 
+                ENDIF
+                !---------- 
+
+
+             !! 5.2.8 Error - the allocation scheme is overspending 
+             ELSEIF (b_inc_tot .LT. min_stomate) THEN
+
+                IF (b_inc_tot .LT. -min_stomate) THEN
+
+                   ! Something is wrong with the calculations
+                   WRITE(numout,*) 'WARNING 7: numerical problem overspending in ordinary allocation'
+                   WRITE(numout,*) 'WARNING 7: PFT, ipts: ',j,ipts
+                   WRITE(numout,*) 'WARNING 7: b_inc_tot', b_inc_tot
+                   IF(ld_stop)THEN
+                      CALL ipslerr_p (3,'growth_fun_all',&
+                           'WARNING 7: numerical problem overspending in ordinary allocation','','')
+                   ENDIF
+
+                ELSE
+
+                   IF (j.EQ.test_pft .AND. ld_alloc) THEN
+
+                      ! Succesful allocation
+                      WRITE(numout,*) 'Successful allocation'
+
+                   ENDIF
+
+                ENDIF
+
+                ! Althought the biomass components respect the allometric relationships, there
+                ! is no carbon left to allocate                      
+                b_inc_tot = zero
+                Cl_inc(:) = zero
+                Cs_inc(:) = zero
+                Cr_inc(:) = zero
+                Cf_inc(:) = zero
+
+             ENDIF ! Ordinary allocation
+             !write(*,*) 'b_inc_tot_ordi',b_inc_tot
+             !! 5.2.9 Forced allocation
+             !  Although this should not happen, in case the functional allocation did not 
+             !  consume all the allocatable carbon, the remaining C is left for the next day, 
+             !  and some of the biomass is used to produce fruits (tuned). The numerical 
+             !  precision of the allocation scheme (i.e. the linearisation) is similar to 
+             !  min_stomate (i.e. 10-8) resulting in 'false' warnings. In the latter case 
+             !  forced allocation is applied but only for very small amounts of carbon 
+             !  i.e. between 10-5 and 10-8.  
+             IF ( b_inc_tot .GT. min_stomate) THEN
+
+                WRITE(numout,*) 'WARNING 8: b_inc_tot greater than min_stomate force allocation'
+                WRITE(numout,*) 'WARNING 8: PFT, ipts: ',j,ipts
+                WRITE(numout,*) 'WARNING 8: b_inc_tot, ', b_inc_tot
+                IF(ld_stop)THEN
+                   CALL ipslerr_p (3,'growth_fun_all',&
+                        'WARNING 8: b_inc_tot greater than min_stomate force allocation','','')
+                ENDIF
+
+                !+++CHECK+++
+                ! We should not end-up here. We need some code to break the conditions 
+                ! that made us end-up here. The current code will do this job.
+!!$                ! Calculate fraction that will be allocated to fruit. The fraction is proportional to the 
+!!$                ! ratio between the total allocatable biomass and the unallocated biomass per tree
+!!$                frac = fruit_alloc(j) * MIN(1., bm_alloc_tot(ipts,j) / b_inc_tot)  
+!!$                Cf_inc(:) = Cf_inc(:) + b_inc_tot * frac
+!!$                b_inc_tot = b_inc_tot * (1 - frac)
+!!$
+!!$                ! Calculate the C that needs to be distributed to the labile pool. The fraction is proportional 
+!!$                ! to the ratio between the total allocatable biomass and the unallocated biomass per tree (b_inc 
+!!$                ! now contains the unallocated biomass). At the end of the allocation scheme bm_alloc_tot is 
+!!$                ! substracted from the labile biomass pool to update the biomass pool (biomass(:,:,ilabile) = 
+!!$                ! biomass(:,:,ilabile,icarbon) - bm_alloc_tot(:,:)). At that point, the scheme puts the 
+!!$                ! unallocated b_inc into the labile pool.
+!!$                bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) * &
+!!$                     ( 1. - (1.-frac) * b_inc_tot / bm_alloc_tot(ipts,j) )
+                !+++++++++++
+
+             ELSEIF ( (b_inc_tot .LT. min_stomate) .AND. (b_inc_tot .GE. -min_stomate) ) THEN
+
+                ! Successful allocation
+                IF (j.EQ.test_pft .AND. ld_alloc) THEN
+                   WRITE(numout,*) 'Successful allocation'
+                ENDIF
+
+             ELSE
+
+                ! Something possibly important was overlooked
+                IF ( (b_inc_tot .LT. 100*min_stomate) .AND. (b_inc_tot .GE. -100*min_stomate) ) THEN
+                   IF (j.EQ.test_pft .AND. ld_alloc) THEN
+                      WRITE(numout,*) 'Marginally successful allocation - precision better than 10-6'
+                      WRITE(numout,*) 'PFT, b_inc_tot', j, b_inc_tot
+                   ENDIF
+                ELSE
+                   WRITE(numout,*) 'WARNING 9: Logical flaw unexpected result in the ordinary allocation'
+                   WRITE(numout,*) 'WARNING 9: b_inc_tot, ',b_inc_tot
+                   WRITE(numout,*) 'WARNING 9: PFT, ipts: ',j,ipts
+                  IF(ld_stop)THEN
+                     CALL ipslerr_p (3,'growth_fun_all',&
+                          'WARNING 9: Logical flaw unexpected result in the ordinary allocation','','')
+                  ENDIF
+                ENDIF
+
+             ENDIF
+
+             ! The second problem we need to catch is when one of the increment pools is 
+             ! negative. This is an undesired outcome (see comment where ::KF_old is 
+             ! calculated in this routine. In that case we write a warning, set all increment
+             ! pools to zero and try it again at the next time step. A likely cause of this 
+             ! problem is a too large change in KF from one time step to another. Try decreasing
+             ! the acceptable value for an absolute increase in KF.
+             IF (MINVAL(Cs_inc(:)) .LT. zero .OR. MINVAL(Cr_inc(:)) .LT. zero .OR. &
+                  MINVAL(Cs_inc(:)) .LT. zero) THEN
+
+                ! Do not allocate - save the carbon for the next time step
+                WRITE(numout,*) 'WARNING 10: numerical problem, one of the increment pools is less than zero'
+                WRITE(numout,*) 'WARNING 10: PFT, ipts: ',j,ipts
+                WRITE(numout,*) 'WARNING 10: Cl_inc(:): ',Cl_inc(:)
+                WRITE(numout,*) 'WARNING 10: Cr_inc(:): ',Cr_inc(:)
+                WRITE(numout,*) 'WARNING 10: Cs_inc(:): ',Cs_inc(:)
+                WRITE(numout,*) 'WARNING 10: PFT, ipts: ',j,ipts
+                WRITE(numout,*) 'WARNING 10: We will undo the allocation'
+                WRITE(numout,*) ' and save the carbon for the next day'
+
+                ! Reverse the allocation
+                
+                b_inc_tot = b_inc_tot + &
+                     SUM(circ_class_n(ipts,j,:)*(Cl_inc(:) + Cr_inc(:) + Cs_inc(:)))
+                Cl_inc(:) = zero
+                Cr_inc(:) = zero
+                Cs_inc(:) = zero
+
+             ENDIF
+
+             !! 5.2.10 Wrap-up phenological and ordinary allocation
+             Cl_inc(:) = Cl_inc(:) + Cl_incp(:)
+             Cr_inc(:) = Cr_inc(:) + Cr_incp(:)
+             Cs_inc(:) = Cs_inc(:) + Cs_incp(:)
+             residual(ipts,j) = b_inc_tot
+
+             !---TEST---
+             IF (j.EQ.test_pft .AND. ld_alloc) THEN
+                WRITE(numout,*) 'Final allocation', ipts, j
+                WRITE(numout,*) 'Cl, Cs, Cr', Cl(:), Cs(:), Cr(:) 
+                WRITE(numout,*) 'Cl_incp, Cs_incp, Cr_incp, ', Cl_incp(:), Cs_incp(:), Cr_incp(:)
+                WRITE(numout,*) 'Cl_inc, Cs_ins, Cr_inc, Cf_inc, ', Cl_inc(:), Cs_inc(:), Cr_inc(:), Cf_inc(:)
+                WRITE(numout,*) 'unallocated/residual, ', b_inc_tot
+                WRITE(numout,*) 'Old ba, delta_ba, new ba, ', circ_class_ba_eff(:), delta_ba(:), circ_class_ba_eff(:)+delta_ba(:)
+                DO l=1,ncirc
+                   WRITE(numout,*) 'Circ_class_biomass, ',circ_class_biomass(ipts,j,l,:,icarbon)
+                ENDDO
+             ENDIF
+             !----------
+
+
+             !! 5.2.11 Account for the residual
+             !  The residual is usually around ::min_stomate but we deal 
+             !  with it anyway to make sure the mass balance is closed
+             !  and as a way to detect errors. Move the unallocated carbon
+             !  back into the labile pool
+             IF (biomass(ipts,j,ilabile,icarbon) + residual(ipts,j) .LE. min_stomate) THEN
+
+                deficit = biomass(ipts,j,ilabile,icarbon) + residual(ipts,j)
+
+                ! The deficit is less than the carbon reserve
+                IF (-deficit .LE. biomass(ipts,j,icarbres,icarbon)) THEN
+
+                   ! Pay the deficit from the reserve pool
+                   biomass(ipts,j,icarbres,icarbon) = &
+                        biomass(ipts,j,icarbres,icarbon) + deficit
+                   biomass(ipts,j,ilabile,icarbon)  = &
+                        biomass(ipts,j,ilabile,icarbon) - deficit
+
+                ELSE
+
+                   ! Not enough carbon to pay the deficit
+                   ! There is likely a bigger problem somewhere in
+                   ! this routine
+                   WRITE(numout,*) 'WARNING 11: PFT, ipts: ',j,ipts
+                   CALL ipslerr_p (3,'growth_fun_all',&
+                        'WARNING 11: numerical problem overspending ',&
+                        'when trying to account for unallocatable C ','')
+
+                ENDIF
+
+             ELSE
+
+                ! Move the unallocated carbon back into the labile pool
+                biomass(ipts,j,ilabile,icarbon) = &
+                     biomass(ipts,j,ilabile,icarbon) + residual(ipts,j)
+
+             ENDIF
+
+             !! 5.2.12 Standardise allocation factors
+             !  Strictly speaking the allocation factors do not need to be 
+             !  calculated because the functional allocation scheme allocates 
+             !  absolute amounts of carbon. Hence, Cl_inc could simply be 
+             !  added to biomass(:,:,ileaf,icarbon), Cr_inc to 
+             !  biomass(:,:,iroot,icarbon), etc. However, using allocation 
+             !  factors bears some elegance in respect to distributing the 
+             !  growth respiration if this would be required. Further it 
+             !  facilitates comparison to the resource limited allocation 
+             !  scheme (stomate_growth_res_lim.f90) and it comes in handy 
+             !  for model-data comparison. This allocation takes place at 
+             !  the tree level - note that ::biomass is the only prognostic 
+             !  variable from the tree-based allocation
+
+             !  Allocation   
+             Cl_inc(:) = MAX(zero, circ_class_n(ipts,j,:) * Cl_inc(:))
+             Cr_inc(:) = MAX(zero, circ_class_n(ipts,j,:) * Cr_inc(:))
+             Cs_inc(:) = MAX(zero, circ_class_n(ipts,j,:) * Cs_inc(:))
+             Cf_inc(:) = MAX(zero, circ_class_n(ipts,j,:) * Cf_inc(:))
+
+             ! Total_inc is based on the updated Cl_inc, Cr_inc, Cs_inc and Cf_inc. Therefore, do not multiply
+             ! circ_class_n(ipts,j,:) again
+             total_inc = SUM(Cf_inc(:) + Cl_inc(:) + Cs_inc(:) + Cr_inc(:))
+             !write(*,*) 'total_inc',total_inc
+             ! Relative allocation
+             IF ( total_inc .GT. min_stomate ) THEN
+                ! yitong explain cx_inc is ratio!
+                Cl_inc(:) = Cl_inc(:) / total_inc
+                Cs_inc(:) = Cs_inc(:) / total_inc
+                Cr_inc(:) = Cr_inc(:) / total_inc
+                Cf_inc(:) = Cf_inc(:) / total_inc
+
+             ELSE
+
+                bm_alloc_tot(ipts,j) = zero
+                Cl_inc(:) = zero
+                Cs_inc(:) = zero
+                Cr_inc(:) = zero
+                Cf_inc(:) = zero
+
+             ENDIF
+
+
+             !! 5.2.13 Convert allocation to allocation facors
+             !  Convert allocation of individuals to ORCHIDEE's allocation 
+             !  factors - see comment for 5.2.5. Aboveground sapwood 
+             !  allocation is age dependent in trees. ::alloc_min and 
+             !  ::alloc_max must range between 0 and 1. 
+             alloc_sap_above = alloc_min(j) + ( alloc_max(j) - alloc_min(j) ) * &
+                  ( 1. - EXP( -age(ipts,j) / demi_alloc(j) ) )
+
+             ! Leaf, wood, root and fruit allocation
+             f_alloc(ipts,j,ileaf) = SUM(Cl_inc(:))
+             f_alloc(ipts,j,isapabove) = SUM(Cs_inc(:)*alloc_sap_above)
+             f_alloc(ipts,j,isapbelow) = SUM(Cs_inc(:)*(1.-alloc_sap_above))
+             f_alloc(ipts,j,iroot) = SUM(Cr_inc(:))
+             f_alloc(ipts,j,ifruit) = SUM(Cf_inc(:))
+
+             ! Absolute allocation at the tree level and for an individual tree (gC tree-1)
+             ! The labile and reserve pools are not allocated at the tree level. However,
+             ! stand level ilabile and icarbres biomass will be redistributed at the tree
+             ! level later in this subroutine. This is done after the relative allocation
+             ! beacuse now ::alloc_sap_above is known
+             circ_class_biomass(ipts,j,:,ileaf,icarbon) = &
+                  circ_class_biomass(ipts,j,:,ileaf,icarbon) + &
+                  ( Cl_inc(:) * total_inc / circ_class_n(ipts,j,:) )
+             circ_class_biomass(ipts,j,:,isapabove,icarbon) = &
+                  circ_class_biomass(ipts,j,:,isapabove,icarbon) + &
+                  ( Cs_inc(:) * alloc_sap_above * total_inc / &
+                  circ_class_n(ipts,j,:) )
+             circ_class_biomass(ipts,j,:,isapbelow,icarbon) = &
+                  circ_class_biomass(ipts,j,:,isapbelow,icarbon) + &
+                  ( Cs_inc(:) * (un - alloc_sap_above) * &
+                  total_inc / circ_class_n(ipts,j,:) )
+             circ_class_biomass(ipts,j,:,iroot,icarbon) = &
+                  circ_class_biomass(ipts,j,:,iroot,icarbon) + &
+                  ( Cr_inc(:) * total_inc / circ_class_n(ipts,j,:) )
+             circ_class_biomass(ipts,j,:,ifruit,icarbon) = &
+                  circ_class_biomass(ipts,j,:,ifruit,icarbon) + &
+                  ( Cf_inc(:) * total_inc / circ_class_n(ipts,j,:) )
+
+             ! 20210503yyt
+             circ_class_gains(ipts,j,:)=Cl_inc(:) * total_inc + Cs_inc(:) * alloc_sap_above * total_inc + Cf_inc(:) * total_inc
+             circ_class_leafgains(ipts,j,:)=Cl_inc(:) * total_inc
+             circ_class_sapgains(ipts,j,:)=Cs_inc(:) * alloc_sap_above * total_inc
+                !+++TEMP+++
+             IF (ld_alloc) THEN
+                tempi = zero
+                DO icirc = 1,ncirc
+                   IF ( Cl_inc(icirc) .LT. zero) THEN
+                      WRITE(numout,*) 'Cl_inc, ', j, Cl_inc(icirc)
+                      tempi = un
+                   ENDIF
+                   IF ( Cs_inc(icirc) * alloc_sap_above .LT. zero) THEN
+                      WRITE(numout,*) 'Cs_inc aboveground, ', j, &
+                           Cs_inc(icirc) * alloc_sap_above
+                      tempi = un
+                   ENDIF
+                   IF ( Cs_inc(icirc) * (un - alloc_sap_above) .LT. zero) THEN
+                      WRITE(numout,*) 'Cs_inc aboveground, ', j, &
+                           Cs_inc(icirc) * (un-alloc_sap_above)
+                      tempi = un
+                   ENDIF
+                   IF ( Cr_inc(icirc) .LT. zero) THEN
+                      WRITE(numout,*) 'Cr_inc, ', j, Cr_inc(icirc)
+                      tempi = un
+                   ENDIF
+                   IF ( Cf_inc(icirc) .LT. zero) THEN
+                      WRITE(numout,*) 'Cf_inc, ', j, Cf_inc(icirc)
+                      tempi = un
+                   ENDIF
+                   IF ( total_inc .LT. zero) THEN
+                      WRITE(numout,*) 'total_inc, ', j, total_inc
+                      tempi = un
+                   ENDIF
+                   IF ( circ_class_n(ipts,j,icirc) .LT. zero) THEN
+                      WRITE(numout,*) 'circ_class_n, ', j, circ_class_n(ipts,j,icirc)
+                      tempi = un
+                   ENDIF
+                ENDDO
+                IF (tempi == un) CALL ipslerr_p (3,'growth_fun_all',&
+                     'WARNING 11bis: the solution has negative values',&
+                     'None of these variables should be negative','')   
+             ENDIF
+             !++++++++++
+
+          ELSEIF (is_tree(j)) THEN
+       
+             IF(ld_alloc) WRITE(numout,*) 'there is no tree biomass to allocate, PFT, ', j 
+
+          ENDIF ! Is there biomass to allocate (Â§5.2 - far far up)
+
+
+          !! 5.3 Calculate allocated biomass pools for grasses and crops
+          !  Only possible if there is biomass to allocate
+          IF ( .NOT. is_tree(j) .AND. bm_alloc_tot(ipts,j) .GT. min_stomate ) THEN
+
+             !! 5.3.1 Scaling factor to convert variables to the individual plant
+             !  Allocation is on an individual basis (gC ind-1). Stand-level variables 
+             !  need to convert to a single individual. The absence of sapwood makes 
+             !  this irrelevant because the allocation reduces to a linear function 
+             !  (contrary to the non-linearity of tree allocation). For the
+             !  beauty of consistency, the transformations will be implemented.
+             !  Different approach between the DGVM and statitic approach
+             IF (control%ok_dgvm) THEN
+
+                ! The DGVM does NOT work with the functional allocation. Consider
+                ! this code as a placeholder. The original code had two different 
+                ! transformations to calculate the scalars. Both could be used but 
+                ! the units will differ. For consistency only one was retained 
+                ! scal = ind(ipts,j) * cn_ind(ipts,j) / veget_max(ipts,j)
+                scal = veget_max(ipts,j) / ind(ipts,j)
+
+             ELSE
+
+                ! By dividing the actual biomass by the number of individuals
+                ! the biomass of an individual is obtained. Note that a grass/crop 
+                ! individual was defined as 1m-2 of vegetation 
+                scal = 1./ ind(ipts,j)
+
+             ENDIF
+
+
+             !! 5.3.2 Current biomass pools per grass/crop (gC ind^-1)
+             !  Cs has too many dimensions for grass/crops. To have a consistent notation the same variables
+             !  are used as for trees but the dimension of Cs, Cl and Cr i.e. ::ncirc should be ignored            
+             Cs(:) = biomass(ipts,j,isapabove,icarbon) * scal
+             Cr(:) = biomass(ipts,j,iroot,icarbon) * scal
+             Cl(:) = biomass(ipts,j,ileaf,icarbon) * scal
+             Ch(:) = zero
+
+             ! Total amount of carbon that needs to be allocated (::bm_alloc_tot). bm_alloc_tot is
+             ! in gC m-2 day-1. At 1 m2 there are ::ind number of grasses.
+             b_inc_tot = bm_alloc_tot(ipts,j)
+
+             !! 5.3.3 C-allocation for crops and grasses
+             !  The mass conservation equations are detailed in the header of this subroutine.
+             !  The scheme assumes a functional relationships between leaves and roots for grasses and crops. 
+             !  When carbon is added to the leaf biomass pool, an increase in the root biomass is to be 
+             !  expected to sustain water transport from the roots to the leaves.
+
+             !! 5.3.3.1 Do the biomass pools respect the pipe model?
+             !  Do the current leaf, sapwood and root components respect the allometric 
+             !  constraints? Calculate the optimal root and leaf mass, given the current wood mass 
+             !  by using the basic allometric relationships. Calculate the optimal sapwood
+             !  mass as a function of the current leaf and root mass.
+             Cl_target(1) = MAX( Cs(1) * KF(ipts,j) , Cr(1) * LF(ipts,j), Cl(1) )
+             Cs_target(1) = MAX( Cl_target(1) / KF(ipts,j), Cr(1) * LF(ipts,j) / KF(ipts,j), Cs(1) ) 
+             Cr_target(1) = MAX( Cl_target(1) / LF(ipts,j), Cs_target(1) * KF(ipts,j) / LF(ipts,j), Cr(1) )
+             
+             ! Write debug comments to output file
+             IF (j .EQ. test_pft .AND. ld_alloc) THEN
+                WRITE(numout,*) 'bm_alloc_tot, ',bm_alloc_tot(ipts,j)
+                WRITE(numout,*) 'Does the grass/crop needs reshaping?'
+                WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
+                WRITE(numout,*) 'qm_height, ', (Cl_target(1) * sla(j) * lai_to_height(j))
+                WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(1)-Cl(1), Cl_target(1), Cl(1)
+                WRITE(numout,*) 'Cs_target-Cs, ', Cs_target(1)-Cs(1), Cs_target(1), Cs(1)
+                WRITE(numout,*) 'Cr_target-Cr, ', Cr_target(1)-Cr(1), Cr_target(1), Cr(1)
+             ENDIF
+
+
+             !! 5.3.3.2 Phenological growth
+             !  Phenological growth and reshaping of the grass/crop in line with the pipe model. Turnover removes 
+             !  C from the different plant components but at a component-specific rate, as such the allometric 
+             !  constraints are distorted at every time step and should be restored before ordinary growth can 
+             !  take place
+
+             !! 5.3.3.2.1 The available structural C can sustain the available leaves and roots
+             !  Calculate whether the structural c is in allometric balance. The target values should 
+             !  always be larger than the current pools so the use of ABS is redundant but was used to 
+             !  be on the safe side (here and in the rest of the module) as it could help to find 
+             !  logical flaws.        
+             IF ( ABS(Cs_target(1) - Cs(1)) .LT. min_stomate ) THEN
+
+                Cs_incp(1) = MAX(zero, Cs_target(1) - Cs(1))
+
+                ! Enough leaves and structural biomass, only grow roots
+                IF ( ABS(Cl_target(1) - Cl(1))  .LT. min_stomate ) THEN
+
+                   ! Allocate at the tree level to restore allometric balance
+                   Cl_incp(1) = MAX(zero, Cl_target(1) - Cl(1))
+                   Cr_incp(1) = MAX( MIN(b_inc_tot / ind(ipts,j) - Cs_incp(1) - Cl_incp(1), &
+                        Cr_target(1) - Cr(1)), zero )
+
+                   ! Write debug comments to output file
+                   IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                      CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
+                           b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
+                           grow_wood, circ_class_n, ind, 12)
+                   ENDIF
+
+                ! Sufficient structural C and roots, allocate C to leaves
+                ELSEIF ( ABS(Cr_target(1) - Cr(1)) .LT. min_stomate ) THEN
+
+                   ! Allocate at the tree level to restore allometric balance 
+                   Cr_incp(1) = MAX(zero, Cr_target(1) - Cr(1))
+                   Cl_incp(1) = MAX( MIN(b_inc_tot / ind(ipts,j) - Cs_incp(1) - Cr_incp(1), &
+                        Cl_target(1) - Cl(1)), zero )
+
+                   ! Update vegetation height
+                   qm_height = (Cl(1) + Cl_incp(1)) * sla(j) * lai_to_height(j)
+               
+                   ! Write debug comments to output file
+                   IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                      CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
+                           b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
+                           grow_wood, circ_class_n, ind, 13)
+                   ENDIF
+
+                ! Both leaves and roots are needed to restore the allometric relationships
+                ELSEIF ( ABS(Cl_target(1) - Cl(1)) .GT. min_stomate .AND. &
+                     ABS(Cr_target(1) - Cr(1)) .GT. min_stomate ) THEN                 
+
+                   ! Allocate at the tree level to restore allometric balance
+                   !  The equations can be rearanged and written as
+                   !  (i) b_inc = Cl_inc + Cr_inc
+                   !  (ii) Cr_inc = (Cl_inc+Cl)/LF - Cr
+                   !  Substitue (ii) in (i) and solve for Cl_inc
+                   !  <=> Cl_inc = (LF*(b_inc+Cr)-Cl)/(1+LF)
+                   Cl_incp(1) = MIN( ((LF(ipts,j) * ((b_inc_tot/ind(ipts,j)) - Cs_incp(1) + Cr(1))) - Cl(1)) / & 
+                        (1 + LF(ipts,j)), Cl_target(1) - Cl(1) )
+                   Cr_incp(1) = MIN ( ((Cl_incp(1) + Cl(1)) / LF(ipts,j)) - Cr(1), &
+                        Cr_target(1) - Cr(1))
+
+                   ! The imbalance between Cr and Cl can be so big that (Cl+Cl_inc)/LF is still less
+                   ! then the available root carbon (observed!). This would result in a negative Cr_incp
+                   IF ( Cr_incp(1) .LT. zero ) THEN
+
+                      Cl_incp(1) = MIN( b_inc_tot/ind(ipts,j) - Cs_incp(1), Cl_target(1) - Cl(1) )
+                      Cr_incp(1) = b_inc_tot/ind(ipts,j) - Cs_incp(1) - Cl_incp(1)
+
+                   ELSEIF (Cl_incp(1) .LT. zero) THEN
+
+                      Cr_incp(1) = MIN( b_inc_tot/ind(ipts,j) - Cs_incp(1), Cr_target(1) - Cr(1) )
+                      Cl_incp(1) = (b_inc_tot/ind(ipts,j)) - Cs_incp(1) - Cr_incp(1)
+
+                   ENDIF
+
+                   ! Update vegetation height
+                   qm_height = (Cl(1) + Cl_incp(1)) * sla(j) * lai_to_height(j)
+
+                   ! Write debug comments to output file
+                   IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                      CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
+                           b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
+                           grow_wood, circ_class_n, ind, 14)
+                   ENDIF    
+
+                ELSE
+
+                   WRITE(numout,*) 'WARNING 12: Exc 1-3 unexpected exception'
+                   WRITE(numout,*) 'WARNING 12: PFT, ipts: ',j,ipts
+                   IF(ld_stop)THEN
+                      CALL ipslerr_p (3,'growth_fun_all',&
+                          'WARNING 12: Exc 1-3 unexpected exception','','') 
+                   ENDIF
+
+                ENDIF
+
+
+             !! 5.3.3.3.2 Enough leaves to sustain the structural C and roots
+             ELSEIF ( ABS(Cl_target(1) - Cl(1)) .LT. min_stomate ) THEN
+                
+                Cl_incp(1) = MAX(zero, Cl_target(1) - Cl(1))
+
+                ! Enough leaves and structural C, only grow roots
+                ! This duplicates Exc 1 and these lines should never be called 
+                IF ( ABS(Cs_target(1) - Cs(1)) .LT. min_stomate ) THEN
+
+                   ! Allocate at the tree level to restore allometric balance
+                   Cs_incp(1) = MAX(zero, Cs_target(1) - Cs(1))
+                   Cr_incp(1) = MAX( MIN(b_inc_tot/ind(ipts,j) - Cl_incp(1) - Cs_incp(1), &
+                        Cr_target(1) - Cr(1)), zero )
+
+                   ! Write debug comments to output file 
+                   IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                      CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
+                           b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
+                           grow_wood, circ_class_n, ind, 15)
+                   ENDIF 
+
+                ! Enough leaves and roots. Need to grow structural C to support the available canopy and roots
+                ELSEIF ( ABS(Cr_target(1) - Cr(1)) .LT. min_stomate ) THEN
+
+                   Cr_incp(1) = MAX(zero, Cr_target(1) - Cr(1))
+                   Cs_incp(1) = MAX( MIN(b_inc_tot/ind(ipts,j) - Cr_incp(1) - Cl_incp(1), &
+                        Cs_target(1) - Cs(1)), zero )
+
+                   ! Write debug comments to output file 
+                   IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                      CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
+                           b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
+                           grow_wood, circ_class_n, ind, 16)
+                   ENDIF                  
+
+                ! Need both structural C and roots to restore the allometric relationships
+                ELSEIF ( ABS(Cs_target(1) - Cs(1) ) .GT. min_stomate .AND. &
+                     ABS(Cr_target(1) - Cr(1)) .GT. min_stomate ) THEN
+
+                   !  First try if we can simply satisfy the allocation needs
+                   IF (Cs_target(1) - Cs(1) + Cr_target(1) - Cr(1) .LE. &
+                           b_inc_tot/ind(ipts,j) - Cl_incp(1)) THEN
+                         
+                         Cr_incp(1) = Cr_target(1) - Cr(1)
+                         Cs_incp(1) = Cs_target(1) - Cs(1)
+
+                      ! Try to satisfy the need for the roots
+                      ELSEIF (Cr_target(1) - Cr(1) .LE. b_inc_tot/ind(ipts,j) - Cl_incp(1)) THEN
+
+                         Cr_incp(1) = Cr_target(1) - Cr(1)
+                         Cs_incp(1) = b_inc_tot/ind(ipts,j) - Cl_incp(1) - Cr_incp(1)
+                         
+
+                      ! There is not enough use whatever is available
+                      ELSE
+                         
+                         Cr_incp(1) = b_inc_tot/ind(ipts,j) - Cl_incp(1)
+                         Cs_incp(1) = zero
+                         
+                      ENDIF
+
+                   ! Write debug comments to output file 
+                   IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                      CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
+                           b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
+                           grow_wood, circ_class_n, ind, 17)
+                   ENDIF 
+
+                ELSE
+
+                   WRITE(numout,*) 'WARNING 13: Exc 4-6 unexpected exception'
+                   WRITE(numout,*) 'WARNING 13: PFT, ipts: ',j,ipts
+                   IF(ld_stop)THEN
+                      CALL ipslerr_p (3,'growth_fun_all',&
+                           'WARNING 13: Exc 4-6 unexpected exception','','')
+                   ENDIF
+
+                ENDIF
+
+
+             !! 5.3.3.3.3 Enough roots to sustain the wood and leaves
+             ELSEIF ( ABS(Cr_target(1) - Cr(1)) .LT. min_stomate ) THEN
+
+                Cr_incp(1) = MAX(zero, Cr_target(1) - Cr(1)) 
+
+                ! Enough roots and wood, only grow leaves
+                ! This duplicates Exc 2 and these lines should thus never be called 
+                IF ( ABS(Cs_target(1) - Cs(1)) .LT. min_stomate ) THEN
+
+                   ! Allocate at the tree level to restore allometric balance
+                   Cs_incp(1) = MAX(zero, Cs_target(1) - Cs(1)) 
+                   Cl_incp(1) = MAX( MIN(b_inc_tot/ind(ipts,j) - Cr_incp(1) - Cs_incp(1), &
+                        Cl_target(1) - Cl(1)), zero )
+
+                   ! Update vegetation height
+                   qm_height = (Cl(1) + Cl_incp(1)) * sla(j) * lai_to_height(j)
+
+                   ! Write debug comments to output file 
+                   IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                      CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
+                           b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
+                           grow_wood, circ_class_n, ind, 18)
+                   ENDIF 
+
+                ! Enough leaves and roots. Need to grow sapwood to support the available canopy and roots
+                ! Duplicates Exc. 4 and these lines should thus never be called 
+                ELSEIF ( ABS(Cl_target(1) - Cl(1)) .LT. min_stomate ) THEN
+
+                   ! Allocate at the tree level to restore allometric balance
+                   Cl_incp(1) = MAX(zero, Cl_target(1) - Cl(1)) 
+                   Cs_incp(1) = MAX( MIN(b_inc_tot/ind(ipts,j) - Cr_incp(1) - Cl_incp(1), &
+                        Cs_target(1) - Cs(1) ), zero )
+
+                   ! Write debug comments to output file 
+                   IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                      CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
+                           b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
+                           grow_wood, circ_class_n, ind, 19)
+                   ENDIF                       
+
+                ! Need both wood and leaves to restore the allometric relationships
+                ELSEIF ( ABS(Cs_target(1) - Cs(1)) .GT. min_stomate .AND. &
+                     ABS(Cl_target(1) - Cl(1)) .GT. min_stomate ) THEN
+
+                   ! circ_class_ba_eff and circ_class_height_eff are already calculated
+                   ! for a tree in balance. It would be rather complicated to follow
+                   ! the allometric rules for wood allocation (implying changes in height 
+                   ! and basal area) because the tree is not in balance.First try if we 
+                   ! can simply satisfy the allocation needs
+                   IF (Cs_target(1) - Cs(1) + Cl_target(1) - Cl(1) .LE. &
+                        b_inc_tot/ind(ipts,j) - Cr_incp(1)) THEN
+                      
+                      Cl_incp(1) = Cl_target(1) - Cl(1)
+                      Cs_incp(1) = Cs_target(1) - Cs(1)
+                      
+                   ! Try to satisfy the need for leaves
+                   ELSEIF (Cl_target(1) - Cl(1) .LE. b_inc_tot/ind(ipts,j) - Cr_incp(1)) THEN
+
+                      Cl_incp(1) = Cl_target(1) - Cl(1)
+                      Cs_incp(1) = b_inc_tot/ind(ipts,j) - Cr_incp(1) - Cl_incp(1)
+
+                   ! There is not enough use whatever is available
+                   ELSE
+
+                      Cl_incp(1) = b_inc_tot/ind(ipts,j) - Cr_incp(1)
+                      Cs_incp(1) = zero
+                      
+                   ENDIF
+                      
+                   ! Calculate the height of the expanded canopy
+                   qm_height(ipts,j) = (Cl(1) + Cl_inc(1)) * sla(j) * lai_to_height(j)
+
+                   ! Write debug comments to output file 
+                   IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                      CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
+                           b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
+                           grow_wood, circ_class_n, ind, 20)
+                   ENDIF
+
+                ELSE
+
+                   WRITE(numout,*) 'WARNING 14: Exc 7-9 unexpected exception'
+                   WRITE(numout,*) 'WARNING 14: PFT, ipts: ',j, ipts
+                   IF(ld_stop)THEN
+                      CALL ipslerr_p (3,'growth_fun_all',&
+                           'WARNING 14: Exc 7-9 unexpected exception','','')
+                   ENDIF
+
+                ENDIF
+
+             ! Either Cl_target, Cs_target or Cr_target should be zero
+             ELSE
+
+                ! Something possibly important was overlooked
+                WRITE(numout,*) 'WARNING 15: Logical flaw in phenological allocation '
+                WRITE(numout,*) 'WARNING 15: PFT, ipts: ',j, ipts
+                WRITE(numout,*) 'Cs - Cs_target', Cs(1), Cs_target(1)
+                WRITE(numout,*) 'Cl - Cl_target', Cl(1), Cl_target(1)
+                WRITE(numout,*) 'Cr - Cr_target', Cr(1), Cr_target(1)
+                IF(ld_stop)THEN
+                   CALL ipslerr_p (3,'growth_fun_all',&
+                        'WARNING 15: Logical flaw in phenological allocation','','')
+                ENDIF
+
+             ENDIF
+
+
+             !! 5.3.4 Wrap-up phenological allocation
+             IF ( Cl_incp(1) .GE. zero .OR. Cr_incp(1) .GE. zero .OR. Cs_incp(1) .GE. zero) THEN
+
+                ! Fake allocation for less messy equations in next 
+                ! case, incp needs to be added to inc at the end
+                Cl(1) = Cl(1) + Cl_incp(1)
+                Cr(1) = Cr(1) + Cr_incp(1)
+                Cs(1) = Cs(1) + Cs_incp(1)
+                b_inc_tot = b_inc_tot - (ind(ipts,j) * (Cl_incp(1) + Cr_incp(1) + Cs_incp(1)))
+
+             ELSE
+
+                ! The code was written such that the increment pools should be greater than or equal
+                ! to zero. If this is not the case, something fundamental is wrong with the if-then 
+                ! constructs under Â§5.3.3.2
+                WRITE(numout,*) 'WARNING 16: numerical problem, one of the increment pools is less than zero'
+                WRITE(numout,*) 'WARNING 16: Cl_incp(1), Cr_incp(1), Cs_incp(1), j, ipts',&
+                     Cl_incp(1), Cr_incp(1), Cs_incp(1), j, ipts
+                IF(ld_stop)THEN
+                   CALL ipslerr_p (3,'growth_fun_all',&
+                        'WARNING 16: numerical problem, one of the increment pools is less than zero','','')
+                ENDIF
+
+             ENDIF
+
+             ! Height depends on Cl, so update height when Cl gets updated
+             qm_height(ipts,j) = Cl(1) * sla(j) * lai_to_height(j) 
+
+             ! Something is wrong with the calculations
+             IF (b_inc_tot .LT. -min_stomate) THEN
+
+                WRITE(numout,*) 'WARNING 17: numerical problem overspending in the phenological allocation'
+                WRITE(numout,*) 'WARNING 17: b_inc_tot, j, ipts',b_inc_tot, j, ipts 
+                WRITE(numout,*) 'WARNING 17: Cl_incp, Cr_incp, Cs_incp, ', Cl_incp(1), Cr_incp(1), Cs_incp(1)
+                IF(ld_stop)THEN
+                    CALL ipslerr_p (3,'growth_fun_all',&
+                         'WARNING 17: numerical problem overspending in the phenological allocation','','')
+                ENDIF
+
+             ENDIF
+
+    
+             !! 5.3.5 Calculate the expected size of the reserve pool 
+             !  use the minimum of either (1) 20% of the total sapwood biomass or 
+             !  (2) the amount of carbon needed to develop the optimal LAI and the roots
+             !  This reserve pool estimate is only used to decide whether wood should be
+             !  grown or not. When really dealing with the reserves the reserve pool is 
+             !  recalculated. See further below Â§7.1.
+
+             !+++CHECK+++
+             ! Sapwood has no meaning for grasses and crops - reserves should sustain the canopy
+             ! For trees 2% was used, given the much lower sapwood pool for grasses and crops we 
+             ! set it arbitrairly to 10%
+             reserve_pool = MIN( 0.10 * ( biomass(ipts,j,isapabove,icarbon) + &
+                  biomass(ipts,j,isapbelow,icarbon)), lai_target(ipts,j)/sla(j)*&
+                  (1.+0.3/ltor(ipts,j)) )
+             !+++++++++++
+             grow_wood = .TRUE.
+
+             ! If the carbohydrate pool is too small, don't grow structural C and 
+             ! thus skip ordinary allocation
+             IF ( (pheno_type(j) .NE. 1) .AND. &
+                  (biomass(ipts,j,icarbres,icarbon) .LE. reserve_pool) ) THEN
+
+                grow_wood = .FALSE.
+
+             ENDIF
+
+             ! Write debug comments to output file 
+             IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, &
+                     delta_ba, ipts, j, l, b_inc_tot, Cl_incp, Cs_incp, Cr_incp, &
+                     KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, grow_wood, &
+                     circ_class_n, ind, 21)
+             ENDIF
+
+
+             !! 5.3.6 Ordinary growth
+             !  Allometric relationship between components is respected, sustain 
+             !  ordinary growth and allocate biomass to leaves, wood, roots and fruits.
+             IF ( (ABS(Cl_target(1) - Cl(1) ) .LE. min_stomate) .AND. &
+                  (ABS(Cs_target(1) - Cs(1) ) .LE. min_stomate) .AND. &
+                  (ABS(Cr_target(1) - Cr(1) ) .LE. min_stomate) .AND. &
+                  (grow_wood) .AND. (b_inc_tot/ind(ipts,j) .GT. min_stomate) ) THEN 
+
+                ! Allocate fraction of carbon to fruit production (at the tree level)
+                Cf_inc(:) = b_inc_tot * fruit_alloc(j)
+
+                ! Residual carbon is allocated to the other components (b_inc_tot is 
+                ! at the stand level)
+                b_inc_tot = b_inc_tot * (1-fruit_alloc(j))
+
+                ! Following allometric allocation
+                ! (i) b_inc = Cl_inc + Cr_inc + Cs_inc
+                ! (ii) Cr_inc = (Cl + Cl_inc)/LF - Cr
+                ! (iii) Cs_inc = (Cl + Cl_inc) / KF - Cs
+                ! Substitue (ii) and (iii) in (i) and solve for Cl_inc 
+                ! <=> b_inc = Cl_inc + ( Cl_inc + Cl ) / KF - Cs + ( Cl_inc + Cl ) / LF - Cr
+	        ! <=> b_inc = Cl_inc * ( 1.+ 1/KF + 1./LF ) + Cl/LF - Cs - Cr
+	        ! <=> Cl_inc = ( b_inc - Cl/LF + Cs + Cr ) / ( 1.+ 1/KF + 1./LF )
+                Cl_inc(1) = MAX( (b_inc_tot/ind(ipts,j) - Cl(1)/LF(ipts,j) - &
+                     Cl(1)/KF(ipts,j) + Cs(1) + Cr(1)) / &
+                     (1. + 1./KF(ipts,j) + 1./LF(ipts,j)), zero)
+               
+                IF (Cl_inc(1) .LE. zero) THEN
+
+                   Cr_inc(:) = zero
+                   Cs_inc(:) = zero
+
+                ELSE
+
+                   ! Calculate the height of the expanded canopy
+                   qm_height(ipts,j) = (Cl(1) + Cl_inc(1)) * sla(j) * lai_to_height(j)
+
+                   ! Use the solution for Cl_inc to calculate Cr_inc and Cs_inc according to (ii) and (iii)
+                   Cr_inc(1) = (Cl(1) + Cl_inc(1)) / LF(ipts,j) - Cr(1)                
+                   Cs_inc(1) = (Cl(1)+Cl_inc(1)) / KF(ipts,j) - Cs(1)
+               
+                ENDIF
+
+                ! Write debug comments to output file 
+                IF ((j.EQ.test_pft .AND. ld_alloc) .OR. ld_warn) THEN
+                   CALL comment(npts, Cl_target, Cl, Cs_target, Cs, Cr_target, Cr, delta_ba, ipts, j, l, &
+                        b_inc_tot, Cl_incp, Cs_incp, Cr_incp, KF, LF, Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
+                        grow_wood, circ_class_n, ind, 22)
+                ENDIF
+                
+                ! Wrap-up ordinary growth  
+                ! Calculate C that was not allocated, note that Cf_inc was already substracted
+                b_inc_tot = b_inc_tot - (ind(ipts,j) * (Cl_inc(1) + Cr_inc(1) + Cs_inc(1)))
+
+                !---TEMP---
+                IF (j.EQ.test_pft .AND. ld_alloc) THEN
+                   WRITE(numout,*) 'wrap-up ordinary allocation, left b_in_tot, ', b_inc_tot 
+                ENDIF
+                !----------
+
+
+             !! 5.3.7 Don't grow wood, use C to fill labile pool
+             ELSEIF ( (.NOT. grow_wood) .AND. (b_inc_tot .GT. min_stomate) ) THEN
+
+                ! Calculate the C that needs to be distributed to the 
+                ! labile pool. The fraction is proportional to the ratio 
+                ! between the total allocatable biomass and the unallocated 
+                ! biomass per tree (b_inc now contains the unallocated 
+                ! biomass). At the end of the allocation scheme bm_alloc_tot 
+                ! is substracted from the labile biomass pool to update the 
+                ! biomass pool (biomass(:,:,ilabile) = biomass(:,:,ilabile) - 
+                ! bm_alloc_tot(:,:)). At that point, the scheme puts the 
+                ! unallocated b_inc into the labile pool. What we 
+                ! want is that the unallocated fraction is removed from 
+                ! ::bm_alloc_tot such that only the allocated C is removed 
+                ! from the labile pool. b_inc_tot will be moved back into
+                ! the labile pool in 5.2.11
+                bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) - b_inc_tot
+                biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) + &
+                     b_inc_tot
+                                
+                ! Wrap-up ordinary growth  
+                ! Calculate C that was not allocated (b_inc_tot), the 
+                ! equation should read b_inc_tot = b_inc_tot - b_inc_tot 
+                ! note that Cf_inc was already substracted
+                b_inc_tot = zero 
+
+                !---TEMP---
+               ! IF (j.EQ.test_pft .AND. ld_alloc) THEN
+                   WRITE(numout,*) 'No wood growth, move remaining C to labile pool'
+                   WRITE(numout,*) 'bm_alloc_tot_new, ',bm_alloc_tot(ipts,j)
+                   WRITE(numout,*) 'wrap-up ordinary allocation, left b_inc_tot, ', b_inc_tot 
+               ! ENDIF
+                !---------- 
+
+             !! 5.3.8 Error - the allocation scheme is overspending 
+             ELSEIF (b_inc_tot .LE. min_stomate) THEN  
+      
+                IF (b_inc_tot .LT. -min_stomate) THEN
+
+                   ! Something is wrong with the calculations
+                   WRITE(numout,*) 'WARNING 18: numerical problem overspending in ordinary allocation'
+                   WRITE(numout,*) 'WARNING 18: PFT, ipts, b_inc_tot: ', j, ipts,b_inc_tot
+                   IF(ld_stop)THEN
+                      CALL ipslerr_p (3,'growth_fun_all',&
+                           'WARNING 18: numerical problem overspending in ordinary allocation','','')
+                   ENDIF
+
+                ELSE
+
+!                   IF (j .EQ. test_pft .AND. ld_alloc) THEN
+                      ! Succesful allocation
+                      WRITE(numout,*) 'Successful allocation'
+!                   ENDIF
+
+                ENDIF
+              
+                ! Althought the biomass components respect the allometric relationships, there
+                ! is no carbon left to allocate                      
+                b_inc_tot = zero
+                Cl_inc(1) = zero
+                Cs_inc(1) = zero
+                Cr_inc(1) = zero
+                Cf_inc(1) = zero
+
+             ELSE
+
+                WRITE(numout,*) 'WARNING 19: Logical flaw unexpected result in ordinary allocation'
+                WRITE(numout,*) 'WARNING 19: PFT, ipts: ', j, ipts
+                WRITE(numout,*) 'WARNING 19: ',ABS(Cl_target(1) - Cl(1) ) , Cl(1)
+                WRITE(numout,*) 'WARNING 19: ',ABS(Cs_target(1) - Cs(1) )  , Cs(1)
+                WRITE(numout,*) 'WARNING 19: ',ABS(Cr_target(1) - Cr(1) )  , Cr(1)
+                WRITE(numout,*) 'WARNING 19: ',grow_wood
+                WRITE(numout,*) 'WARNING 19: ',b_inc_tot,ind(ipts,j),b_inc_tot/ind(ipts,j)
+                IF(ld_stop)THEN
+                   CALL ipslerr_p (3,'growth_fun_all',&
+                        'WARNING 19: Logical flaw unexpected result in ordinary allocation','','')
+                ENDIF
+                
+             ENDIF ! Ordinary allocation
+
+
+             !! 5.3.9 Forced allocation
+             !  Although this should not happen, in case the functional allocation did not consume 
+             !  all the allocatable carbon, the remaining C is left for the next day, and some of 
+             !  the biomass is used to produce fruits (tuned)
+             IF ( b_inc_tot .GT. min_stomate ) THEN 
+
+                WRITE(numout,*) 'WARNING 20: unexpected outcome force allocation'
+                WRITE(numout,*) 'WARNING 20: grow_wood, b_inc_tot: ', grow_wood, b_inc_tot
+                WRITE(numout,*) 'WARNING 20: PFT, ipts: ',j,ipts
+                IF(ld_stop)THEN
+                   CALL ipslerr_p (3,'growth_fun_all',&
+                        'WARNING 20: unexpected outcome force allocation','','')
+                ENDIF
+
+                !+++CHECK+++
+!!$                ! Calculate fraction that will be allocated to fruit. The fraction is proportional to the 
+!!$                ! ratio between the total allocatable biomass and the unallocated biomass per tree
+!!$                frac = 0.1 * MIN(1., bm_alloc_tot(ipts,j) / b_inc_tot)
+!!$                Cf_inc(:) = Cf_inc(:) + b_inc_tot * frac
+!!$                b_inc_tot = b_inc_tot * (1 - frac)
+!!$
+!!$                ! Calculate the C that needs to be distributed to the labile pool. The fraction is proportional 
+!!$                ! to the ratio between the total allocatable biomass and the unallocated biomass per tree (b_inc 
+!!$                ! now contains the unallocated biomass). At the end of the allocation scheme bm_alloc_tot is 
+!!$                ! substracted from the labile biomass pool to update the biomass pool (biomass(:,:,ilabile) = 
+!!$                ! biomass(:,:,ilabile,icarbon) - bm_alloc_tot(:,:)). At that point, the scheme puts the 
+!!$                ! unallocated b_inc into the labile pool. 
+!!$                bm_alloc_tot(ipts,j) = bm_alloc_tot(ipts,j) * ( 1. - (1.-frac) * b_inc_tot / bm_alloc_tot(ipts,j) )
+                !++++++++++
+
+             ELSEIF ( (b_inc_tot .LT. min_stomate) .AND. (b_inc_tot .GE. -min_stomate) ) THEN
+
+                ! Successful allocation
+                !---TEMP---
+                IF (j.EQ.test_pft .AND. ld_alloc) THEN
+                   WRITE(numout,*) 'Successful allocation'
+                ENDIF
+                !----------
+
+             ELSE
+
+                ! Something possibly important was overlooked
+                IF ( (b_inc_tot .LT. 100*min_stomate) .AND. (b_inc_tot .GE. -100*min_stomate) ) THEN
+                   IF (j.EQ.test_pft .AND. ld_alloc) THEN
+                      WRITE(numout,*) 'Marginally successful allocation - precision is better than 10-6', j
+                   ENDIF
+                ELSE
+                   WRITE(numout,*) 'WARNING 21: Logical flaw unexpected result in ordinary allocation'
+                   WRITE(numout,*) 'WARNING 21: b_inc_tot', b_inc_tot
+                   WRITE(numout,*) 'WARNING 21: PFT, ipts: ',j,ipts
+                   CALL ipslerr_p (3,'growth_fun_all',&
+                        'WARNING 21: Logical flaw unexpected result in ordinary allocation','','')
+                ENDIF
+
+             ENDIF
+
+             ! The second problem we need to catch is when one of the increment pools is 
+             ! negative. This is an undesired outcome (see comment where ::KF_old is 
+             ! calculated in this routine. In that case we write a warning, set all increment
+             ! pools to zero and try it again at the next time step. A likely cause of this 
+             ! problem is a too large change in KF from one time step to another. Try decreasing
+             ! the acceptable value for an absolute increase in KF.
+             IF (Cs_inc(1) .LT. zero .OR. Cr_inc(1) .LT. zero .OR. Cs_inc(1) .LT. zero) THEN
+             
+                ! Do not allocate - save the carbon for the next time step
+                Cl_inc(1) = zero
+                Cr_inc(1) = zero
+                Cs_inc(1) = zero
+                WRITE(numout,*) 'WARNING 22: numerical problem, one of the increment pools is less than zero'
+                WRITE(numout,*) 'WARNING 22: PFT, ipts: ',j,ipts
+               
+             ENDIF
+
+
+             !! 5.3.10 Wrap-up phenological and ordinary allocation
+             Cl_inc(1) = Cl_inc(1) + Cl_incp(1)
+             Cr_inc(1) = Cr_inc(1) + Cr_incp(1)
+             Cs_inc(1) = Cs_inc(1) + Cs_incp(1)
+             residual(ipts,j) = b_inc_tot
+
+             !---TEMP---
+            IF (j.EQ.test_pft .AND. ld_alloc) THEN
+                WRITE(numout,*) 'Final allocation', j 
+                WRITE(numout,*) 'Cl, Cs, Cr', Cl(1), Cs(1), Cr(1) 
+                WRITE(numout,*) 'Cl_incp, Cs_incp, Cr_incp, ', Cl_incp(1), Cs_incp(1), Cr_incp(1)
+                WRITE(numout,*) 'Cl_inc, Cs_ins, Cr_inc, Cf_inc, ', Cl_inc(1), Cs_inc(1), Cr_inc(1), Cf_inc(1)
+                WRITE(numout,*) 'unallocated/residual, ', b_inc_tot
+            ENDIF
+      !       !----------
+            
+
+             !! 5.3.11 Account for the residual
+             !  The residual is usually around ::min_stomate but we deal 
+             !  with it anyway to make sure the mass balance is closed
+             !  and as a way to detect errors. Move the unallocated carbon
+             !  back into the labile pool
+             IF (biomass(ipts,j,ilabile,icarbon) + residual(ipts,j) .LE. min_stomate) THEN
+
+                deficit = biomass(ipts,j,ilabile,icarbon) + residual(ipts,j)
+
+                ! The deficit is less than the carbon reserve
+                IF (-deficit .LE. biomass(ipts,j,icarbres,icarbon)) THEN
+
+                   ! Pay the deficit from the reserve pool
+                   biomass(ipts,j,icarbres,icarbon) = &
+                        biomass(ipts,j,icarbres,icarbon) + deficit
+                   biomass(ipts,j,ilabile,icarbon)  = &
+                        biomass(ipts,j,ilabile,icarbon) - deficit
+
+                ELSE
+
+                   ! Not enough carbon to pay the deficit
+                   ! There is likely a bigger problem somewhere in
+                   ! this routine
+                   WRITE(numout,*) 'WARNING 23: PFT, ipts: ',j,ipts
+                   CALL ipslerr_p (3,'growth_fun_all',&
+                        'WARNING 23: numerical problem overspending ',&
+                        'when trying to account for unallocatable C ','')
+
+                ENDIF
+
+             ELSE
+                
+                ! Move the unallocated carbon back into the labile pool
+                biomass(ipts,j,ilabile,icarbon) = &
+                     biomass(ipts,j,ilabile,icarbon) + residual(ipts,j)
+                
+             ENDIF
+
+             !! 5.3.12 Standardise allocation factors
+             !  Strictly speaking the allocation factors do not need to be calculated because the functional
+             !  allocation scheme allocates absolute amounts of carbon. Hence, Cl_inc could simply be added to
+             !  biomass(:,:,ileaf,icarbon), Cr_inc to biomass(:,:,iroot,icarbon), etc. However, using allocation 
+             !  factors bears some elegance in respect to distributing the growth respiration if this would be 
+             !  required. Further it facilitates comparison to the resource limited allocation scheme 
+             !  (stomate_growth_res_lim.f90) and it comes in handy for model-data comparison. This allocation
+             !  takes place at the tree level - note that ::biomass is the only prognostic variable from the tree-based
+             !  allocation
+                          
+             !  Allocation   
+             Cl_inc(1) = MAX(zero, ind(ipts,j) * Cl_inc(1))
+             Cr_inc(1) = MAX(zero, ind(ipts,j) * Cr_inc(1))
+             Cs_inc(1) = MAX(zero, ind(ipts,j) * Cs_inc(1))
+             Cf_inc(1) = MAX(zero, ind(ipts,j) * Cf_inc(1))
+             
+             ! Total_inc is based on the updated Cl_inc, Cr_inc, Cs_inc and Cf_inc. Therefore, do not multiply
+             ! ind(ipts,j) again
+             total_inc = (Cf_inc(1) + Cl_inc(1) + Cs_inc(1) + Cr_inc(1))
+             
+             ! Relative allocation
+             IF ( total_inc .GT. min_stomate ) THEN
+
+                Cl_inc(1) = Cl_inc(1) / total_inc
+                Cs_inc(1) = Cs_inc(1) / total_inc
+                Cr_inc(1) = Cr_inc(1) / total_inc
+                Cf_inc(1) = Cf_inc(1) / total_inc
+
+             ELSE
+
+                bm_alloc_tot(ipts,j) = zero
+                Cl_inc(1) = zero
+                Cs_inc(1) = zero
+                Cr_inc(1) = zero
+                Cf_inc(1) = zero
+
+             ENDIF
+
+ 
+             !! 5.3.13 Convert allocation to allocation facors
+             !  Convert allocation of individuals to ORCHIDEE's allocation factors - see comment for 5.2.5
+             !  Aboveground sapwood allocation is age dependent in trees, but there is only aboveground
+             !  allocation in grasses 
+             alloc_sap_above = un
+
+             ! Leaf, wood, root and fruit allocation
+             f_alloc(ipts,j,ileaf) = Cl_inc(1)
+             f_alloc(ipts,j,isapabove) = Cs_inc(1)*alloc_sap_above
+             f_alloc(ipts,j,isapbelow) = Cs_inc(1)*(1.-alloc_sap_above)
+             f_alloc(ipts,j,iroot) = Cr_inc(1)
+             f_alloc(ipts,j,ifruit) = Cf_inc(1)
+
+          ELSEIF (.NOT. is_tree(j)) THEN 
+       
+             IF(ld_alloc) WRITE(numout,*) 'there is no non-tree biomass to allocate, PFT, ', j
+             f_alloc(ipts,j,ileaf) = zero
+             f_alloc(ipts,j,isapabove) = zero
+             f_alloc(ipts,j,isapbelow) = zero
+             f_alloc(ipts,j,iroot) = zero
+             f_alloc(ipts,j,ifruit) = zero
+  
+          ENDIF ! .NOT. is_tree(j) and there is biomass to allocate (Â§5.3 - far far up)
+
+       ENDDO ! npts
+
+       !! 5.4 Allocate allocatable biomass to different plant compartments
+       !  The amount of allocatable biomass to each compartment is a fraction ::f_alloc of the total 
+       !  allocatable biomass - see comment for 5.2.6
+       DO k = 1, nparts
+
+          bm_alloc(:,j,k,icarbon) = f_alloc(:,j,k) * (bm_alloc_tot(:,j) - residual(:,j))
+
+       ENDDO
+
+       !---TEMP---
+       IF (j .EQ. test_pft .AND. ld_alloc) THEN
+          DO ipts=1,npts
+             IF(test_grid == ipts)THEN
+                WRITE(numout,*) 'bm_alloc_tot(ipts,j), ', j, bm_alloc_tot(ipts,j)
+                WRITE(numout,*) 'f_alloc(ipts,j,:), ', f_alloc(ipts,j,:)
+                WRITE(numout,*) 'residual(ipts,j), ', residual(ipts,j)
+             ENDIF
+          END DO
+       ENDIF
+       !---------- 
+
+    ENDDO ! # End Loop over # of PFTs   
+
+    ! we need to zero the array for PFT 1, since it has not been calculated but it
+    ! is used in implict loops below
+    bm_alloc_tot(:,1) = zero
+    bm_alloc(:,1,:,icarbon) = zero
+
+
+ !! 6. Update the biomass with newly allocated biomass after respiration
+
+    ! Update the biomass pools
+    !---TEMP---
+    IF (ld_alloc) THEN
+       DO ipts=1,npts
+          DO j=1,nvm
+             IF(ipts == test_grid .AND. j == test_pft)THEN
+                WRITE(numout,*) 'biomass, ', biomass(test_grid,test_pft,:,icarbon)
+                WRITE(numout,*) 'bm_alloc, ', bm_alloc(test_grid,test_pft,:,icarbon)
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDIF
+    !---------- 
+    ! I'm putting in a test here to see if we try to allocate
+    ! a negative amount of biomass.  That's a bad thing if we do.
+    DO ipts=1,npts
+       DO j=1,nvm
+          DO ipar=1,nparts
+             IF(j == test_pft .AND. ipts == test_grid)THEN
+                IF(bm_alloc(test_grid,test_pft,ipar,icarbon) .LT. zero)THEN
+                   WRITE(numout,*) 'Trying to allocate negative biomass!'
+                   WRITE(numout,*) 'ipts,j,ipar: ',ipts,j,ipar
+                   WRITE(numout,*) 'bm_alloc(test_grid,test_pft,ipar,icarbon): ',&
+                        bm_alloc(test_grid,test_pft,ipar,icarbon)
+                   IF(ld_stop)THEN
+                       CALL ipslerr_p (3,'growth_fun_all',&
+                            'Trying to allocate negative biomass!','','')
+                   ENDIF
+                ENDIF
+             END IF
+          ENDDO
+       ENDDO
+    ENDDO
+
+    biomass(:,:,:,icarbon) = biomass(:,:,:,icarbon) + bm_alloc(:,:,:,icarbon)
+    
+
+ !! 7. Use or fill reserve pools depending on relative size of the labile and reserve C pool
+
+    ! +++ CHECK +++
+    ! Externalize all the hard coded values i.e. 0.3
+
+    ! Calculate the labile pool for all plants and also the reserve pool for trees      
+    DO j = 2,nvm
+
+       DO ipts = 1,npts
+
+
+          IF (veget_max(ipts,j) .LE. min_stomate) THEN
+
+             ! this vegetation type is not present, so no reason to do the 
+             ! calculation. CYCLE will take us out of the innermost DO loop
+             CYCLE
+
+          ENDIF
+
+          ! There is vegetation present and has started growing. The second and third condition
+          ! required to make the PFT survive the first year during which the long term climate
+          ! variables are initialized for the phenology. If these conditions are not added, the 
+          ! reserves are respired well before growth ever starts
+          IF ( veget_max(ipts,j) .GT. min_stomate .AND. &
+               rue_longterm(ipts,j) .GE. zero .AND. &                  
+               rue_longterm(ipts,j) .NE. un) THEN
+             
+             !! 7.1 Calculate the optimal size of the pools   
+             !  The size of the labile pool is proportional to the assumed activity of living tissues 
+             !  and its relative nitrogen content). The numerical value of ::lab_fac is already a
+             !  tuning variable, the division by 10 (default for ::labile_reserve) stresses the importance 
+             !  of this variable to scale other processes.
+             !+++CHECK+++
+             ! There is an inconsistency in the calculation - most pools are in gN but leaves is in gC
+             ! The correction is proposed, that implies that the parameter labile_reserve will need to 
+             ! be tuned
+!!$          VERSION WITH CONSISTENT UNITS
+!!$             labile_pool = lab_fac(ipts,j)/labile_reserve * &
+!!$                  ( biomass(ipts,j,ileaf,icarbon) / cn_leaf_prescribed(j) + & 
+!!$                  fcn_root(j) * ( biomass(ipts,j,iroot,icarbon) + biomass(ipts,j,ifruit,icarbon) ) + & 
+!!$                  fcn_wood(j) * ( biomass(ipts,j,isapabove,icarbon) + biomass(ipts,j,isapbelow,icarbon) + &
+!!$                  biomass(ipts,j,icarbres,icarbon) ) )
+!!$          ORIGINAL VERSION WITH INCONSISTENT UNITS
+!!$             labile_pool = lab_fac(ipts,j)/labile_reserve * ( biomass(ipts,j,ileaf,icarbon)  + & 
+!!$                  fcn_root(j) * ( biomass(ipts,j,iroot,icarbon) + biomass(ipts,j,ifruit,icarbon) ) + & 
+!!$                  fcn_wood(j) * ( biomass(ipts,j,isapabove,icarbon) + biomass(ipts,j,isapbelow,icarbon) + &
+!!$                  biomass(ipts,j,icarbres,icarbon) ) )
+!!$             labile_pool = MAX ( labile_pool, gpp_to_labile(j) * gpp_week(ipts,j) )
+             
+             ! We had an endless series of problems which were often difficult to
+             ! understand but which always seemed to be related to a sudden drop
+             ! in biomass(ilabile). This drop was often the result of a sudden 
+             ! change in labile_pool. Given that there is not much science behind
+             ! this approach it seems a good idea to remove this max statement to
+             ! avoid sudden changes. Rather than using the actual biomass we propose
+             ! to use the target biomass. This assumes that the tree would like to 
+             ! fill its labile pool to be optimal when it would be in allometric
+             ! balance.
+             IF (is_tree(j)) THEN
+             
+                ! We will make use of the REAL sapwood, heartwood and effective height
+                ! and then calculate the target leaves and roots. This approach gives
+                ! us a target for a labile_pool of a tree in allometric balance. 
+                ! Basal area at the tree level (m2 tree-1)
+                circ_class_ba_eff(:) = wood_to_ba_eff(circ_class_biomass(ipts,j,:,:,icarbon),j)
+
+                ! Current biomass pools per tree (gC tree^-1) 
+                ! We will have different trees so this has to be calculated from the 
+                ! diameter relationships            
+                Cs(:) = ( circ_class_biomass(ipts,j,:,isapabove,icarbon) + &
+                     circ_class_biomass(ipts,j,:,isapbelow,icarbon) ) * scal
+
+                DO l = 1,ncirc 
+
+                   !  Calculate tree height
+                   circ_class_height_eff(l) = pipe_tune2(j)*(4/pi*circ_class_ba_eff(l))**(pipe_tune3(j)/2)
+                   
+                   ! Use the pipe model to calculate the target leaf and root
+                   ! biomasses
+                   Cl_target(l) = KF(ipts,j) * Cs(l) / circ_class_height_eff(l)
+                   Cr_target(l) = Cl_target(l) / LF(ipts,j)
+                   
+                ENDDO
+
+             ! grasses and crops
+             ELSEIF ( .NOT. is_tree(j)) THEN
+             
+                Cs(:) = zero
+                Cl_target(:) = zero 
+                Cr_target(:) = zero
+                ! Current biomass pools per grass/crop (gC ind^-1)
+                ! Cs has too many dimensions for grass/crops. To have a consistent notation the same variables
+                ! are used as for trees but the dimension of Cs, Cl and Cr i.e. ::ncirc should be ignored            
+                Cs(1) = biomass(ipts,j,isapabove,icarbon) * scal
+   
+                ! Use the pipe model to calculate the target leaf and root
+                ! biomasses
+                Cl_target(1) = Cs(1) * KF(ipts,j)
+                Cr_target(1) = Cl_target(1) / LF(ipts,j)
+
+             ENDIF !is_tree
+
+             ! Accounting for the N-concentration of the tissue as a proxy
+             ! of tissue activity
+             labile_pool = lab_fac(ipts,j)/labile_reserve * &
+                  ( SUM(Cl_target(:)) / cn_leaf_prescribed(j) + & 
+                  SUM(Cr_target(:)) * fcn_root(j) + & 
+                  SUM(Cs(:)) * fcn_wood(j) )
+             !+++++++++++
+
+             !+++TEMP+++ 
+             IF (j .EQ. test_pft .AND. ld_alloc) THEN
+                WRITE(numout,*) 'lab_fac, labile pool, 3*gpp_week ', lab_fac(ipts,j), labile_pool, &
+                     gpp_to_labile(j) * gpp_week(ipts,j)
+             ENDIF
+             !++++++++++
+
+             ! The max size of reserve pool is proportional to the size of the storage organ (the sapwood)
+             ! and a the leaf functional trait of the PFT (::phene_type_tab). The reserve pool is 
+             ! constrained by the mass needed to replace foliage and roots. This constraint prevents the
+             ! scheme from putting too much reserves in big trees (which have a lot of sapwood compared to
+             ! small trees). Exessive storage would hamper tree growth and would make mortality less likely.
+             IF(is_tree(j)) THEN
+
+                IF (pheno_type(j).EQ.1) THEN 
+
+                   ! Evergreen trees are not very conservative with respect to C-storage. Therefore, only 5% 
+                   ! of their sapwood mass is stored in their reserve pool.
+                   reserve_pool = MIN(evergreen_reserve * ( biomass(ipts,j,isapabove,icarbon) + &
+                        biomass(ipts,j,isapbelow,icarbon)), lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j)))
+
+                   IF (j .EQ. test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
+                      WRITE(numout,*) 'What happens to the reserve and labile pools? Evergreen'
+                      WRITE(numout,*) 'carbres, reserve_pool: ',&
+                           biomass(ipts,j,icarbres,icarbon),reserve_pool
+                      WRITE(numout,*) 'ilabile, labile_pool: ',&
+                           biomass(ipts,j,ilabile,icarbon),labile_pool
+                      WRITE(numout,*) 'evergreen_reserve: ',&
+                           evergreen_reserve
+                      WRITE(numout,*) 'isapabove,isapbelow: ',&
+                           biomass(ipts,j,isapabove,icarbon), biomass(ipts,j,isapbelow,icarbon)
+                      WRITE(numout,*) 'lai_target,sla,ltor: ',&
+                           lai_target(ipts,j),sla(j),ltor(ipts,j)
+                      WRITE(numout,*) 'term1, term2: ',&
+                           evergreen_reserve * ( biomass(ipts,j,isapabove,icarbon) + &
+                           biomass(ipts,j,isapbelow,icarbon)),&
+                           lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j))
+                   ENDIF
+               
+
+                ELSE
+
+                   ! Deciduous trees are more conservative and 12% of their sapwood mass is stored in the 
+                   ! reserve pool. The scheme avoids that during the growing season too much reserve are 
+                   ! accumulated (which would hamper growth), therefore, the reduced rate of 12% is used 
+                   ! until scenecence.
+                   IF (bm_alloc_tot(ipts,j) .GT. min_stomate) THEN
+
+                      reserve_pool = MIN(deciduous_reserve * ( biomass(ipts,j,isapabove,icarbon) + &
+                           biomass(ipts,j,isapbelow,icarbon)), lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j)))
+
+                      IF (j .EQ. test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
+                         WRITE(numout,*) 'What happens to the reserve and labile pools? Deciduous'
+                         WRITE(numout,*) 'carbres, reserve_pool: ',&
+                              biomass(ipts,j,icarbres,icarbon),reserve_pool
+                         WRITE(numout,*) 'deciduous_reserve: ',&
+                              deciduous_reserve
+                         WRITE(numout,*) 'isapabove,isapbelow: ',&
+                              biomass(ipts,j,isapabove,icarbon), biomass(ipts,j,isapbelow,icarbon)
+                         WRITE(numout,*) 'lai_target,sla,ltor: ',&
+                              lai_target(ipts,j),sla(j),ltor(ipts,j)
+                         WRITE(numout,*) 'term1, term2: ',&
+                              deciduous_reserve * ( biomass(ipts,j,isapabove,icarbon) + &
+                              biomass(ipts,j,isapbelow,icarbon)),&
+                              lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j))
+                      ENDIF
+
+                  ELSE  
+
+                      ! If the plant is scenecent, allow for a higher reserve mass. Plants can then use the 
+                      ! excess labile C, that is no longer used for growth and would be respired otherwise,
+                      ! to regrow leaves after the dormant period.
+                      reserve_pool = MIN(senescense_reserve * ( biomass(ipts,j,isapabove,icarbon) + &
+                           biomass(ipts,j,isapbelow,icarbon)), lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j)))
+
+                      IF (j .EQ. test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
+                         WRITE(numout,*) 'What happens to the reserve and labile pools? Senescent'
+                         WRITE(numout,*) 'carbres, reserve_pool: ',&
+                              biomass(ipts,j,icarbres,icarbon),reserve_pool
+                         WRITE(numout,*) 'senescense_reserve: ',&
+                              senescense_reserve
+                         WRITE(numout,*) 'isapabove,isapbelow: ',&
+                              biomass(ipts,j,isapabove,icarbon), biomass(ipts,j,isapbelow,icarbon)
+                         WRITE(numout,*) 'lai_target,sla,ltor: ',&
+                              lai_target(ipts,j),sla(j),ltor(ipts,j)
+                         WRITE(numout,*) 'term1, term2: ',&
+                              senescense_reserve * ( biomass(ipts,j,isapabove,icarbon) + &
+                              biomass(ipts,j,isapbelow,icarbon)),&
+                              lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j))
+                      ENDIF
+                      
+                   ENDIF ! Scenecent
+
+                ENDIF ! Phenology type
+
+             ! Grasses
+             ELSE
+
+                !+++CHECK+++
+                ! The min criterion results in the reserves being zero because isapabove goes to zero 
+                ! when the reserves are most needed 
+                reserve_pool = MIN(0.3 * ( biomass(ipts,j,iroot,icarbon) + biomass(ipts,j,isapabove,icarbon) + & 
+                     biomass(ipts,j,isapbelow,icarbon)), lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j)))
+!!$                reserve_pool = lai_target(ipts,j)/sla(j)*(1.+0.3/ltor(ipts,j))
+                !+++++++++++
+
+                !+++TEMP+++ 
+                IF (j .EQ. test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
+                   WRITE(numout,*) 'reserve pool, 30%', reserve_pool
+                ENDIF
+                !++++++++++
+
+             ENDIF
+
+             !! 7.2 Move carbon between the reserve pools
+             !  Fill the reserve pools up to their optimal level or until the min/max limits are reached
+             !  The original approcah in OCN resulted in instabilities and sometimes oscilations. For
+             !  this reason a more simple and straightforward transfer between the pools has been 
+             !  implemented.
+
+             !! 7.2.1 Burn excess reserves
+             !  The actual reserve and/or labile pool exceed the required pools (as calculated in 7.1)
+             !  The excessive reserve pools respires C which needs to be accounted for in the 
+             !  growth respiration. Because of this line of code, npp cannot be calculated at the
+             !  start of the of this subroutine (i.e. between section 4 and 5). Last, correct the
+             !  labile and reserve pool for this respiration flux. Note that instead of respiring
+             !  this carbon it could be used for leaching, feeding mycorrhizae, producing DOCs,
+             !  producing VOCs or any other component of NPP that does not end up in the biomass.
+                !write(*,*) 'biomass_carbres',biomass(ipts,j,icarbres,icarbon)
+                !write(*,*) 'reserve_pool',reserve_pool
+                !write(*,*) 'biomass_labile', biomass(ipts,j,ilabile,icarbon)
+                !write(*,*) 'labile_pool',labile_pool
+             IF ( (biomass(ipts,j,icarbres,icarbon) .GE. reserve_pool) .AND. &
+                  (biomass(ipts,j,ilabile,icarbon) .GE. labile_pool) ) THEN
+                          
+                ! reserves are full
+                IF ( biomass(ipts,j,icarbres,icarbon) .GT. reserve_pool ) THEN
+
+                   excess = biomass(ipts,j,icarbres,icarbon) - reserve_pool
+
+                   !---TEMP---
+                   IF (j.EQ.test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
+                      WRITE(numout,*) 'excess reserve, ', &
+                           excess, biomass(ipts,j,icarbres,icarbon), &
+                           reserve_pool 
+                   ENDIF
+                   !----------
+
+                   resp_growth(ipts,j) = resp_growth(ipts,j) + 0.1 * excess
+                   biomass(ipts,j,icarbres,icarbon) = biomass(ipts,j,icarbres,icarbon) - &
+                        0.1 * excess
+
+                ENDIF
+
+                ! labile is full
+                ! Try not buring the labile pool.  I am commenting out this part because
+                ! this can prevent trees from growing after coppicing.  It is unclear
+                ! exactly what the point of it is, too.  In another loop, if the
+                ! labile pool is overful but the carbres pool is just below the limit,
+                ! the code is supposed to move labile carbon to the reserve pool.  It does
+                ! it so slowly, though, that it might as well not be doing it at all.  Here
+                ! we burn off the reserves while leaving the labile pool, since the labile
+                ! pool is used for allocation.  This implicitly supposes that some of the
+                ! carbon burned off from the reserve pool turns into labile carbon, enough
+                ! to counter whatever is burned off from the labile pool.
+!!$                IF ( biomass(ipts,j,ilabile,icarbon) .GT. labile_pool ) THEN
+!!$
+!!$                   excess = biomass(ipts,j,ilabile,icarbon) - labile_pool
+!!$
+!!$                   !---TEMP---
+!!$                   IF (j.EQ.test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
+!!$                      WRITE(numout,*) 'excess labile, ', &
+!!$                           excess, biomass(ipts,j,ilabile,icarbon), &
+!!$                           labile_pool 
+!!$                   ENDIF
+!!$                   !----------
+!!$
+!!$                   resp_growth(ipts,j) = resp_growth(ipts,j) + 0.1 * excess
+!!$                   biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) - &
+!!$                        0.1 * excess
+!!$
+!!$                ENDIF
+
+                !---TEMP---
+                IF (j.EQ.test_pft .AND. ld_alloc .AND. ipts == test_grid) THEN
+                   WRITE(numout,*) 'reserve pools are considered too full'
+                   WRITE(numout,*) 'excess, ', excess 
+                   WRITE(numout,*) 'resp_growth, ', resp_growth(ipts,j)
+                   WRITE(numout,*) 'biomass(ilabile) really final, ', biomass(ipts,j,ilabile,icarbon)
+                   WRITE(numout,*) 'biomass(icarbres) really final, ', biomass(ipts,j,icarbres,icarbon)
+                   WRITE(numout,*) 'when_growthinit, ', when_growthinit(ipts,j) , j
+                   WRITE(numout,*) 'senescence, ',senescence(ipts,j), j
+                ENDIF
+                !----------        
+
+             !! 7.2.2 Enough reserves, not enough labile
+             ELSEIF ( (biomass(ipts,j,icarbres,icarbon) .GE. reserve_pool) .AND. &
+                  (biomass(ipts,j,ilabile,icarbon) .LT. labile_pool) ) THEN
+
+                ! We need to move carbon from the reserve pool to the labile pool. We will move
+                ! this gradually. Calculate the maximum flow of the carbon reserve pool to labile 
+                IF (is_tree(j)) THEN
+
+                   ! During the dormant season for evergreens or the growing season for both functional leaf
+                   ! traits. 
+                   IF ( (biomass(ipts,j,ileaf,icarbon) .GT. min_stomate .AND. &
+                        f_alloc(ipts,j,isapabove) .LE. min_stomate) .OR. & 
+                        (lab_fac(ipts,j) .GT. 0.1) ) THEN 
+                      
+                      ! Don't move more than an arbitrary 5% from the carbohydrate reserve pool
+!!$                         use_max = biomass(ipts,j,icarbres,icarbon) * MIN(0.05,reserve_scal)
+                      use_max = biomass(ipts,j,icarbres,icarbon) * 0.05
+
+                   ! Dormant season
+                   ELSE 
+
+                      ! Don't move any carbon between the reserve and the labile pool
+                      use_max = zero
+
+                   ENDIF ! Growing or dormant season
+
+                ! Grasses
+                ELSE 
+
+                   ! During the growing season
+                   IF (biomass(ipts,j,ileaf,icarbon).GT.min_stomate) THEN 
+
+                      ! Don't move more than an arbitrary 5% from the carbohydrate reserve pool
+!!$                         use_max = biomass(ipts,j,icarbres,icarbon) * MIN(0.05,reserve_scal)
+                      use_max = biomass(ipts,j,icarbres,icarbon) * 0.05
+
+                   ! Dormant season
+                   ELSE 
+
+                      ! Don't move any carbon between the reserve and the labile pool
+                      use_max = zero
+
+                   ENDIF ! Growing or dormant season
+
+                ENDIF ! Trees or grasses
+
+                ! Calculate the required flow of the carbon reserve pool to labile  
+                ! Propose to use what can be moved from the reserve pool (::use_max) or 
+                ! the amount required to fill the pool.
+                use_res = MAX(zero, MIN(use_max, labile_pool-biomass(ipts,j,ilabile,icarbon)))
+                   
+                ! Update labile pool and reserve
+                bm_alloc(ipts,j,icarbres,icarbon) =  use_res
+                biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) + &
+                     bm_alloc(ipts,j,icarbres,icarbon)
+                biomass(ipts,j,icarbres,icarbon) = biomass(ipts,j,icarbres,icarbon) - &
+                     bm_alloc(ipts,j,icarbres,icarbon)
+
+                !+++TEMP+++ 
+                IF (j .EQ. test_pft .AND. ld_alloc) THEN
+                   WRITE(numout,*) 'move carbon from reserve to labile'
+                   WRITE(numout,*) 'use_res, ', use_res
+                   WRITE(numout,*) 'required: reserve and labile pool, ',reserve_pool, labile_pool
+                   WRITE(numout,*) 'available: reserve and labile, ', biomass(ipts,j,icarbres,icarbon), &
+                        biomass(ipts,j,ilabile,icarbon)
+                ENDIF
+                !++++++++++
+                
+             ! 7.2.3 Enough labile, not enough reserves
+             ELSEIF ( (biomass(ipts,j,icarbres,icarbon) .LT. reserve_pool) .AND. &
+                  (biomass(ipts,j,ilabile,icarbon) .GE. labile_pool) ) THEN
+                
+                ! The labile carbon is more mobile than the reserve pool but
+                ! it is also more important in the allocation scheme because 
+                ! it generates growth respiration and it is used to calculate
+                ! bm_alloc. Therefore, the mobility of the labile pool was
+                ! restricted to an arbitrary 15% 
+                use_max = biomass(ipts,j,ilabile,icarbon) * 0.15
+                
+                ! Propose to use what can be moved from the reserve labile pool(::use_max) or 
+                ! the amount required to fill the pool.
+                use_lab = MAX(zero, MIN(use_max, reserve_pool-biomass(ipts,j,icarbres,icarbon)))
+                
+                ! Update labile pool and reserve
+                bm_alloc(ipts,j,icarbres,icarbon) =  use_lab
+                biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) - &
+                     bm_alloc(ipts,j,icarbres,icarbon)
+                biomass(ipts,j,icarbres,icarbon) = biomass(ipts,j,icarbres,icarbon) + &
+                     bm_alloc(ipts,j,icarbres,icarbon)
+
+                !+++TEMP+++ 
+                IF (j .EQ. test_pft .AND. ld_alloc) THEN
+                   WRITE(numout,*) 'move carbon from labile to reserve'
+                   WRITE(numout,*) 'use_lab, ', use_lab
+                   WRITE(numout,*) 'required: reserve and labile pool, ',reserve_pool, labile_pool
+                   WRITE(numout,*) 'available: reserve and labile, ', biomass(ipts,j,icarbres,icarbon), &
+                        biomass(ipts,j,ilabile,icarbon)
+                ENDIF
+                !++++++++++
+             
+
+             !! 7.2.3 We don't have enough carbon in both reserve pools. We will 
+             !  redistribute what we have to minimise the tension between available and 
+             !  required
+             ELSEIF ( (biomass(ipts,j,icarbres,icarbon) .LT. reserve_pool) .AND. &
+                  (biomass(ipts,j,ilabile,icarbon) .LT. labile_pool) ) THEN 
+             
+                !+++CHECK+++
+                ! not really clear what the advantage is of doing this. Best case it avoids 
+                ! that one of the pools gets depleted. Worst case it takes a lot of C (relatively)
+                ! speaking from the labile pool (which is much smaller than the reserve pool).
+                ! The carbon that is lacking to satisfy the needs of the reserve pools
+!!$                shortage = (reserve_pool + labile_pool) - &
+!!$                     (biomass(ipts,j,icarbres,icarbon) + biomass(ipts,j,ilabile,icarbon)) 
+!!$                
+!!$                ! Share of the reserve pool in the total requirement
+!!$                reserve_scal = reserve_pool/(reserve_pool+labile_pool)
+!!$
+!!$                ! The shortage that should occur in the reserve pool
+!!$                ! under the assumption that the optimal shortage is
+!!$                ! proportional to the required reserve and labil pool
+!!$                use_res = shortage * reserve_scal
+!!$                
+!!$                ! Update labile pool and reserve
+!!$                bm_alloc(ipts,j,icarbres,icarbon) =  zero
+!!$                biomass(ipts,j,ilabile,icarbon) = labile_pool - (shortage - use_res)
+!!$                biomass(ipts,j,icarbres,icarbon) = reserve_pool - use_res
+                !+++++++++++
+
+                !++++++++++++++++
+                !  Try moving carbon from reserves to labile, just because labile seems
+                ! to be essential for growing leaves.  If we don't have enough, the
+                ! trees stop growing but don't die.
+                !shortage = labile_pool - biomass(ipts,j,ilabile,icarbon)
+                !IF(shortage .GT. biomass(ipts,j,icarbres,icarbon))THEN
+                !   biomass(ipts,j,ilabile,icarbon)=biomass(ipts,j,ilabile,icarbon)+0.9*shortage
+                !   biomass(ipts,j,icarbres,icarbon)=biomass(ipts,j,icarbres,icarbon)-0.9*shortage
+                !ENDIF
+                !++++++++++++++++++++++++++
+
+                !+++Temp+++ 
+                IF (j .EQ. test_pft .AND. ld_alloc) THEN
+                   WRITE(numout,*) 'not enough carbon to satify the total requirement of labile and reserve'
+                   !WRITE(numout,*) 'use_res,shortage,reserve_scale: ', use_res,shortage,reserve_scal
+                   WRITE(numout,*) 'bm_alloc: ',bm_alloc(ipts,j,icarbres,icarbon)
+                   WRITE(numout,*) 'bm_alloc_tot: ',bm_alloc_tot(ipts,j)
+                   WRITE(numout,'(A,2ES20.10)') 'required: reserve and labile pool, ',&
+                        reserve_pool, labile_pool
+                   WRITE(numout,'(A,2ES20.10)') 'available: reserve and labile, ', &
+                        biomass(ipts,j,icarbres,icarbon), &
+                           biomass(ipts,j,ilabile,icarbon)
+                ENDIF
+                !++++++++++
+
+             !!  7.4 Unexpected condition
+             ELSE
+                
+                IF(ld_warn .OR. ld_alloc) THEN
+                   WRITE(numout,*) 'An unexpected condition occured for the reserve pools'
+                   WRITE(numout,*) 'required: reserve and labile pool, ',reserve_pool, labile_pool
+                   WRITE(numout,*) 'available: reserve and labile, ', biomass(ipts,j,icarbres,icarbon), &
+                        biomass(ipts,j,ilabile,icarbon)
+                   CALL ipslerr_p (3,'growth_fun_all',&
+                        'An unexpected condition occured for the reserve pools','','')
+                ENDIF
+
+             ENDIF
+             
+
+!!$             !! 7.2 Calculate the C that could move from the reserve pool to the labile pool 
+!!$             !  Fill the reserve pools up to their optimal level or until the min/max limits are reached
+!!$   
+!!$             !+++CHECK++++
+!!$             ! SL does not understand the benefit of this implementation
+!!$             ! Should equally well work without it
+!!$             !  Calcualte the tension between the required and demanded reserve pool
+!!$             IF (reserve_pool .GT. min_stomate) THEN
+!!$
+!!$                reserve_scal = MAX( MIN(biomass(ipts,j,icarbres,icarbon)/reserve_pool,un), zero) 
+!!$
+!!$             ELSE
+!!$
+!!$                reserve_scal = zero
+!!$
+!!$             ENDIF
+!!$             !+++++++++++++
+!!$
+!!$     
+!!$             !! 7.3 Calculate the C that is required to fill the labile pool
+!!$             !  Propose to use what can be moved from the reserve pool (::use_max) or the amount required 
+!!$             !  to fill the pool.
+!!$             use_res = MAX(zero, MIN(use_max, labile_pool-biomass(ipts,j,ilabile,icarbon))) 
+!!$
+!!$             !+++TEMP+++ 
+!!$             IF (j .EQ. test_pft .AND. ld_alloc) THEN
+!!$                WRITE(numout,*) 'use_res, ', use_res
+!!$             ENDIF
+!!$             !++++++++++
+!!$
+!!$             ! Check wether there is excessive carbon in the reserve pool 
+!!$             IF ( (biomass(ipts,j,icarbres,icarbon).GT.reserve_pool) .AND. (reserve_pool .GT. min_stomate) ) THEN
+!!$                
+!!$                ! Calculate the amount of carbon that will be moved from the reserve pool to the labile pool            
+!!$                use_res = MIN(0.25 * biomass(ipts,j,icarbres,icarbon), & 
+!!$                     MAX( biomass(ipts,j,icarbres,icarbon)-reserve_pool, use_res ))
+!!$           
+!!$             ENDIF
+!!$
+!!$             !! 7.4 Avoid overflow of the reserve pool
+!!$             use_max = labile_pool
+!!$             use_lab = MAX(zero, biomass(ipts,j,ilabile,icarbon)-use_max) * (un - reserve_scal)
+!!$
+!!$
+!!$             !! 7.5 Calculate flow between the pools
+!!$             !  Net carbon flow between reserve and labile pool adjust the reserve compartment in bm_alloc
+!!$             bm_alloc(ipts,j,icarbres,icarbon) = MAX( MIN(use_lab-use_res, biomass(ipts,j,ilabile,icarbon)), &
+!!$                  -biomass(ipts,j,icarbres,icarbon) )
+!!$
+!!$             !+++TEMP+++ 
+!!$             IF (j .EQ. test_pft .AND. ld_alloc) THEN
+!!$                WRITE(numout,*) 'bm_alloc(icarbes), ', bm_alloc(ipts,j,icarbres,icarbon)
+!!$                WRITE(numout,*) 'use_lab, ', use_lab
+!!$                WRITE(numout,*) 'use_res, ', use_res
+!!$                WRITE(numout,*) 'biomass(ilabile), ', biomass(ipts,j,ilabile,icarbon)
+!!$                WRITE(numout,*) 'biomass(icarbres), ', biomass(ipts,j,icarbres,icarbon)
+!!$                WRITE(numout,*) 'biomass(ilabile) final, ', biomass(ipts,j,ilabile,icarbon) - &
+!!$                     bm_alloc(ipts,j,icarbres,icarbon)
+!!$                WRITE(numout,*) 'biomass(icarbres) final, ', biomass(ipts,j,icarbres,icarbon) + &
+!!$                     bm_alloc(ipts,j,icarbres,icarbon)
+!!$             ENDIF
+!!$             !++++++++++
+!!$
+!!$             ! Update labile pool and reserve
+!!$             biomass(ipts,j,ilabile,icarbon) = biomass(ipts,j,ilabile,icarbon) - bm_alloc(ipts,j,icarbres,icarbon)
+!!$             biomass(ipts,j,icarbres,icarbon) = biomass(ipts,j,icarbres,icarbon) + bm_alloc(ipts,j,icarbres,icarbon)
+               
+          ELSEIF ( veget_max(ipts,j) .GT. min_stomate .AND. &
+               rue_longterm(ipts,j) .EQ. un) THEN
+
+             ! There hasn't been any photosynthesis yet. This happens when a new vegetation
+             ! is prescribed and the longterm phenology variables are not initialized yet. 
+             ! These conditions happen when the model is started from scratch (no restart files).
+             ! Because the plants are very small, they contain little reserves. We increased the 
+             ! amount of reserves by a factor ::tune_r_in_sapling where r stands for reserves.
+             ! However, this amount gets simply respired before it is needed because the 
+             ! reserve_pool is calculated as a function of the sapwood biomass which is very
+             ! low because the plants are really small. Here we skip recalculating the 
+             ! reserve_pool until the day we start using it.
+
+          ELSE
+
+             ! No reason to be here
+             WRITE(numout,*) 'Error: unexpected condition for the reserve pools, pft, ',j
+             WRITE(numout,*) 'veget_max, rue_longterm, ', veget_max(ipts,j), rue_longterm(ipts,j)
+
+          ENDIF ! rue_longterm
+          !write(*,*) 'resp_growth_excess',resp_growth(ipts,j)
+          !write(*,*) 'bm_alloc_carbres',bm_alloc(ipts,j,icarbres,icarbon) 
+          !! 7.8 Calculate NPP
+          !  Calculate the NPP @tex $(gC.m^{-2}dt^{-1})$ @endtex as the difference between GPP and the two 
+          !  components of autotrophic respiration (maintenance and growth respiration). GPP, R_maint and R_growth 
+          !  are prognostic variables, NPP is calculated as the residuals and is thus a diagnostic variable. 
+          !  Note that NPP is not used in the allocation scheme, instead bm_alloc_tot is allocated. The 
+          !  physiological difference between both is that bm_alloc_tot does no longer contain the reserves and
+          !  labile pools and is only the carbon that needs to go into the biomass pools. NPP contains the reserves
+          !  and labile carbon. Note that GPP is in gC m-2 s-1 whereas the respiration terms were calculated in
+          !  gC m-2 dt-1
+          npp(ipts,j) = gpp_daily(ipts,j) - resp_growth(ipts,j)/dt - resp_maint(ipts,j)/dt
+    
+          !---TEMP---
+          IF (j.EQ.test_pft .AND. ld_alloc) THEN
+             WRITE(numout,'(A,20F20.10)') 'GPP_DAILY, NPP, Rag, Ra, ', gpp_daily(ipts,j), npp(ipts,j), &
+                  resp_growth(ipts,j)/dt, resp_maint(ipts,j)/dt
+             WRITE(numout,*) 'PFT, bm_alloc_tot, ', bm_alloc_tot(ipts,j)
+             WRITE(numout,*) 'PFT, sum of bm_alloc components, ', SUM(bm_alloc(ipts,j,:,icarbon))
+          ENDIF
+          !----------
+
+
+          !! 7.9 Distribute stand level ilabile and icarbres at the tree level
+          !  The labile and carbres pools are calculated at the stand level but are then redistributed at the
+          !  tree level. This has the advantage that biomass and circ_class_biomass have the same dimensions
+          !  for nparts which comes in handy when phenology and mortality are calculated.
+                
+          IF (is_tree(j)) THEN
+ 
+             ! Initialize to enable a loop over nparts
+             circ_class_biomass(ipts,j,:,ilabile,:) = zero
+             circ_class_biomass(ipts,j,:,icarbres,:) = zero
+ 
+             ! Distribute labile and reserve pools over the circumference classes 
+             DO m = 1,nelements
+
+                ! Total biomass across parts and circumference classes
+                temp_total_biomass = zero
+
+                DO l = 1,ncirc 
+                   
+                   DO k = 1,nparts
+                      
+                      temp_total_biomass = temp_total_biomass + circ_class_biomass(ipts,j,l,k,m) * circ_class_n(ipts,j,l)
+                                
+                   ENDDO
+
+                ENDDO
+              
+                ! Total biomass across parts but for a specific circumference class
+                DO l = 1,ncirc
+
+                   temp_class_biomass = zero
+  
+                   DO k = 1,nparts
+
+                      temp_class_biomass = temp_class_biomass + circ_class_biomass(ipts,j,l,k,m) * circ_class_n(ipts,j,l)
+               
+                   ENDDO
+
+                   IF(  temp_total_biomass .NE. zero) THEN
+
+                      ! Share of this circumference class to the total biomass
+                      temp_share = temp_class_biomass / temp_total_biomass
+ 
+                      ! Allocation of ilabile at the tree level (gC tree-1)
+                      circ_class_biomass(ipts,j,l,ilabile,m) = temp_share * &
+                           biomass(ipts,j,ilabile,m) / circ_class_n(ipts,j,l)
+                      
+                      ! Allocation of icarbres at the tree level (gC tree-1)
+                      circ_class_biomass(ipts,j,l,icarbres,m) = temp_share * &
+                           biomass(ipts,j,icarbres,m) / circ_class_n(ipts,j,l)
+                   ELSE
+
+                      circ_class_biomass(ipts,j,l,ilabile,m) = zero
+                      circ_class_biomass(ipts,j,l,icarbres,m) = zero
+
+                   ENDIF
+
+                ENDDO ! ncirc
+
+             ENDDO  ! nelements
+
+          ! Grasses and crops
+          ELSE
+
+             DO m = 1,nelements
+
+                ! synchronize biomass and circ_class_biomass
+                IF (ind(ipts,j) .GT. zero) THEN
+
+                   circ_class_biomass(ipts,j,1,:,m) = biomass(ipts,j,:,m) / ind(ipts,j)
+
+                ELSE
+
+                   circ_class_biomass(ipts,j,1,:,m) = zero
+
+                ENDIF
+
+             ENDDO  
+          
+          ENDIF ! is_tree
+  
+       ENDDO ! pnts
+
+    ENDDO ! PFTs
+
+
+ !! 8. Check mass balance closure
+    
+    ! Calculate pools at the end of the routine
+    pool_end = zero
+    DO ipar = 1,nparts
+       DO iele = 1,nelements
+          pool_end(:,:,iele) = pool_end(:,:,iele) + &
+               (biomass(:,:,ipar,iele) * veget_max(:,:))
+       ENDDO
+    ENDDO
+
+    ! Calculate components of the mass balance
+    check_intern(:,:,iatm2land,icarbon) = gpp_daily(:,:) * dt * veget_max(:,:)
+    check_intern(:,:,iland2atm,icarbon) = -un * (resp_maint(:,:) + resp_growth(:,:)) * &
+         veget_max(:,:)
+    check_intern(:,:,ilat2out,icarbon) = -un * zero
+    check_intern(:,:,ilat2in,icarbon) = un * zero
+    check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - &
+         pool_start(:,:,icarbon))
+    closure_intern = zero
+    DO imbc = 1,nmbcomp
+       closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + &
+            check_intern(:,:,imbc,icarbon)
+    ENDDO
+
+    ! Write conclusion
+    DO ipts=1,npts
+       DO j=1,nvm
+          IF(ABS(closure_intern(ipts,j,icarbon)) .LE. min_stomate)THEN
+             IF (ld_massbal) WRITE(numout,*) 'Mass balance closure in stomate_growth_fun_all.f90'
+          ELSE
+             WRITE(numout,*) 'Error: mass balance is not closed in stomate_growth_fun_all.f90'
+             WRITE(numout,*) '   ipts,j; ', ipts,j
+             WRITE(numout,*) '   Difference is, ', closure_intern(ipts,j,icarbon)
+             WRITE(numout,*) '   pool_end,pool_start: ', pool_end(ipts,j,icarbon), pool_start(ipts,j,icarbon)
+             WRITE(numout,*) '   gpp_daily, veget_max: ', gpp_daily(ipts,j),veget_max(ipts,j)
+             WRITE(numout,*) '   resp_maint,resp_growth: ', resp_maint(ipts,j),resp_growth(ipts,j)
+             IF(ld_stop)THEN
+                CALL ipslerr_p (3,'growth_fun_all', 'Mass balance error.','','')
+             ENDIF
+          ENDIF
+       ENDDO
+    ENDDO
+
+    !----------
+
+
+ !! 9. Update leaf age
+
+    !  Leaf age is needed to calculate the turnover and vmax in the stomate_turnover.f90 and stomate_vmax.f90 routines. 
+    !  Leaf biomass is distributed according to its age into several "age classes" with age class=1 representing the
+    !  youngest class, and consisting of the most newly allocated leaf biomass. 
+    
+    !! 9.1 Update quantity and age of the leaf biomass in the youngest class
+    !  The new amount of leaf biomass in the youngest age class (leaf_mass_young) is the sum of :
+    !  - the leaf biomass that was already in the youngest age class (leaf_frac(:,j,1) * lm_old(:,j)) with the 
+    !  leaf age given in leaf_age(:,j,1) 
+    !  - and the new biomass allocated to leaves (bm_alloc(:,j,ileaf,icarbon)) with a leaf age of zero.
+    leaf_mass_young(:,:) = leaf_frac(:,:,1) * lm_old(:,:) + bm_alloc(:,:,ileaf,icarbon)
+
+    ! The age of the updated youngest age class is the average of the ages of its 2 components: bm_alloc(leaf) of age
+    ! '0', and leaf_frac*lm_old(=leaf_mass_young-bm_alloc) of age 'leaf_age(:,:,1)' 
+    DO ipts=1,npts
+
+       DO j=1,nvm
+
+          ! IF(veget_max(ipts,j) == zero)THEN
+          !     ! this vegetation type is not present, so no reason to do the 
+          !     ! calculation
+          !     CYCLE
+          ! ENDIF
+
+          IF( (bm_alloc(ipts,j,ileaf,icarbon) .GT. min_stomate ) .AND. &
+               ( leaf_mass_young(ipts,j) .GT. min_stomate ) )THEN
+             
+
+             leaf_age(ipts,j,1) = MAX ( zero, leaf_age(ipts,j,1) * &
+                  ( leaf_mass_young(ipts,j) - bm_alloc(ipts,j,ileaf,icarbon) ) / &
+                  & leaf_mass_young(ipts,j) )
+             
+          ENDIF
+          
+          !+++TEMP+++
+!!$          IF(j == test_pft .AND. ipts == test_grid)THEN
+!!$             WRITE(numout,*) 'VCMAX: leaf_age growth: ',leaf_age(ipts,j,1),&
+!!$                  bm_alloc(ipts,j,ileaf,icarbon),leaf_mass_young(ipts,j),&
+!!$                  biomass(ipts,j,ileaf,icarbon)
+!!$          ENDIF
+          !++++++++++
+
+       ENDDO
+
+    ENDDO
+          
+    !! 8.2 Decrease reduction of photosynthesis 
+    !  Decrease reduction of photosynthesis from new (undamaged) foliage
+!!$    WHERE(biomass(:,:,ileaf,icarbon).GT.min_stomate)
+!!$    
+!!$      t_photo_stress(:,:) =  (t_photo_stress(:,:) * lm_old(:,:) + & 
+!!$            bm_alloc(:,:,ileaf,icarbon))/biomass(:,:,ileaf,icarbon)
+!!$   
+!!$    ENDWHERE
+
+
+    !! 9.3 Update leaf age
+    !  Update fractions of leaf biomass in each age class (fraction in youngest class increases)
+
+    !! 9.3.1 Update age of youngest leaves
+    !  For age class 1 (youngest class), because we have added biomass to the youngest class, we need to update
+    !  the fraction of total leaf biomass that belongs to the youngest age class : updated mass in class divided
+    !  by new total leaf mass
+    WHERE ( biomass(:,:,ileaf,icarbon) .GT. min_stomate )
+
+          leaf_frac(:,:,1) = leaf_mass_young(:,:) / biomass(:,:,ileaf,icarbon)
+
+    ENDWHERE
+
+
+    !! 9.3.2 Update age of other age classes
+    !  Because the total leaf biomass has changed, we need to update the fraction of leaves in each age class:
+    !  mass in leaf age class (from previous fraction of leaves in this class and previous total leaf biomass) 
+    !  divided by new total mass
+    DO m = 2, nleafages ! Loop over # leaf age classes
+
+       WHERE ( biomass(:,:,ileaf,icarbon) .GT. min_stomate )
+
+          leaf_frac(:,:,m) = leaf_frac(:,:,m) * lm_old(:,:) / biomass(:,:,ileaf,icarbon)
+
+       ENDWHERE
+
+    ENDDO       ! Loop over # leaf age classes
+
+
+ !! 10. Update whole-plant age 
+    
+    !! 10.1 PFT age
+    !  At every time step, increase age of the biomass that was already present at previous time step. 
+    !  Age is expressed in years, and the time step 'dt' in days so age increase is: dt divided by number 
+    !  of days in a year.
+    WHERE ( PFTpresent(:,:) )
+
+       age(:,:) = age(:,:) + dt/one_year
+
+    ELSEWHERE
+
+       age(:,:) = zero
+
+    ENDWHERE
+
+
+    !! 10.2 Age of grasses and crops
+    !  For grasses and crops, biomass with age 0 has been added to the whole plant with age 'age'. New biomass is the sum of 
+    !  the current total biomass in all plant parts (bm_new), bm_new(:) = SUM( biomass(:,j,:), DIM=2 ). The biomass that has 
+    !  just been added is the sum of the allocatable biomass of all plant parts (bm_add), its age is zero. bm_add(:) = 
+    !  SUM( bm_alloc(:,j,:,icarbon), DIM=2 ). Before allocation, the plant biomass is bm_new-bm_add, its age is "age(:,j)". 
+    !  The age of the new biomass is the average of the ages of previous and added biomass.
+    !  For trees, age is treated in "establish" if vegetation is dynamic, and in turnover routines if it is static (in this 
+    !  case, only the age of the heartwood is accounted for).
+    DO j = 2,nvm
+
+       IF ( .NOT. is_tree(j) ) THEN
+
+          bm_new(:) = biomass(:,j,ileaf,icarbon) + biomass(:,j,isapabove,icarbon) + &
+               biomass(:,j,iroot,icarbon) + biomass(:,j,ifruit,icarbon)
+          bm_add(:) = bm_alloc(:,j,ileaf,icarbon) + bm_alloc(:,j,isapabove,icarbon) + &
+               bm_alloc(:,j,iroot,icarbon) + bm_alloc(:,j,ifruit,icarbon)
+
+          WHERE ( ( bm_new(:) .GT. min_stomate ) .AND. ( bm_add(:) .GT. min_stomate ) )
+             
+             age(:,j) = age(:,j) * ( bm_new(:) - bm_add(:) ) / bm_new(:)
+          
+          ENDWHERE
+
+       ENDIF ! is .NOT. tree
+
+    ENDDO  ! Loop over #PFTs 
+    !write(*,*) 'bm_alloc_sum',sum(bm_alloc(1,2,:,icarbon))
+    !write(*,*) 'bm_alloc_4sum',bm_alloc(1,2,ileaf,icarbon)+bm_alloc(1,2,isapabove,icarbon)+bm_alloc(1,2,iroot,icarbon)+bm_alloc(1,2,ifruit,icarbon)+bm_alloc(1,2,isapbelow,icarbon)
+ !! 11. Write history files
+
+    !---TEMP---
+!!$    DO ipts = 1, npts
+!!$       height_out(ipts,1) = zero
+!!$       DO j = 2, nvm
+!!$          height_out(ipts,j) = SUM(circ_class_height_eff(:))/ncirc
+!!$       ENDDO
+!!$    ENDDO
+    !---------
+
+!!$    !+++++++++ TEMP ++++++++++
+!!$    ! Just for testing.  Set the labile and reserve pools to zero to see if it dies.
+!!$    istep=istep+1
+!!$    IF(istep == 600)THEN
+!!$       WRITE(numout,'(A,I6,I6)') '!********** KILLING PFT ',test_pft,istep
+!!$       biomass(test_grid,test_pft,ileaf,icarbon)=zero
+!!$       biomass(test_grid,test_pft,ilabile,icarbon)=zero
+!!$       biomass(test_grid,test_pft,icarbres,icarbon)=zero
+!!$       circ_class_biomass(test_grid,test_pft,:,ileaf,icarbon)=zero
+!!$       circ_class_biomass(test_grid,test_pft,:,ilabile,icarbon)=zero
+!!$       circ_class_biomass(test_grid,test_pft,:,icarbres,icarbon)=zero
+!!$    ENDIF
+!!$    !+++++++++++++++++++++++++
+
+    ! Save in history file the variables describing the biomass allocated to the plant parts
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_LEAF', itime, &
+         bm_alloc(:,:,ileaf,icarbon), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_SAP_AB', itime, &
+         bm_alloc(:,:,isapabove,icarbon), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_SAP_BE', itime, &
+         bm_alloc(:,:,isapbelow,icarbon), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_HEART_AB', itime, &
+         bm_alloc(:,:,iheartabove,icarbon), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_HEART_BE', itime, &
+         bm_alloc(:,:,iheartbelow,icarbon), npts*nvm, horipft_index)
+    
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_ROOT', itime, &
+         bm_alloc(:,:,iroot,icarbon), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_FRUIT', itime, &
+         bm_alloc(:,:,ifruit,icarbon), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_RES', itime, &
+         bm_alloc(:,:,icarbres,icarbon), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_LABILE', itime, &
+         bm_alloc(:,:,ilabile,icarbon), npts*nvm, horipft_index)
+
+    CALL histwrite(hist_id_stomate, 'BM_ALLOC_TOT',itime, & 
+         bm_alloc_tot, npts*nvm, horipft_index)
+
+    CALL histwrite (hist_id_stomate, 'RUE_LONGTERM', itime, &
+         rue_longterm(:,:), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'KF', itime, &
+         k_latosa(:,:), npts*nvm, horipft_index)
+
+    DO ipts = 1,npts
+       DO j = 1,nvm
+          IF(is_tree(j))THEN
+             ! Calculate the forestry basal area (thus NOT the effective ba)
+             circ_class_ba(:) = wood_to_ba(circ_class_biomass(ipts,j,:,:,icarbon),j)
+             ba(ipts,j) = SUM(circ_class_ba(:)*circ_class_n(ipts,j,:)) * m2_to_ha
+             wood_volume(ipts,j) = wood_to_volume(biomass(ipts,j,:,icarbon),j,&
+                  branch_ratio(j),0)
+             store_circ_class_ba(ipts,j,:) = circ_class_ba(:)
+          ELSE
+             ba(ipts,j) = val_exp
+             wood_volume(ipts,j) = val_exp
+             store_circ_class_ba(ipts,j,:) = val_exp 
+          ENDIF
+       ENDDO
+    ENDDO
+
+    CALL histwrite (hist_id_stomate, 'BA', itime, &
+         ba(:,:), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'WOOD_VOL', itime, &
+         wood_volume(:,:), npts*nvm, horipft_index)
+
+    DO icirc = 1,ncirc
+       WRITE(var_name,'(A,I3.3)') 'CCBA_',icirc
+       CALL histwrite (hist_id_stomate, var_name, itime, &
+            store_circ_class_ba(:,:,icirc), npts*nvm, horipft_index)
+       WRITE(var_name,'(A,I3.3)') 'CCDELTABA_',icirc
+       CALL histwrite (hist_id_stomate, VAR_NAME, itime, &
+            store_delta_ba(:,:,icirc), npts*nvm, horipft_index)
+    ENDDO
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving functional growth'
+
+     
+END SUBROUTINE growth_fun_all
+
+
+
+!! ================================================================================================================================
+!! FUNCTION	: func_derfunc
+!!
+!>\BRIEF        Calculate value for a function and its derivative
+!!
+!!
+!! DESCRIPTION  : the routine describes the function and its derivative. Both function and derivative are used
+!!              by the optimisation scheme. Hence, this function is part of the optimisation scheme and is only 
+!!              called by the optimisation 
+!!
+!! RECENT CHANGE(S): 
+!!
+!! MAIN OUTPUT VARIABLE(S): f, df
+!!
+!! REFERENCE(S)	: Numerical recipies in Fortran 77
+!! 
+!! FLOWCHART : 
+!! \n
+!_ ================================================================================================================================
+ 
+ SUBROUTINE func_derfunc(x, n, o, p, q, r, t, eq_num, f, df)
+
+!! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+    REAL(r_std), INTENT(in)                :: x           !! x value for which the function f(x) will be evaluated
+    REAL(r_std), INTENT(in)                :: n,o,p,q,r,t !! Coefficients of the equation. Not all equations use all coefficients
+    INTEGER(i_std), INTENT(in)             :: eq_num      !! Function i.e. f(x), g(x), ...
+
+    !! 0.2 Output variables
+    REAL(r_std), INTENT(out)               :: f           !! Value y for f(x)
+    REAL(r_std), INTENT(out)               :: df          !! Value y for derivative[f(x)]   
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+!_ ================================================================================================================================
+
+!! 1. Calculate f(x) and df(x)
+
+    IF (eq_num .EQ. 1) THEN
+
+       !f = n*x**4 + o*x**3 + p*x**2 + q*x + r  
+       !df = 4*n*x**3 + 3*o*x**2 + 2*p*x + q
+    
+    ELSEIF (eq_num .EQ. 2) THEN
+    
+       f = ( (n*x)/(p*((x+o)/t)**(q/(2+q))) ) - r
+       df = ( n*(o*(q+2)+2*x)*((o+x)/t)**(-q/(q+2)) ) / ( p*(q+2)*(o+x) )
+    
+    ENDIF
+
+ END SUBROUTINE func_derfunc
+
+
+!! ================================================================================================================================
+!! FUNCTION	: iterative_solver
+!!
+!>\BRIEF        find best fitting x for f(x)
+!!
+!!
+!! DESCRIPTION  : The function makes use of an iterative approach to optimise the value for X. The solver
+!!              splits the search region in two but there is an additional check to ensure that bounds are not
+!!              exceeded.   
+!!
+!! RECENT CHANGE(S): 
+!!
+!! MAIN OUTPUT VARIABLE(S): x
+!!
+!! REFERENCE(S)	: Numerical recipies in Fortran 77
+!! 
+!! FLOWCHART : 
+!! \n
+!_ ================================================================================================================================
+
+  FUNCTION newX(n, o, p, q, r, t, x1, x2, eq_num, j, ipts)
+
+!! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+    REAL(r_std), INTENT(in)        :: n,o,p,q,r,t      !! Coefficients of the equation. Not all 
+                                                       !! equations use all coefficients
+    REAL(r_std), INTENT(in)        :: x1               !! Lower boundary off search range
+    REAL(r_std), INTENT(in)        :: x2               !! Upper boundary off search range
+    INTEGER(i_std), INTENT(in)     :: eq_num           !! Function for which an iterative solution is 
+                                                       !! searched
+    INTEGER(i_std), INTENT(in)     :: j                !! Number of PFT
+    INTEGER(i_std), INTENT(in)     :: ipts             !! Number of grdi square...for debugging
+    
+    !! 0.2 Output variables
+   
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std), PARAMETER      :: maxit = 20       !! Maximum number of iterations
+    INTEGER(i_std), PARAMETER      :: max_attempt = 5  !! Maximum number of iterations
+    INTEGER(i_std)                 :: i, attempt       !! Index
+    REAL(r_std)                    :: newX             !! New estimate for X
+    REAL(r_std)                    :: fl, fh, f        !! Value of the function for the lower bound (x1), 
+                                                       !! upper bound (x2) and the new value (newX)
+    REAL(r_std)                    :: xh, xl           !! Checked lower and upper bounds
+    REAL(r_std)                    :: df               !! Value of the derivative of the function for newX
+    REAL(r_std)                    :: dx, dxold        !! Slope of improvement
+    REAL(r_std)                    :: temp             !! Dummy variable for value swaps
+    REAL(r_std)                    :: low, high        !! temporary variables for x1 and x2 to avoid
+                                                       !! intent in/out conflicts with Cs
+    LOGICAL                        :: found_range      !! Flag indicating whether the range in which
+                                                       !! a solution exists was identified.
+!_ ================================================================================================================================   
+
+!! 1. Find solution for X
+ 
+    ! Not sure whether our initial range is large enough. We will
+    ! start with a narrow range so we are more likely to fine the
+    ! solution witin ::maxit iterations. If there is no solution
+    ! in the initial range we will expande the range and try again
+
+    ! Initilaze flags and counters
+    attempt = 2
+    found_range = .FALSE.
+    low = x1
+    high = x2
+
+ ! initialized newX tzj to avoid Bugs
+    newX = 0.5 * (x1+x2)
+    xl = MIN(x1,x2)
+    xh = MAX(x1,x2)
+
+    ! Calculate y for the upper and lower bound
+    DO WHILE (.NOT. found_range .AND. attempt .LT. max_attempt)
+
+!WRITE(numout,*) "funderC newX",high, low, n, o, p, q, r, t, eq_num, fl,fh, df
+
+       CALL func_derfunc(low, n, o, p, q, r, t, eq_num, fl, df)
+       CALL func_derfunc(high, n, o, p, q, r, t, eq_num, fh, df)
+ 
+       IF ((fl .GT. 0.0 .AND. fh .GT. 0.0) .OR. &
+            (fl .LT. 0.0 .AND. fh .LT. 0.0)) THEN
+       
+          IF (attempt .GT. max_attempt) THEN
+
+             ! If the sign of y does not changes between the upper 
+             ! and lower bound there no solution with the specified range
+             WRITE(numout,*) 'Iterative procedure - tried really hard but' 
+             WRITE(numout,*) 'no solution exists within the specified range'
+             WRITE(numout,*) 'PFT, grid square: ',j,ipts
+             CALL ipslerr_p (3,'growth_fun_all','newX',&
+                  'Iterative procedure - tried really hard but failed','')
+
+          ELSE
+ 
+             ! Update counter
+             attempt = attempt + 1
+             
+             ! Use previous upper boundary as the lower
+             ! boundary for the next range search. Increase
+             ! the upper boundary
+             temp = high
+             high = x1 * attempt
+             low = temp
+             
+             ! Enlarge the search range
+!!$             WRITE(numout,*) 'Iterative procedure - enlarge the search range'
+!!$             WRITE(numout,*) 'New range: ', x1, x2
+!!$             WRITE(numout,*) 'PFT, grid square, range: ',j,ipts,attempt
+
+          ENDIF
+       
+       ELSE
+
+          found_range = .TRUE.
+          
+       ENDIF
+      
+    ENDDO
+
+    ! Only when we found a range we will search for the solution 
+    IF (found_range) THEN
+       
+       ! If the sign of y changes between the upper and lower bound there is a solution
+       IF ( ABS(fl) .LT. min_stomate ) THEN          
+
+          ! The lower bound is the solution - most likely the lower bound is too high
+          newX = x1
+          RETURN
+
+          ELSEIF ( ABS(fh) .LT. min_stomate ) THEN
+
+          ! The upper bound is the solution - most likely the upper bound is too low
+          newX = x2
+          RETURN
+
+       ELSEIF (fl .LT. 0.0) THEN
+          
+          ! Accept the lower and upper bounds as specified
+          xl = x1
+          xh = x2
+       ELSE
+
+          ! Lower and upper bounds were swapped, correct their ranking 
+          xh = x1
+          xl = x2
+       ENDIF
+
+       ! Estimate the initial newX value 	
+       newX = 0.5 * (x1+x2)
+       dxold = ABS(x2-x1)
+       dx = dxold
+
+    ENDIF
+   
+!WRITE(numout,*) "funderC 2 newX",newX, n, o, p, q, r, t, eq_num, f, df
+    ! Calculate y=f(x) and df(x) for initial guess of newX
+    CALL func_derfunc(newX, n, o, p, q, r, t, eq_num, f, df)
+    
+    ! Evaluate for the maximum number of iterations  
+    DO  i = 1,maxit
+
+       IF ( ((newX-xh)*df-f)*((newX-xl)*df-f) .GT. 0.0 .OR. ABS(deux*f) > ABS(dxold*df) ) THEN
+             
+          ! Bisection
+          dxold = dx
+          dx = 0.5 * (xh-xl)
+          newX = xl+dx
+          IF (xl .EQ. newX) RETURN
+
+       ELSE
+             
+          ! Newton
+          dxold = dx
+          dx = f/df
+          temp = newX
+          newX = newX-dx
+          IF (temp .EQ. newX) RETURN
+
+       ENDIF
+
+       ! Precision reached
+       IF ( ABS(dx) .LT. min_stomate) RETURN
+          
+!WRITE(numout,*) "funderC 3 newX", newX, n, o, p, q, r, t, eq_num, f, df
+       ! Precision was not reached calculate f(x) and df(x) for newX
+       CALL func_derfunc(newX, n, o, p, q, r, t, eq_num, f, df)
+          
+       ! Narrow down the range
+       IF (f .LT. 0.0) then
+          xl = newX
+       ELSE
+          xh = newX
+       ENDIF
+
+    ENDDO ! maximum number of iterations
+       
+    !---TEMP---
+    IF (j.EQ. test_pft) THEN 
+       WRITE(numout,*) 'Iterative procedure: exceeded maximum iterations'
+    ENDIF
+    !----------
+
+  END FUNCTION newX
+
+
+!! ================================================================================================================================
+!! SUBROUTINE	: comments
+!!
+!>\BRIEF        Contains all comments to check the code
+!!
+!!
+!! DESCRIPTION  : contains all comments to check the code. By setting pft_test to 0, this routine is not called 
+!!
+!! RECENT CHANGE(S): 
+!!
+!! MAIN OUTPUT VARIABLE(S): none
+!!
+!! REFERENCE(S)	: none
+!! 
+!! FLOWCHART : 
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE comment(npts, Cl_target, Cl, Cs_target, & 
+       Cs, Cr_target, Cr, delta_ba, &
+       ipts, j, l, b_inc_tot, & 
+       Cl_incp, Cs_incp, Cr_incp, KF, LF, &
+       Cl_inc, Cs_inc, Cr_inc, Cf_inc, &
+       grow_wood, circ_class_n, ind, n_comment)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+    INTEGER(i_std), INTENT(in)                         :: npts		                    !! Defined in stomate_growth_fun_all
+    REAL(r_std), DIMENSION(:), INTENT(in)              :: Cl_target, Cs_target, Cr_target   !! Defined in stomate_growth_fun_all
+    REAL(r_std), DIMENSION(:), INTENT(in)              :: Cl_incp, Cs_incp, Cr_incp         !! Defined in stomate_growth_fun_all
+    REAL(r_std), DIMENSION(:), INTENT(in)              :: Cl_inc, Cs_inc, Cr_inc, Cf_inc    !! Defined in stomate_growth_fun_all
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)          :: circ_class_n                      !! Defined in stomate_growth_fun_all
+    REAL(r_std), DIMENSION(:), INTENT(in)              :: Cl, Cs, Cr                        !! Defined in stomate_growth_fun_all
+    REAL(r_std), DIMENSION(:), INTENT(in)              :: delta_ba                          !! Defined in stomate_growth_fun_all
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: KF, LF, ind                       !! Defined in stomate_growth_fun_all
+    REAL(r_std), INTENT(in)                            :: b_inc_tot                         !! Defined in stomate_growth_fun_all
+    INTEGER(i_std), INTENT(in)                         :: ipts, j, l                        !! Defined in stomate_growth_fun_all
+    LOGICAL, INTENT(in)                                :: grow_wood                         !! Defined in stomate_growth_fun_all
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                     :: n_comment                         !! Comment number  
+    !_ ================================================================================================================================
+
+    SELECT CASE (n_comment)
+    CASE (1)
+       ! Enough leaves and wood, grow roots
+       WRITE(numout,*) 'Exc 1: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, class, '
+       WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
+            b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
+       IF (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 1.1: unallocated less then 0: overspending, ', b_inc_tot - &
+               (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
+       ELSE
+          IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. zero) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 1.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
+               .LE. min_stomate) .AND. &
+               (circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l)) .GT. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 1.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 24: Exc 1.4 unexpected result'
+             WRITE(numout,*) 'WARNING 24: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE (2)
+       ! Enough wood and roots, grow leaves 
+       WRITE(numout,*) 'Exc 2: Cl_incp(<>0), Cs_incp (=0), Cr_incp (=0), unallocated, class, '
+       WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
+            b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
+       IF (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 2.1: unallocated less then 0: overspending, ', b_inc_tot - &
+               (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
+       ELSE
+          IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. zero) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 2.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
+               .LE. min_stomate) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .GT. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 2.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 25: Exc 2.4 unexpected result'
+             WRITE(numout,*) 'WARNING 25: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+
+    CASE (3)
+
+       ! Enough wood, grow leaves and roots
+       WRITE(numout,*) 'Exc 3: Cl_incp(<>0), Cs_incp(=0), Cr_incp(<>0), unallocated, class, '
+       WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), b_inc_tot - & 
+            (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))), l
+       IF (b_inc_tot - circ_class_n(ipts,j,l) * (Cl_incp(l) + Cs_incp(l) + Cr_incp(l))  &
+            .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 3.1: unallocated less then 0: overspending, ', b_inc_tot - &
+               (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) )
+       ELSE
+          IF ( (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) &
+               .GE. min_stomate) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l)) ) .LE. min_stomate) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l)) ) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 3.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
+               .LE. min_stomate) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l)) ) .GT. min_stomate) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l)) ) .GT. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 3.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 26: Exc 3.4 unexpected result'
+             WRITE(numout,*) 'WARNING 26: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(4)
+       ! Enough leaves and wood, grow roots
+       WRITE(numout,*) 'Exc 4: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, class, '
+       WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
+            b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
+       IF (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 4.1: unallocated less then 0: overspending, ', b_inc_tot - &
+               (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
+       ELSE
+          IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. zero) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 4.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
+               .LE. min_stomate) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l))) .GT. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 4.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 27: Exc 4.4 unexpected result'
+             WRITE(numout,*) 'WARNING 27: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(5)
+       ! Enough leaves and roots, grow wood
+       WRITE(numout,*) 'Exc 5: Cl_incp(=0), Cs_incp (<>0), Cr_incp (=0), unallocated, class, '
+       WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
+            b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
+       IF (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 5.1: unallocated less then 0: overspending, ', b_inc_tot - &
+               (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
+       ELSE
+          IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. zero) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 5.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
+               .LE. min_stomate) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .GT. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 5.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 28: Exc 5.4 unexpected result'
+             WRITE(numout,*) 'WARNING 28: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(6)
+       ! Enough leaves, grow wood and roots
+       WRITE(numout,*) 'Exc 6: Cl_incp(=0), Cs_incp(<>0), Cr_incp(<>0), unallocated'
+       WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
+            b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
+       IF (b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 6.1: unallocated less then 0: overspending, ', &
+               b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
+       ELSE
+          IF ( (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) .GE. zero) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .LE. min_stomate) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 6.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) .LE. min_stomate) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .GT. min_stomate) .OR. &
+               ((circ_class_n(ipts,j,l) * ABS(Cr_target(l)-Cr(l)-Cr_incp(l))) .GT. min_stomate) ) THEN
+             WRITE(numout,*) &
+                  'Exc 6.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 29: Exc 6.4 unexpected result'
+             WRITE(numout,*) 'WARNING 29: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(7)
+       ! Enough leaves and wood, grow roots
+       WRITE(numout,*) 'Exc 7: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, class, '
+       WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
+            b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
+       IF (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 7.1: unallocated less then 0: overspending, ', b_inc_tot - &
+               (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
+       ELSE
+          IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. zero) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 7.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
+               .LE. min_stomate) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .GT. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 7.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 30: Exc 7.4 unexpected result'
+             WRITE(numout,*) 'WARNING 30: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(8)
+       ! Enough leaves and roots, grow wood
+       WRITE(numout,*) 'Exc 8: Cl_incp(=0), Cs_incp (<>0), Cr_incp (=0), unallocated, class, '
+       WRITE(numout,*) Cl_incp(l), Cs_incp(l), Cr_incp(l), &
+            b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ), l
+       IF (b_inc_tot - (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 8.1: unallocated less then 0: overspending, ', b_inc_tot - &
+               (circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
+       ELSE
+          IF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) .GE. zero) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 8.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - ( circ_class_n(ipts,j,l)*(Cl_incp(l)+Cs_incp(l)+Cr_incp(l)) ) &
+               .LE. min_stomate) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .GT. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 8.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 31: Exc 8.4 unexpected result'
+             WRITE(numout,*) 'WARNING 31: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(9)
+       ! Enough roots, grow leaves and wood
+       WRITE(numout,*) 'Exc 9: delta_ba, Cl_incp(<>0), Cs_incp(<>0), Cr_incp(=0), unallocated, class, '
+       WRITE(numout,*) delta_ba(:), Cl_incp(l), Cs_incp(l), Cr_incp(l), &
+            b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))), l
+       IF (b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 9.1: unallocated less then 0: overspending, ', &
+               b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l)))
+       ELSE
+          IF ( (b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) .GE. zero) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .LE. min_stomate) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 9.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - (circ_class_n(ipts,j,l) * (Cl_incp(l)+Cs_incp(l)+Cr_incp(l))) &
+               .LE. min_stomate) .AND. &
+               ((circ_class_n(ipts,j,l) * ABS(Cl_target(l)-Cl(l)-Cl_incp(l))) .GT. min_stomate) .OR. &
+               ((circ_class_n(ipts,j,l) * ABS(Cs_target(l)-Cs(l)-Cs_incp(l))) .GT. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 9.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 32: Exc 9.4 unexpected result'
+             WRITE(numout,*) 'WARNING 32: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(10)
+       ! Ready for ordinary allocation
+       WRITE(numout,*) 'Ready for ordinary allocation?'
+       WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
+       WRITE(numout,*) 'b_inc_tot, ', b_inc_tot
+       WRITE(numout,*) 'Cl, Cs, Cr', Cl(:), Cs(:), Cr(:)
+       WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(:)-Cl(:)
+       WRITE(numout,*) 'Cs_target-Cs, ', Cs_target(:)-Cs(:)
+       WRITE(numout,*) 'Cr_target-Cr, ', Cr_target(:)-Cr(:)
+
+       IF (b_inc_tot .GT. min_stomate) THEN
+          IF (SUM(ABS(Cl_target(:)-Cl(:))) .LE. min_stomate) THEN
+             IF (SUM(ABS(Cs_target(:)-Cs(:))) .LE. min_stomate) THEN
+                IF (SUM(ABS(Cr_target(:)-Cr(:))) .LE. min_stomate) THEN
+                   IF (grow_wood) THEN
+                      WRITE(numout,*) 'should result in exc 10.1 or 10.2'
+                   ELSE
+                      WRITE(numout,*) 'No wood growth.  Not a problem!  Just an observation.'
+                   ENDIF
+                ELSE
+                   WRITE(numout,*) 'WARNING 34: problem with Cr_target'
+                   WRITE(numout,*) 'WARNING 34: PFT, ipts: ',j,ipts
+                ENDIF
+             ELSE
+                WRITE(numout,*) 'WARNING 35: problem with Cs_target'
+                WRITE(numout,*) 'WARNING 35: PFT, ipts: ',j,ipts
+             ENDIF
+          ELSE
+             WRITE(numout,*) 'WARNING 36: problem with Cl_target'
+             WRITE(numout,*) 'WARNING 36: PFT, ipts: ',j,ipts
+          ENDIF
+       ELSEIF(b_inc_tot .LT. -min_stomate) THEN 
+          WRITE(numout,*) 'WARNING 37: problem with b_inc_tot'
+          WRITE(numout,*) 'WARNING 37: PFT, ipts: ',j,ipts
+       ELSE
+          WRITE(numout,*) 'no unallocated fraction'
+       ENDIF
+
+    CASE(11)
+       ! Ordinary allocation
+       WRITE(numout,*) 'delta_ba, ', delta_ba
+       IF ( (SUM(Cl_inc(:)) .GE. zero) .AND. (SUM(Cs_inc(:)) .GE. zero) .AND. &
+            (SUM(Cr_inc(:)) .GE. zero) .AND. &
+            ( b_inc_tot - SUM(circ_class_n(ipts,j,:) * (Cl_inc(:)+Cs_inc(:)+Cr_inc(:))) .GT. -1*min_stomate) .AND. &
+            ( b_inc_tot - SUM(circ_class_n(ipts,j,:) * (Cl_inc(:)+Cs_inc(:)+Cr_inc(:))) .LT. min_stomate ) ) THEN
+          WRITE(numout,*) 'Exc 10.1: Ordinary allocation was succesful'
+          WRITE(numout,*) 'Cl_inc, Cs_inc, Cr_inc, unallocated', Cl_inc(:), Cs_inc(:), Cr_inc(:), & 
+               b_inc_tot - SUM(circ_class_n(ipts,j,:) * (Cl_inc(:)+Cs_inc(:)+Cr_inc(:)))
+       ELSE
+          WRITE(numout,*) 'WARNING 38: Exc 10.2 problem with ordinary allocation'
+          WRITE(numout,*) 'WARNING 38: PFT, ipts: ',j,ipts
+          WRITE(numout,*) 'Cl_inc, Cs_inc, Cr_inc, unallocated', Cl_inc(:), Cs_inc(:), Cr_inc(:), & 
+               b_inc_tot - SUM(circ_class_n(ipts,j,:) * (Cl_inc(:)+Cs_inc(:)+Cr_inc(:)))
+       ENDIF
+
+    CASE(12)
+       ! Enough leaves and structure, grow roots
+       WRITE(numout,*) 'Exc 1: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, '
+       WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
+            b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
+       IF (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 1.1: unallocated less then 0: overspending, ', b_inc_tot - &
+               (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
+       ELSE
+          IF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. zero) .AND. &
+               ((ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 1.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
+               .LE. min_stomate) .AND. &
+               (ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1)) .GT. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 1.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 39: Exc 1.4 unexpected result'
+             WRITE(numout,*) 'WARNING 39: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(13)
+       ! Enough structural C and roots, grow leaves
+       WRITE(numout,*) 'Exc 2: Cl_incp(<>0), Cs_incp (=0), Cr_incp (=0), unallocated, '
+       WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
+            b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
+       IF (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 2.1: unallocated less then 0: overspending, ', b_inc_tot - &
+               (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
+       ELSE
+          IF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. zero) .AND. &
+               ((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 2.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
+               .LE. min_stomate) .AND. &
+               ((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .GT. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 2.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 40: Exc l.4 unexpected result'
+             WRITE(numout,*) 'WARNING 40: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(14)
+       ! Enough structural C and root, grow leaves
+       WRITE(numout,*) 'Exc 3: Cl_incp(<>0), Cs_incp(=0), Cr_incp(<>0), unallocated, '
+       WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), b_inc_tot - & 
+            (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
+       IF (b_inc_tot - ind(ipts,j) * (Cl_incp(1) + Cs_incp(1) + Cr_incp(1))  &
+            .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 3.1: unallocated less then 0: overspending, ', b_inc_tot - &
+               (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
+       ELSE
+          IF ( (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1))) &
+               .GE. min_stomate) .AND. &
+               ((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1)) ) .LE. min_stomate) .AND. &
+               ((ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1)) ) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 3.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
+               .LE. min_stomate) .AND. &
+               ((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1)) ) .GT. min_stomate) .AND. &
+               ((ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1)) ) .GT. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 3.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 41: Exc 3.4 unexpected result'
+             WRITE(numout,*) 'WARNING 41: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(15)
+       ! Enough leaves and structural C, grow roots
+       WRITE(numout,*) 'Exc 4: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, '
+       WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
+            b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
+       IF (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 4.1: unallocated less then 0: overspending, ', b_inc_tot - &
+               (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
+       ELSE
+          IF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. zero) .AND. &
+               ((ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 4.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
+               .LE. min_stomate) .AND. &
+               ((ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1))) .GT. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 4.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 42: Exc 4.4 unexpected result'
+             WRITE(numout,*) 'WARNING 42: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(16)
+       ! Enough leaves and roots, grow structural C            
+       WRITE(numout,*) 'Exc 5: Cl_incp(=0), Cs_incp (<>0), Cr_incp (=0), unallocated, '
+       WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
+            b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
+       IF (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 5.1: unallocated less then 0: overspending, ', b_inc_tot - &
+               (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
+       ELSE
+          IF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. zero) .AND. &
+               ((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 5.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
+               .LE. min_stomate) .AND. &
+               ((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .GT. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 5.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 43: Exc 5.4 unexpected result'
+             WRITE(numout,*) 'WARNING 43: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(17)
+       ! Enough leaves, grow structural C and roots
+       WRITE(numout,*) 'Exc 6: Cl_incp(=0), Cs_incp(<>0), Cr_incp(<>0), unallocated'
+       WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
+            b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
+       IF (b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1))) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 6.1: unallocated less then 0: overspending, ', &
+               b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
+       ELSE
+          IF ( (b_inc_tot - ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) .GE. zero) .AND. &
+               ((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .LE. min_stomate) .AND. &
+               ((ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 6.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) .LE. min_stomate) .AND. &
+               ((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .GT. min_stomate) .AND. &
+               ((ind(ipts,j) * ABS(Cr_target(1)-Cr(1)-Cr_incp(1))) .GT. min_stomate) ) THEN
+             WRITE(numout,*) &
+                  'Exc 6.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 44: Exc 6.4 unexpected result'
+             WRITE(numout,*) 'WARNING 44: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(18)
+       ! Enough leaves and structural C, grow roots
+       WRITE(numout,*) 'Exc 7: Cl_incp(=0), Cs_incp (=0), Cr_incp (<>0), unallocated, '
+       WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
+            b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
+       IF (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 7.1: unallocated less then 0: overspending, ', b_inc_tot - &
+               (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
+       ELSE
+          IF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. zero) .AND. &
+               ((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 7.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
+               .LE. min_stomate) .AND. &
+               ((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .GT. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 7.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 45: Exc 7.4 unexpected result'
+             WRITE(numout,*) 'WARNING 45: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(19)
+       ! Enough leaves and roots, grow structural C
+       WRITE(numout,*) 'Exc 8: Cl_incp(=0), Cs_incp (<>0), Cr_incp (=0), unallocated, '
+       WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
+            b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) )
+       IF (b_inc_tot - (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 8.1: unallocated less then 0: overspending, ', b_inc_tot - &
+               (ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
+       ELSE
+          IF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) .GE. zero) .AND. &
+               ((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 8.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - ( ind(ipts,j)*(Cl_incp(1)+Cs_incp(1)+Cr_incp(1)) ) &
+               .LE. min_stomate) .AND. &
+               ((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .GT. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 8.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 46: Exc 8.4 unexpected result'
+             WRITE(numout,*) 'WARNING 46: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(20)
+       ! Enough roots, grow structural C and leaves
+       WRITE(numout,*) 'Exc 9: Cl_incp(<>0), Cs_incp(<>0), Cr_incp(=0), unallocated, '
+       WRITE(numout,*) Cl_incp(1), Cs_incp(1), Cr_incp(1), &
+            b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
+       WRITE(numout,*) 'term 1', b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
+       WRITE(numout,*) 'term 2', (ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1)))
+       WRITE(numout,*) 'term 3', (ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1)))
+       IF (b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1))) .LT. -min_stomate) THEN
+          WRITE(numout,*) 'Exc 9.1: unallocated less then 0: overspending, ', &
+               b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1)))
+       ELSE
+          IF ( (b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1))) .GE. zero) .AND. &
+               ((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .LE. min_stomate) .AND. &
+               ((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .LE. min_stomate) ) THEN
+             WRITE(numout,*) 'Exc 9.2: unallocated <>= 0 but tree is in good shape: successful allocation'
+          ELSEIF ( (b_inc_tot - (ind(ipts,j) * (Cl_incp(1)+Cs_incp(1)+Cr_incp(1))) .LE. min_stomate) .AND. &
+               (((ind(ipts,j) * ABS(Cl_target(1)-Cl(1)-Cl_incp(1))) .GT. min_stomate) .OR. &
+               ((ind(ipts,j) * ABS(Cs_target(1)-Cs(1)-Cs_incp(1))) .GT. min_stomate) ) ) THEN
+             WRITE(numout,*) 'Exc 9.3: unallocated = 0, but the tree needs more reshaping: successful allocation'
+          ELSE
+             WRITE(numout,*) 'WARNING 47: Exc 9.4 unexpected result'
+             WRITE(numout,*) 'WARNING 47: PFT, ipts: ',j,ipts
+          ENDIF
+       ENDIF
+
+    CASE(21)
+       ! Ready for ordinary allocation
+       WRITE(numout,*) 'Ready for ordinary allocation?'
+       WRITE(numout,*) 'KF, LF, ', KF(ipts,j), LF(ipts,j)
+       WRITE(numout,*) 'b_inc_tot, ', b_inc_tot
+       WRITE(numout,*) 'Cl, Cs, Cr', Cl(1), Cs(1), Cr(1)
+       WRITE(numout,*) 'Cl_target-Cl, ', Cl_target(1)-Cl(1)
+       WRITE(numout,*) 'Cs_target-Cs, ', Cs_target(1)-Cs(1)
+       WRITE(numout,*) 'Cr_target-Cr, ', Cr_target(1)-Cr(1)
+       IF (b_inc_tot .GT. min_stomate) THEN
+          IF (ABS(Cl_target(1)-Cl(1)) .LE. min_stomate) THEN
+             IF (ABS(Cs_target(1)-Cs(1)) .LE. min_stomate) THEN
+                IF (ABS(Cr_target(1)-Cr(1)) .LE. min_stomate) THEN
+                   IF (b_inc_tot .GT. min_stomate) THEN
+                      IF (grow_wood) THEN
+                         WRITE(numout,*) 'should result in exc 10.1 or 10.2'
+                      ELSE
+                         WRITE(numout,*) 'WARNING 48: no wood growth'
+                         WRITE(numout,*) 'WARNING 48: PFT, ipts: ',j,ipts
+                      ENDIF
+                   ENDIF
+                ELSE
+                   WRITE(numout,*) 'WARNING 49: problem with Cr_target'
+                   WRITE(numout,*) 'WARNING 49: PFT, ipts: ',j,ipts
+                ENDIF
+             ELSE
+                WRITE(numout,*) 'WARNING 50: problem with Cs_target'
+                WRITE(numout,*) 'WARNING 50: PFT, ipts: ',j,ipts
+             ENDIF
+          ELSE
+             WRITE(numout,*) 'WARNING 51: problem with Cl_target'
+             WRITE(numout,*) 'WARNING 51: PFT, ipts: ',j,ipts
+          ENDIF
+       ELSEIF(b_inc_tot .LT. -min_stomate) THEN 
+          WRITE(numout,*) 'WARNING 52: problem with b_inc_tot'
+          WRITE(numout,*) 'WARNING 52: PFT, ipts: ',j,ipts
+       ELSE
+          WRITE(numout,*) 'no unallocated fraction'
+       ENDIF
+
+    CASE(22)
+       ! Ordinary allocation
+       IF ( ((Cl_inc(1)) .GE. zero) .AND. ((Cs_inc(1)) .GE. zero) .AND. &
+            ((Cr_inc(1)) .GE. zero) .AND. &
+            ( b_inc_tot - (ind(ipts,j) * (Cl_inc(1)+Cs_inc(1)+Cr_inc(1))) .GT. -1*min_stomate) .AND. &
+            ( b_inc_tot - (ind(ipts,j) * (Cl_inc(1)+Cs_inc(1)+Cr_inc(1))) .LT. min_stomate ) ) THEN
+          WRITE(numout,*) 'Exc 10.1: Ordinary allocation was succesful'
+          WRITE(numout,*) 'Cl_inc, Cs_inc, Cr_inc, unallocated', Cl_inc(1), Cs_inc(1), Cr_inc(1), & 
+               b_inc_tot - (ind(ipts,j) * (Cl_inc(1)+Cs_inc(1)+Cr_inc(1)))
+       ELSE
+          WRITE(numout,*) 'WARNING 53: Exc 10.2 problem with ordinary allocation'
+          WRITE(numout,*) 'WARNING 53: PFT, ipts: ',j,ipts
+          WRITE(numout,*) 'Cl_inc, Cs_inc, Cr_inc, unallocated', Cl_inc(1), Cs_inc(1), Cr_inc(1), & 
+               b_inc_tot - (ind(ipts,j) * (Cl_inc(1)+Cs_inc(1)+Cr_inc(1)))
+       ENDIF
+
+    END SELECT
+
+  END SUBROUTINE comment
+
+END MODULE stomate_growth_fun_all
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_growth_res_lim.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_growth_res_lim.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_growth_res_lim.f90	(revision 7236)
@@ -0,0 +1,1125 @@
+! =================================================================================================================================
+! MODULE       : stomate_growth_res_lim
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+!                This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Plant growth and C-allocation among the biomass components (leaves, wood, roots, fruit, reserves) 
+!!               is calculated making use of the resource limitation scheme proposed by Friedlingstein et al 1999.      
+!!
+!!\n DESCRIPTION: This module calculates three processes: (1) daily maintenance respiration based on the half-hourly
+!!               respiration calculated in stomate_resp.f90, (2) the allocation fractions to the different biomass
+!!               components based on the resource-limitation approach and (3) the allocatable biomass as the residual
+!!               of GPP-Ra. Multiplication of the allocation fractions and allocatable biomass given the changes in
+!!               biomass pools.
+!!
+!! RECENT CHANGE(S): Until 1.9.6 the calculations in this routine were distributed over stomate_alloc.f90 and
+!!               stomate_npp.f90. Given the strong dependencies of both routines they were merged in this module.
+!!               At the same time an alternative growth module (stomate_growth_fun_all.f90) was introduced.               
+!!
+!! REFERENCE(S)	: - Friedlingstein, P., G. Joel, C.B. Field, and Y. Fung (1999), Towards an allocation
+!!               scheme for global terrestrial carbon models, Global Change Biology, 5, 755-770.\n
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE stomate_growth_res_lim
+
+  ! Modules used:
+
+  USE ioipsl_para
+  USE pft_parameters
+  USE stomate_data
+  USE constantes
+  USE constantes_soil
+
+  IMPLICIT NONE
+
+  ! Private & public routines
+
+  PRIVATE
+  PUBLIC growth_res_lim_clear, growth_res_lim
+
+  ! Variables shared by all subroutines in this module
+
+  LOGICAL, SAVE                                             :: firstcall = .TRUE.  !! Is this the first call? (true/false) 
+  
+  CONTAINS
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : growth_res_lim_clear
+!!
+!>\BRIEF          Set the flag ::firstcall to .TRUE. and as such activate section 
+!! 1.1 of the subroutine alloc (see below).\n
+!!
+!_ ================================================================================================================================
+
+  SUBROUTINE growth_res_lim_clear
+    firstcall = .TRUE.
+  END SUBROUTINE growth_res_lim_clear
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: growth_res_lim
+!!
+!>\BRIEF        Calculate NPP as the difference between GPP and respiration (= growth + 
+!! maintenance respiration). Distribute NPP over all compartments (carbon reserves, 
+!! aboveground sapwood, belowground sapwood, root, fruits and leaves following 
+!! Friedlingstein et al. (1999).
+!!
+!! DESCRIPTION  : NPP is calculated from three components: Gross Primary Productivity 
+!! (GPP), maintenance respiration and growth respiration 
+!! (all in @tex $ gC.m^{-2}dt^{-1} $ @endtex), following the convention that positive 
+!! fluxes denote fluxes from the plants to the atmosphere. GPP is the input variable from
+!! which, in the end, NPP or total allocatable biomass @tex $(gC.m^{-2})$ @endtex is 
+!! calculated. Net primary production is then calculated as:\n	
+!! NPP = GPP - growth_resp - maint-resp   [eq. 1]\n   
+!!	
+!! The calculation of maintenance respiration is done in routine stomate_resp.f90. 
+!! Maintenance respiration is calculated for the whole plant and is therefore removed from 
+!! the total allocatable biomass. In order to prevent all allocatable biomass from being 
+!! used for maintenance respiration, a limit fraction of total allocatable biomass, tax_max, 
+!! is defined (in the variables declaration). If maintenance respiration exceeds tax_max 
+!! (::bm_tax_max), the maximum allowed allocatable biomass will be respired and the remaining 
+!! respiration, required in excess of tax_max, is taken out from tissues already present in 
+!! the plant biomass.\n  
+!! 
+!! After total allocatable biomass has been updated by removing maintenance respiration, 
+!! total allocatable biomass is distributed to all plant compartments according to the 
+!! f_alloc fractions also calculated in this routine.\n
+!! 
+!! The philosophy underlying the allocation scheme is that allocation patterns
+!! result from evolved responses that adjust carbon investments to facilitate capture of 
+!! most limiting resources i.e. light, water and mineral nitrogen. The implemented scheme 
+!! calculates the limitation of light, water and nitrogen. However, nitrogen is not a 
+!! prognostic variable of the model and therefore soil temperature and soil moisture 
+!! are used as a proxy for soil nitrogen availability.\n
+!! Sharpe & Rykiel (1991) proposed a generic relationship between the allocation of 
+!! carbon to a given plant compartment and the availability of a particular resource:\n
+!! \latexonly 
+!!   \input{alloc1.tex}
+!! \endlatexonly
+!! \n
+!! where A is the allocation of biomass production (NPP) to a given compartment (either 
+!! leaves, stem, or roots). Xi and Yj are resource availabilities (e.g. light, water, 
+!! nutrient). For a given plant compartment, a resource can be of type X or Y. An increase 
+!! in a X-type resource will increase the allocation to compartment A. An increase in a 
+!! Y-type resource will, however, lead to a decrease in carbon allocation to that compartment. 
+!! In other words, Y-type resources are those for which uptake increases with increased 
+!! investment in the compartment in question. X-type resources, as a consequence of 
+!! trade-offs, are the opposite. For example, water is a Y-type resource for root allocation. 
+!! Water-limited conditions should promote carbon allocation to roots, which enhance water 
+!! uptake and hence minimize plant water stress. Negative relationships between investment 
+!! and uptake arise when increased investment in one compartment leads, as required for 
+!! conservation of mass, to decreased investment in a component involved in uptake of 
+!! that resource.\n
+!!
+!! The implemented scheme allocates carbon to the following components:\n
+!! - Carbon reserves;\n
+!! - Aboveground sapwood;\n
+!! - Belowground sapwood;\n
+!! - Roots;\n
+!! - Fruits/seeds and\n
+!! - Leaves.
+!! \n
+!!
+!! The allocation to fruits and seeds is simply a 10% "tax" of the total biomass 
+!! production.\n
+!! Following carbohydrate use to support budburst and initial growth, the 
+!! carbohydrate reserve is refilled. The daily amount of carbon allocated to the 
+!! reserve pool is proportional to leaf+root allocation (::LtoLSR and ::RtoLSR).
+!! Sapwood and root allocation (respectively ::StoLSR and ::RtoLSR) are proportional 
+!! to the estimated light and soil (water and nitrogen) stress (::Limit_L and 
+!! ::Limit_NtoW). Further, Sapwood allocation is separated in belowground sapwood 
+!! and aboveground sapwood making use of the parameter (:: alloc_sap_above_tree
+!! or ::alloc_sap_above_grass). For trees partitioning between above and 
+!! belowground compartments is a function of PFT age. Leaf allocation (::LtoLSR) 
+!! is calculated as the residual of root and sapwood 
+!! allocation (LtoLSR(:) = 1. - RtoLSR(:) - StoLSR(:).\n
+!!
+!! Growth respiration is calculated as a fraction of allocatable biomass for each part 
+!! of the plant. The fraction coefficient ::frac_growth_resp is defined in 
+!! stomate_constants.f90 and is currently set to be the same for all plant compartments. 
+!! Is it thus assumed that it takes as much energy to grow a leaf as it is to grow 
+!! wood. Allocatable biomass of all plant compartments are updated by removing what is 
+!! lost through growth respiration. Net allocatable biomass (total allocatable biomass 
+!! after maintenance and growth respiration) is added to the current biomass for each 
+!! plant compartment.\n
+!!
+!! Finally, leaf age and plant age are updated. Leaf age is described with the concept 
+!! of "leaf age classes". A number of leaf age classes (::nleafages) is defined in 
+!! stomate_constants.f90. Each leaf age class contains a fraction (::leaf_frac) of the 
+!! total leaf biomass. When new biomass is added to leaves, the age of the biomass in 
+!! the youngest leaf age class is decreased. The fractions of leaves in the other leaf 
+!! ages classes are also updated as the total biomass has increased. Plant age is 
+!! updated first by increasing the age of the previous biomass by one time step, and 
+!! then by adjusting this age as the average of the ages of the previous and the new 
+!! biomass.
+!!
+!! RECENT CHANGE(S): Until 1.9.6 the calculations in this routine were distributed over 
+!! stomate_alloc.f90 and stomate_npp.f90. Given the strong dependencies of both routines 
+!! they were merged in a single module. The underlying science and principles were not 
+!! changed. This new module (stomate_growth_res_lim) exactely reproduces the results 
+!! from the previous implementation (stomate_alloc and stomate_npp). At the same time an 
+!! alternative growth module (stomate_growth_fun_all.f90), based on the pipe-model, was 
+!! added to the code.
+!!
+!! MAIN OUTPUT VARIABLE(S): ::npp and ::biomass; fraction of NPP that is allocated to the 
+!! six different biomass compartments (leaves, roots, above and belowground wood, 
+!! carbohydrate reserves and fruits). DIMENSION(npts,nvm,nparts).
+!!
+!! REFERENCE(S)	:
+!! - Friedlingstein, P., G. Joel, C.B. Field, and Y. Fung (1999), Towards an allocation
+!! scheme for global terrestrial carbon models, Global Change Biology, 5, 755-770.\n
+!! - Krinner G, Viovy N, de Noblet-Ducoudr N, Ogee J, Polcher J, Friedlingstein P,
+!! Ciais P, Sitch S, Prentice I C (2005) A dynamic global vegetation model for studies
+!! of the coupled atmosphere-biosphere system. Global Biogeochemical Cycles, 19, GB1015,
+!! doi: 10.1029/2003GB002199.\n
+!! - F.W.T.Penning De Vries, A.H.M. Brunsting, H.H. Van Laar. 1974. Products, requirements 
+!! and efficiency of biosynthesis a quantitative approach. Journal of Theoretical Biology, 
+!! Volume 45, Issue 2, June 1974, Pages 339-377.
+!! - Sharpe, P.J.H., and Rykiel, E.J. (1991), Modelling integrated response of plants 
+!! to multiple stresses. In: Response of Plants to Multiple Stresses (eds Mooney, H.A., 
+!! Winner, W.E., Pell, E.J.), pp. 205-224, Academic Press, San Diego, CA.\n
+!!
+!! +++++++++++++++++++++
+!! MAKE A NEW FLOW CHART
+!! +++++++++++++++++++++
+!! FLOWCHART    : 
+!! \latexonly
+!! \includegraphics[scale=0.14]{stomate_npp_flow.jpg}
+!! \endlatexonly
+!! \n 
+!! \latexonly 
+!!   \includegraphics[scale=0.5]{allocflow.jpg}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE growth_res_lim (npts, dt, lai, veget_max, &
+       PFTpresent, senescence, when_growthinit, moiavail_week, &
+       soilhum_month, tsoil_month, gpp, resp_maint_part, &
+       resp_maint, resp_growth, npp, biomass, &
+       age, leaf_age, leaf_frac)
+!, use_reserve)                                              
+ 
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                               :: npts			!! Domain size - number of grid cells 
+                                                                                        !! (unitless)
+    REAL(r_std), INTENT(in)                                  :: dt			!! Time step of the simulations for stomate
+                                                                                        !! (days)    
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: lai			!! PFT leaf area index 
+                                                                                        !! @tex $(m^2 m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: veget_max		!! PFT "Maximal" coverage fraction of a PFT  
+                                                                                        !! @tex $(m^2 m^{-2})$ @endtex   
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: when_growthinit	        !! Days since beginning of growing season 
+                                                                                        !! (days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: moiavail_week		!! PFT moisture availability - integrated
+                                                                                        !! over a week (0-1, unitless) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: gpp                     !! PFT gross primary productivity 
+                                                                                        !! @tex $(gC.m^{-2}dt^{-1})$ @endtex                                       
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)            :: tsoil_month		!! PFT soil temperature - integrated over 
+                                                                                        !! a month (K) 
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)            :: soilhum_month		!! PFT soil humidity - integrated over a 
+                                                                                        !! month (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(in)      :: resp_maint_part         !! Maintenance respiration of different plant 
+                                                                                        !! parts @tex $(gC.m^{-2}dt^{-1})$ @endtex  
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                 :: senescence		!! Is the PFT senescent?  - only for 
+                                                                                        !! deciduous trees (true/false)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                 :: PFTpresent              !! PFT exists (true/false)
+    
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)            :: resp_maint              !! PFT maintenance respiration 
+                                                                                        !! @tex $(gC.m^{-2}dt^{-1})$ @endtex		    
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)            :: resp_growth             !! PFT growth respiration 
+                                                                                        !! @tex $(gC.m^{-2}dt^{-1})$ @endtex				
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)            :: npp                     !! PFT net primary productivity 
+                                                                                        !! @tex $(gC.m^{-2}dt^{-1})$ @endtex
+
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)          :: age                     !! PFT age (years)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(inout)   :: biomass	!! PFT total biomass 
+                                                                                        !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout):: leaf_age		!! PFT age of different leaf classes 
+                                                                                        !! (days)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout):: leaf_frac		!! PFT fraction of leaves in leaf age class
+                                                                                        !! (0-1, unitless)
+
+    !! 0.4 Local variables
+                          
+    INTEGER(i_std)                                           :: i,j,k,l,m	        !! Indices (unitless)
+    REAL(r_std)                                              :: reserve_time		!! Maximum number of days during which 
+                                                                                        !! carbohydrate reserve may be used (days)
+    REAL(r_std), DIMENSION(nvm)                              :: lai_happy_old		!! Lai threshold below which carbohydrate 
+                                                                                        !! reserve may be used 
+                                                                                        !! @tex $(m^2 m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts)                             :: limit_L	        	!! Lights stress (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: limit_N	        	!! Total nitrogen stress (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: limit_N_temp		!! Stress from soil temperature on nitrogen
+                                                                                        !! mineralisation (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: limit_N_hum		!! Stress from soil humidity on nitrogen 
+                                                                                        !! mineralisation (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: limit_W		        !! Soil water stress (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: limit_WorN		!! Most limiting factor in the soil: 
+                                                                                        !! nitrogen or water (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: limit			!! Most limiting factor: amongst limit_N, 
+                                                                                        !! limit_W and limit_L (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: t_nitrogen		!! Preliminairy soil temperature stress 
+                                                                                        !! used as a proxy for nitrogen stress (K)
+    REAL(r_std), DIMENSION(npts)                             :: h_nitrogen		!! Preliminairy soil humidity stress used 
+                                                                                        !! as a proxy for nitrogen stress 
+                                                                                        !! (unitless)  
+    REAL(r_std), DIMENSION(npts)                             :: rpc			!! Scaling factor for integrating vertical
+                                                                                        !! soil profiles (unitless) 	
+    REAL(r_std), DIMENSION(npts)                             :: LtoLSR		        !! Ratio between leaf-allocation and 
+                                                                                        !! (leaf+sapwood+root)-allocation 
+                                                                                        !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: StoLSR		        !! Ratio between sapwood-allocation and 
+                                                                                        !! (leaf+sapwood+root)-allocation 
+                                                                                        !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: RtoLSR		        !! Ratio between root-allocation and 
+                                                                                        !! (leaf+sapwood+root)-allocation 
+                                                                                        !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: carb_rescale		!! Rescaling factor for allocation factors
+                                                                                        !! if carbon is allocated to carbohydrate 
+                                                                                        !! reserve (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: natveg_tot		!! Total natural vegetation cover on 
+                                                                                        !! natural part of the grid cell 
+                                                                                        !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: lai_nat		        !! Average LAI on natural part of the grid
+                                                                                        !! cell @tex $(m^2 m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts)                             :: alloc_sap_above	        !! Fraction of sapwood 
+                                                                                        !! allocation to above ground sapwood 
+                                                                                        !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: bm_add                  !! Biomass increase @tex $(gC.m^{-2})$ @endtex		
+    REAL(r_std), DIMENSION(npts)                             :: bm_new                  !! New biomass @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts)                             :: bm_tax_max              !! Maximum part of allocatable biomass used for 
+                                                                                        !! respiration @tex $(gC.m^{-2})$ @endtex	
+    REAL(r_std), DIMENSION(npts)                             :: bm_pump                 !! Biomass that remains to be taken away 
+                                                                                        !! @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                         :: transloc_leaf		!! Fraction of carbohydrate reserve used 
+                                                                                        !! (::use_reserve) to support leaf growth 
+                                                                                        !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                         :: use_reserve             !! Mass taken from carbohydrate reserve
+                                                                                        !! @tex $(gC m^{-2})$ @endtex				
+    REAL(r_std), DIMENSION(npts,nvm)                         :: bm_create               !! Biomass created when biomass<0 because of dark
+                                                                                        !! respiration @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                         :: bm_alloc_tot            !! Allocatable biomass for the whole plant
+                                                                                        !! @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                         :: dia                     !! Tree diameter (cm)
+    REAL(r_std), DIMENSION(npts,nvm)                         :: ltor                    !! Leaf to root ratio (unitless)
+    REAL(r_std), DIMENSION(npts,nvm)                         :: leaf_mass_young	        !! Leaf biomass in youngest leaf age class 
+                                                                                        !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                         :: lm_old		        !! Variable to store leaf biomass from 
+                                                                                        !! previous time step 
+                                                                                        !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                         :: lai_around		!! lai on natural part of the grid cell, or
+                                                                                        !! of agricultural PFTs 
+                                                                                        !! @tex $(m^2 m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                         :: veget_max_nat 	        !! Vegetation cover of natural PFTs on the 
+                                                                                        !! grid cell (agriculture masked) 
+                                                                                        !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nparts)                      :: resp_growth_part        !! Growth respiration of different plant parts
+                                                                                        !! @tex $(gC.m^{-2}dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts)                  :: f_alloc		        !! PFT fraction of NPP that is allocated to
+                                                                                        !! the different components (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements)        :: bm_alloc                !! PFT biomass increase, i.e. NPP per plant part 
+                                                                                        !! @tex $(gC.m^{-2}dt^{-1})$ @endtex**2
+    REAL(r_std), SAVE, DIMENSION(0:nbdl)                     :: z_soil		        !! Variable to store depth of the different
+                                                                                        !! soil layers (m)
+!_ =================================================================================================================================
+
+
+!! 1. Initialize
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering resource limited growth'
+
+    !! 1.1 First call only
+    IF ( firstcall ) THEN
+      
+       !! 1.1.1 Initialization
+       L0(2:nvm) = un - R0 - S0(2:nvm)
+       IF ((MINVAL(L0(2:nvm)) .LT. zero) .OR. (MAXVAL(S0(2:nvm)) .EQ. un)) THEN 
+
+          CALL ipslerr_p (3,'in module stomate_alloc', &
+               &           'Something wrong happened', &
+               &           'L0 negative or division by zero if S0 = 1', &
+               &           '(Check your parameters.)')
+
+       ENDIF
+
+
+       !! 1.1.2 Copy the depth of the different soil layers (number of layers=nbdl) 
+       !        previously calculated as variable diaglev in routines sechiba.f90 and slowproc.f90
+       z_soil(0) = 0.
+       z_soil(1:nbdl) = diaglev(1:nbdl)
+
+       !! 1.1.3 Print flags and parameter settings
+       WRITE(numout,*) 'allocation:'
+       WRITE(numout,'(a)',ADVANCE='NO') '    > We'
+       !IF ( .NOT. ok_minres ) WRITE(numout,'(a,$)') ' do NOT'
+       WRITE(numout,*) 'try to reach a minumum reservoir when severely stressed.'
+       WRITE(numout,*) '   > Time delay (days) to build leaf mass (::tau_leafinit): ', tau_leafinit
+       WRITE(numout,*) '   > Curvature of root mass with increasing soil depth (::z_nitrogen): ', z_nitrogen
+       WRITE(numout,*) '   > Sap allocation above the ground / total sap allocation (0-1, unitless): '
+       WRITE(numout,*) '       grasses (::alloc_sap_above_grass) :', alloc_sap_above_grass
+       WRITE(numout,*) '   > Default root alloc fraction (1; ::R0): ', R0
+       WRITE(numout,*) '   > Default sapwood alloc fraction (1; ::S0): ', S0(:)
+       WRITE(numout,*) '   > Default fruit allocation (1, ::f_fruit): ', f_fruit
+       WRITE(numout,*) '   > Minimum (min_LtoLSR)/maximum (::max_LtoLSR)leaf alloc fraction (0-1, unitless): ',&
+            min_LtoLSR,max_LtoLSR
+       WRITE(numout,*) '   > Maximum time (days) the carbon reserve can be used:'
+       WRITE(numout,*) '       trees (reserve_time_tree):',reserve_time_tree
+       WRITE(numout,*) '       grasses (reserve_time_grass):',reserve_time_grass
+  
+       firstcall = .FALSE.
+
+    ENDIF
+    
+    !! 1.2 Every call
+
+    !! 1.2.1 Reset output variable (::f_alloc)
+    f_alloc(:,:,:) = zero
+    f_alloc(:,:,icarbres) = un
+    bm_alloc(:,:,:,icarbon) = zero
+    resp_maint(:,:) = zero
+    resp_growth(:,:) = zero
+    npp(:,:) = zero
+    use_reserve(:,:) = zero
+ 
+
+    !! 1.2.2 Proxy for soil nitrogen stress
+    !  Nitrogen availability and thus N-stress can not be calculated by the model. Water and
+    !  temperature stress are used as proxy under the assumption that microbial activity is 
+    !  determined by soil temperature and water availability. In turn, microbial activity is 
+    !  assumed to be an indicator for nitrogen mineralisation and thus its availability. 
+
+    !! 1.2.2.1 Convolution of nitrogen stress with root profile 
+    !  Here we calculate preliminary soil temperature and soil humidity stresses that will be used 
+    !  as proxies for nitrogen stress. Their calculation follows the nitrogen-uptake capacity of roots.
+    !  The capacity of roots to take up nitrogen is assumed to decrease exponentially with 
+    !  increasing soil depth. The curvature of the exponential function describing the 
+    !  nitrogen-uptake capacity of roots (= root mass * uptake capacity) is given by 
+    !  ::z_nitrogen. Strictly speaking its unit is meters (m). Despite its units this parameter 
+    !  has no physical meaning.
+    !  Because the roots are described by an exponential function but the soil depth is limited to
+    !  ::z_soil(nbdl), the root profile is truncated at ::z_soil(nbdl). For numerical reasons, 
+    !  the total capacity of the soil profile for nitrogen uptake should be 1. To this aim a scaling
+    !  factor (::rpc) is calculated as follows:\n
+    !  \latexonly
+    !  \input{alloc2.tex} 
+    !  \endlatexonly
+    !  Then temperature (::t_nitrogen) and humidity (::h_nitrogen) proxies for nitrogen stress are 
+    !  calculated using mean weighted (weighted by nitrogen uptake capacity) soil temperature (::tsoil_month)
+    !  or soil moisture (::soil_hum_month) (calculated in stomate_season.f90). 
+    !  \latexonly
+    !  \input{alloc3.tex} 
+    !  \endlatexonly
+    !  \latexonly
+    !  \input{alloc4.tex} 
+    !  \endlatexonl	
+    !  \n 
+    ! Scaling factor for integration
+    rpc(:) = un / ( un - EXP( -z_soil(nbdl) / z_nitrogen ) )
+
+    ! Integrate over # soil layers
+    t_nitrogen(:) = zero
+
+    DO l = 1, nbdl ! Loop over # soil layers
+
+       t_nitrogen(:) = t_nitrogen(:) + tsoil_month(:,l) * rpc(:) * &
+            ( EXP( -z_soil(l-1)/z_nitrogen ) - EXP( -z_soil(l)/z_nitrogen ) )
+
+    ENDDO ! Loop over # soil layers
+
+    !---TEMP---
+    WRITE(numout,*) 't_nitrogen, ', t_nitrogen(:)
+    !----------
+
+    !! 1.2.2.2 Convolution for soil moisture
+    !  Integrate over # soil layers
+    h_nitrogen(:) = zero
+
+    DO l = 1, nbdl ! Loop over # soil layers
+
+       h_nitrogen(:) = &
+            h_nitrogen(:) + soilhum_month(:,l) * rpc(:) * &
+            ( EXP( -z_soil(l-1)/z_nitrogen ) - EXP( -z_soil(l)/z_nitrogen ) )
+
+    ENDDO ! Loop over # soil layers
+    
+    !---TEMP---
+    WRITE(numout,*) 'h_nitrogen, ', h_nitrogen(:)
+    !----------
+
+    !! 1.2.3 Separate between natural and agrigultural LAI
+    !  The model distinguishes different natural PFTs but does not contain information
+    !  on whether these PFTs are spatially separated or mixed. In line with the DGVM the 
+    !  models treats the natural PFT's as mixed. Therefore, the average LAI over the
+    !  natural PFTs is calculated to estimate light stress. Agricultural PFTs are spatially
+    !  separated. 
+    natveg_tot(:) = 0.0
+    lai_nat(:) = 0.0
+
+    DO j = 2, nvm ! Loop over # PFTs
+
+       IF ( natural(j) ) THEN
+
+          ! Mask agricultural vegetation
+          veget_max_nat(:,j) = veget_max(:,j)
+
+       ELSE
+
+          ! Mask natural vegetation
+          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 ! Loop over # PFTs
+
+    DO j = 2, nvm ! Loop over # PFTs
+
+       IF ( natural(j) ) THEN
+
+          ! Use the mean LAI over all natural PFTs when estimating light stress 
+          ! on a specific natural PFT
+          lai_around(:,j) = lai_nat(:)
+
+       ELSE
+
+          ! Use the actual LAI (specific for that PFT) when estimating light
+          ! stress on a specific agricultural PFT
+          lai_around(:,j) = lai(:,j)
+
+       ENDIF
+
+    ENDDO ! Loop over # PFTs
+
+
+    !! 1.2.4 Calculate LAI threshold below which carbohydrate reserve is used.
+    !  Lai_max is a PFT-dependent parameter specified in stomate_constants.f90
+    lai_happy_old(:) = lai_max(:) * lai_max_to_happy
+    
+    
+    !! 1.2.5 Set allocatable biomass
+    !  Total allocatable biomass during this time step determined from GPP.
+    !  GPP was calculated as CO2 assimilation in enerbil.f90
+    !  This is ignored later in the code if control%ok_functional_allocation is true
+    bm_alloc_tot(:,:) = gpp(:,:) * dt 
+
+
+ !! 2. Use carbohydrate reserve to support growth and update leaf age
+
+    ! Save old leaf mass, biomass got last updated in stomate_phenology.f90
+    lm_old(:,:) = biomass(:,:,ileaf,icarbon)
+
+    DO j = 2, nvm ! Loop over # PFTs 
+
+       !! 2.1 Calculate demand for carbohydrate reserve to support leaf and root growth.
+       !  Maximum time (days) since start of the growing season during which carbohydrate 
+       !  may be used
+       IF ( is_tree(j) ) THEN
+
+          reserve_time = reserve_time_tree
+
+       ELSE
+          reserve_time = reserve_time_grass
+
+       ENDIF
+
+       ! Growth is only supported by the use of carbohydrate reserves if the following 
+       ! conditions are  statisfied:\n
+       ! - PFT is not senescent;\n
+       ! - LAI must be low (i.e. below ::lai_happy_old) and\n
+       ! - Day of year of the simulation is in the beginning of the growing season.
+       WHERE ( ( biomass(:,j,ileaf,icarbon) .GT. zero ) .AND. ( .NOT. senescence(:,j) ) .AND. &
+            ( lai(:,j) .LT. lai_happy_old(j) ) .AND. ( when_growthinit(:,j) .LT. reserve_time ) ) 
+
+            ! Determine the mass from the carbohydrate reserve that can be used @tex $(gC m^{-2})$ @endtex. 
+            ! Satisfy the demand or use everything that is available 
+            ! (i.e. ::biomass(:,j,icarbres,icarbon)). Distribute the demand evenly over the time 
+            ! required (::tau_leafinit) to develop a minimal canopy from reserves (::lai_happy_old)
+            ! Needs to be additive, since reserves could already have been used in stomate_phenology
+            ! old use_reserve(:) = &
+            ! old     MIN( biomass(:,j,icarbres,icarbon), &
+            ! old     2._r_std * dt/tau_leafinit * lai_happy_old(j)/ sla(j) ).
+            use_reserve(:,j) = MIN( biomass(:,j,icarbres,icarbon), &
+               & deux * dt / tau_leafinit * lai_happy_old(j) / sla(j) )
+
+!           +++CHECK+++
+!$            use_reserve(:,j) = use_reserve(:,j) + MIN( biomass(:,j,icarbres,icarbon) * 0.1, &
+!$                 deux * dt / tau_leafinit * lai_happy_old(j) / sla(j) )
+!           +++++++++++
+
+            ! Distribute the reserve over leaves and fine roots.
+	    ! The part of the reserve going to the leaves is the ratio of default leaf allocation to default root and leaf allocation.
+	    ! The remaining of the reserve is alocated to the roots.
+            transloc_leaf(:,j) = L0(j)/(L0(j)+R0) * use_reserve(:,j)
+            biomass(:,j,ileaf,icarbon) = biomass(:,j,ileaf,icarbon) + transloc_leaf(:,j)
+            biomass(:,j,iroot,icarbon) = biomass(:,j,iroot,icarbon) + ( use_reserve(:,j) - transloc_leaf(:,j) )
+
+            ! Adjust the carbohydrate reserve mass by accounting for the reserves allocated to leaves and roots during
+            ! this time step
+            biomass(:,j,icarbres,icarbon) = biomass(:,j,icarbres,icarbon) - use_reserve(:,j)
+
+       ELSEWHERE
+
+           transloc_leaf(:,j) = zero
+
+       ENDWHERE
+      
+       !---TEMP---
+       WRITE(numout,*) 'use_reserve, ', use_reserve(:,j)
+       WRITE(numout,*) 'biomass(icarbres), ', biomass(:,j,icarbres,icarbon)+use_reserve(:,j)
+       WRITE(numout,*) 'other part, ', deux * dt / tau_leafinit * lai_happy_old(j) / sla(j)
+       !----------
+       
+ 
+ !! 3. Update leaf age
+
+       !  Leaf age is needed for calculation of turnover and vmax in stomate_turnover.f90 and stomate_vmax.f90 routines. 
+       !  Leaf biomass is distributed according to its age into several "age classes" with age class=1 representing the
+       !  youngest class, and consisting of the most newly allocated leaf biomass 
+    
+       !! 3.1 Update quantity and age of the leaf biomass in the youngest class
+       !  The new amount of leaf biomass in the youngest age class (leaf_mass_young) is the sum of :
+       !  - the leaf biomass that was already in the youngest age class (leaf_frac(:,j,1) * lm_old(:,j)) with the 
+       !    leaf age given in leaf_age(:,j,1) 
+       !  - and the new biomass allocated to leaves (bm_alloc(:,j,ileaf,icarbon)) with a leaf age of zero.
+       leaf_mass_young(:,j) = leaf_frac(:,j,1) * lm_old(:,j) + transloc_leaf(:,j)
+
+       ! The age of the updated youngest age class is the average of the ages of its 2 components: bm_alloc(leaf) of age
+       ! '0', and leaf_frac*lm_old(=leaf_mass_young-bm_alloc) of age 'leaf_age(:,:,1)' 
+       WHERE ( ( transloc_leaf(:,j) .GT. min_stomate ) .AND. ( leaf_mass_young(:,j) .GT. min_stomate ) )
+          
+          leaf_age(:,j,1) = MAX ( zero, leaf_age(:,j,1) * ( leaf_mass_young(:,j) - transloc_leaf(:,j) ) / &
+               & leaf_mass_young(:,j) )
+          
+       ENDWHERE
+
+
+       !! 3.2 Update leaf fractions
+       !      Update fractions of leaf biomass in each age class (fraction in youngest class increases)
+
+       !! 3.2.1 Update age of youngest leaves
+       !        For age class 1 (youngest class), because we have added biomass to the youngest class, we need to update
+       !        the fraction of total leaf biomass that belongs to the youngest age class : updated mass in class divided
+       !        by new total leaf mass
+       WHERE ( biomass(:,j,ileaf,icarbon) .GT. min_stomate )
+
+          leaf_frac(:,j,1) = leaf_mass_young(:,j) / biomass(:,j,ileaf,icarbon)
+
+       ENDWHERE
+
+
+       !! 3.2.2 Update age of other age classes
+       !        Because the total leaf biomass has changed, we need to update the fraction of leaves in each age class:
+       !        mass in leaf age class (from previous fraction of leaves in this class and previous total leaf biomass) 
+       !        divided by new total mass
+       DO m = 2, nleafages	! Loop over # leaf age classes
+
+          WHERE ( biomass(:,j,ileaf,icarbon) .GT. min_stomate )
+
+             leaf_frac(:,j,m) = leaf_frac(:,j,m) * lm_old(:,j) / biomass(:,j,ileaf,icarbon)
+
+          ENDWHERE
+
+       ENDDO	! Loop over # leaf age classes
+
+    ENDDO ! loop over # PFTs
+
+
+ !! 4. Calculate allocatable fractions of biomass production (NPP) 
+     
+    ! Calculate fractions of biomass production (NPP) to be allocated to the different 
+    ! biomass components.\n
+    ! The fractions of NPP allocated (0-1, unitless) to the different compartments depend on the
+    ! availability of light, water, and nitrogen.
+    DO j = 2, nvm ! Loop over # PFTs
+
+       ! Reset values
+       RtoLSR(:) = zero
+       LtoLSR(:) = zero
+       StoLSR(:) = zero
+        
+       !! 4.1 Age dependency of aboveground allocation
+       !  For trees, partitioning between above and belowground sapwood biomass is a function 
+       !  of age. An older tree gets more allocation to the aboveground sapwoood than a younger tree.
+       !  For the other PFTs it is prescribed. 
+       !  ::alloc_min, ::alloc_max and ::demi_alloc are specified in stomate_constants.f90
+       IF ( is_tree(j) ) THEN
+
+          alloc_sap_above (:) = alloc_min(j) + (alloc_max(j) - alloc_min(j)) * &
+             &   ( un - EXP( -age(:,j) / demi_alloc(j) ) )
+
+       ELSE
+
+          alloc_sap_above(:) = alloc_sap_above_grass
+
+       ENDIF  ! tree
+
+       !---TEMP---
+       WRITE(numout,*) 'age, ', age(:,j)
+       !----------
+
+       !! 4.2 Calculate light stress, water stress and proxy for nitrogen stress.
+       !  For the limiting factors a low value indicates a strong limitation
+       WHERE ( biomass(:,j,ileaf,icarbon) .GT. min_stomate )
+
+          !! 4.2.1 Light stress
+          !  Light stress is a function of the mean lai on the natural part of the grid box 
+          !  and of the PFT-specific LAI for agricultural crops. In line with the DGVM, natural
+          !  PFTs in the same gridbox are treated as if they were spatially mixed whereas 
+          !  agricultural PFTs are considered to be spatially separated.
+          !  The calculation of the lights stress depends on the extinction coefficient (set to 0.5)
+          !  and of a mean LAI.
+          WHERE( lai_around(:,j) < max_possible_lai )
+             
+             limit_L(:) = MAX( 0.1_r_std, EXP( -ext_coeff(j) * lai_around(:,j) ) )
+
+          ELSEWHERE
+             
+             limit_L(:) = 0.1_r_std
+          
+          ENDWHERE
+
+ 
+          !! 4.2.2 Water stress
+          !  Water stress is calculated as the weekly moisture availability.
+          !  Weekly moisture availability is calculated in stomate_season.f90.
+          limit_W(:) = MAX( 0.1_r_std, MIN( un, moiavail_week(:,j) ) )
+
+
+          !! 4.2.3 Proxy for nitrogen stress
+          !  The proxy for nitrogen stress depends on monthly soil water availability
+          !  (::soilhum_month) and monthly soil temperature (::tsoil_month). See section
+          !  1.2.2 for details on how ::t_nitrogen and ::h_nitrogen were calculated.\n
+          !  Currently nitrogen-stress is calculated for both natural and agricultural PFTs.
+          !  Due to intense fertilization of agricultural PFTs this is a strong 
+          !  assumption for several agricultural regions in the world (US, Europe, India, ...)
+          !  Water stress on nitrogen mineralisation 
+          limit_N_hum(:) = MAX( undemi, MIN( un, h_nitrogen(:) ) )
+
+          ! Temperature stress on nitrogen mineralisation using a Q10 decomposition model
+          ! where Q10 was set to 2
+          limit_N_temp(:) = deux**( ( t_nitrogen(:) - ZeroCelsius - Nlim_tref ) / Nlim_Q10 )
+          limit_N_temp(:) = MAX( 0.1_r_std, MIN( un, limit_N_temp(:) ) )
+
+          ! Combine water and temperature factors to get total nitrogen stress
+          limit_N(:) = MAX( 0.1_r_std, MIN( un, limit_N_hum(:) * limit_N_temp(:) ) )
+
+          ! Take the most limiting factor among soil water and nitrogen 
+          limit_WorN(:) = MIN( limit_W(:), limit_N(:) )
+
+          ! Take the most limiting factor among aboveground (i.e. light) and belowground 
+          ! (i.e. water & nitrogen) limitations
+          limit(:) = MIN( limit_WorN(:), limit_L(:) )
+
+
+          !! 4.3 Calculate ratio between allocation to leaves, sapwood and roots
+          !  Partitioning between belowground and aboveground biomass components is assumed 
+          !  to be proportional to the ratio of belowground and aboveground stresses.\n
+          !  \latexonly 
+          !  \input{alloc1.tex} 
+          !  \endlatexonly
+          !  Root allocation is the default root allocation corrected by a normalized ratio of aboveground 
+          !  stress to total stress. The minimum root allocation is 0.15.
+          RtoLSR(:) = MAX( .15_r_std, R0 * trois * limit_L(:) / ( limit_L(:) + deux * limit_WorN(:) ) )
+
+          ! Sapwood allocation is the default sapwood allocation corrected by a normalized ratio of 
+          ! belowground stress to total stress.
+          StoLSR(:) = S0(j) * trois * limit_WorN(:) / ( deux * limit_L(:) + limit_WorN(:) )
+
+          ! Leaf allocation is calculated as the remaining allocation fraction
+	  ! The range of variation of leaf allocation is constrained by ::min_LtoLSR and ::max_LtoLSR. 
+          LtoLSR(:) = un - RtoLSR(:) - StoLSR(:)
+          LtoLSR(:) = MAX( min_LtoLSR, MIN( max_LtoLSR, LtoLSR(:) ) )
+
+          ! Roots allocation is recalculated as the residual carbon after leaf allocation has been calculated. 
+          RtoLSR(:) = un - LtoLSR(:) - StoLSR(:)
+
+       ENDWHERE
+	   
+       ! Check whether allocation needs to be adjusted. If LAI exceeds maximum LAI 
+       ! (::lai_max), no addition carbon should be allocated to leaf biomass. Allocation is 
+       ! then partioned between root and sapwood biomass.
+       WHERE ( (biomass(:,j,ileaf,icarbon) .GT. min_stomate) .AND. (lai(:,j) .GT. lai_max(j)) )
+
+          StoLSR(:) = StoLSR(:) + LtoLSR(:)
+          LtoLSR(:) = zero
+
+       ENDWHERE
+       
+
+       !! 4.4 Calculate the allocation fractions.
+       !  The allocation fractions (::f_alloc) are an output variable (0-1, unitless). f_alloc
+       !  has three dimensions (npts,nvm,nparts). Where ::npts is the number of grid cells, ::nvm is the 
+       !  number of PFTs and ::nparts the number of biomass components. Currently six biomass compartments
+       !  are distinguished: (1) Carbon reserves, (2) Aboveground sapwood, (3) Belowground 
+       !  sapwood, (4) Roots, (5) fruits/seeds and (6) Leaves.@tex $(gC m^{-2})$ @endtex \n
+       DO i = 1, npts ! Loop over grid cells 
+
+          IF ( biomass(i,j,ileaf,icarbon) .GT. min_stomate ) THEN
+      
+            IF ( senescence(i,j) ) THEN
+                
+               !! 4.4.1 Allocate all C to carbohydrate reserve
+               !  If the PFT is senescent allocate all C to carbohydrate reserve, 
+               !  then the allocation fraction to reserves is 1. 
+               f_alloc(i,j,icarbres) = un
+
+            ELSE
+
+               !! 4.4.2 Allocation during the growing season  
+               f_alloc(i,j,ifruit) = f_fruit
+
+               ! Allocation to the carbohydrate reserve is proportional to leaf and root 
+               ! allocation. If carbon is allocated to the carbohydrate reserve, rescaling 
+               ! of allocation factors is required to ensure carbon mass preservation.
+               ! Carbon is allocated to the carbohydrate reserve when the pool size of the 
+               ! reserve is less than the carbon needed to grow a canopy twice the size of 
+               ! the maximum LAI (::lai_max). Twice the size was used as a threshold because
+               ! the reserves needs to be sufficiently to grow a canopy and roots. In case 
+               ! the carbohydrate pool is full, there is no need to rescale the other
+               ! allocation factors.
+	       ! If there is no rescaling of the allocation factors (carbres=1, no carbon put
+	       ! to reserve), then fraction remaining after fruit allocation (1-fruit_alloc) 
+	       ! is distributed between leaf, root and sap (sap carbon also distributed between   
+	       ! sap_above and sap_below with factor alloc_sap_above).
+	       ! If carbon is allocated to the carbohydrate reserve, all these factors are 
+	       ! rescaled through carb_rescale, and an allocation fraction for carbohydrate pool 
+	       ! appears. carb_rescale depends on the parameter (::ecureuil). 
+               ! (::ecureuil) is the fraction of primary leaf and root allocation put into 
+               ! reserve, it is specified in stomate_constants.f90 and is either 0 or 1.
+               IF ( ( biomass(i,j,icarbres,icarbon) * sla(j) ) .LT. deux * 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) * ( un - 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) * ( un - f_alloc(i,j,ifruit) ) * carb_rescale(i)
+               f_alloc(i,j,icarbres) = ( un - carb_rescale(i) ) * ( un - f_alloc(i,j,ifruit) )
+
+               ENDIF  ! Is senescent?
+
+            ENDIF  ! There are leaves
+
+         ENDDO  ! Loop over # pixels - domain size
+
+      ENDDO  ! loop over # PFTs
+
+
+ !! 5. Calculate maintenance and growth respiration
+
+    ! First, total maintenance respiration for the whole plant is calculated by summing maintenance 
+    ! respiration of the different plant compartments. Then, maintenance respiration is subtracted 
+    ! from whole-plant allocatable biomass (up to a maximum fraction of the total allocatable biomass). 
+    ! Growth respiration is then calculated for each plant compartment as a fraction of remaining 
+    ! allocatable biomass for this compartment. NPP is calculated by substracting total autotrophic 
+    ! respiration from GPP i.e. NPP = GPP - maintenance resp - growth resp.
+    DO j = 2,nvm	! Loop over # of PFTs       
+
+       !! 5.1 Maintenance respiration of the different plant parts 
+       !  Maintenance respiration of the different plant parts is calculated in 
+       !  stomate_resp.f90 as a function of the plant's temperature, 
+       !  the long term temperature and plant coefficients 
+       resp_maint(:,j) = zero
+
+       !  Following the calculation of hourly maintenance respiration, verify that 
+       !  the 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
+       
+       !! 5.2 Substract maintenance respiration from allocatable biomass
+       !  The total maintenance respiration calculated in 2.2 is substracted from the newly 
+       !  produced allocatable biomass (bm_alloc_tot). However, ensure that not all allocatable 
+       !  biomass is removed by setting a maximum to the fraction of allocatable biomass used 
+       !  for maintenance respiration: tax_max. If the maintenance respiration is larger than 
+       !  tax_max,the amount tax_max is taken from allocatable biomass, and the remaining of 
+       !  maintenance respiration is taken from the tissues themselves (biomass). We suppose 
+       !  that respiration is not dependent on leaf age -> therefore the leaf age structure is 
+       !  not changed. 
+       !  The maximum fraction of allocatable biomass used for respiration is defined as tax_max. 
+       !  The value of tax_max is set in the declarations section (0.4 Local variables) of this
+       !  routine
+
+       !! 5.2.1 Resource based allocatable biomass   
+       !  maximum part of allocatable biomass used for respiration
+       bm_tax_max(:) = tax_max * bm_alloc_tot(:,j)
+
+       ! If there is enough allocatable biomass to cover maintenance respiration, 
+       ! then biomass associated with maintenance respiration is removed from allocatable biomass
+       WHERE ( ( bm_alloc_tot(:,j) .GT. zero ) .AND. &
+            ( ( resp_maint(:,j) * dt ) .LT. bm_tax_max(:) ) )	
+	  
+          bm_alloc_tot(:,j) = bm_alloc_tot(:,j) - resp_maint(:,j) * dt
+
+       ELSEWHERE ( resp_maint(:,j) .GT. min_stomate )
+
+	  ! If there is not enough allocatable biomass to cover maintenance respiration, the  
+          ! - maximum allowed allocatable biomass (bm_tax_max) is removed from allocatable biomass.   
+          bm_alloc_tot(:,j) = bm_alloc_tot(:,j) - bm_tax_max(:)
+
+          ! ::bm_pump is the amount of maintenance respiration that exceeds the maximum allocatable biomass
+	  ! This amount of biomass still needs to be respired and will be removed from tissues biomass of each
+	  ! plant compartment
+          bm_pump(:) = resp_maint(:,j) * dt - bm_tax_max(:)
+
+          ! The biomass is removed from each plant compartment tissues as the ratio of the maintenance		
+          ! respiration of the plant compartment to the total maintenance respiration (resp_maint_part/resp_maint)
+          biomass(:,j,ileaf,icarbon) = biomass(:,j,ileaf,icarbon) - &
+             bm_pump(:) * resp_maint_part(:,j,ileaf) / resp_maint(:,j)
+          biomass(:,j,isapabove,icarbon) = biomass(:,j,isapabove,icarbon) - &
+             bm_pump(:) * resp_maint_part(:,j,isapabove) / resp_maint(:,j)
+          biomass(:,j,isapbelow,icarbon) = biomass(:,j,isapbelow,icarbon) - &
+             bm_pump(:) * resp_maint_part(:,j,isapbelow) / resp_maint(:,j)
+          biomass(:,j,iroot,icarbon) = biomass(:,j,iroot,icarbon) - &
+             bm_pump(:) * resp_maint_part(:,j,iroot) / resp_maint(:,j)
+          biomass(:,j,ifruit,icarbon) = biomass(:,j,ifruit,icarbon) - &
+             bm_pump(:) * resp_maint_part(:,j,ifruit) / resp_maint(:,j)
+          biomass(:,j,icarbres,icarbon) = biomass(:,j,icarbres,icarbon) - &
+             bm_pump(:) * resp_maint_part(:,j,icarbres) / resp_maint(:,j)
+          ! Resource based allocation does not uses a labile carbon pool
+          biomass(:,j,ilabile,icarbon) = zero
+
+       ENDWHERE  ! there is enough allocatable biomass to cover maintenance respiration
+
+     
+       !! 5.3 Allocate allocatable biomass to different plant compartments.
+       !      The amount of allocatable biomass to each compartment is a fraction ::f_alloc of the total 
+       !      allocatable biomass. For the resource-based allocation ::f_alloc of the different plant parts 
+       !      is calculated in stomate_alloc.f90
+       DO k = 1, nparts
+
+          bm_alloc(:,j,k,icarbon) = f_alloc(:,j,k) * bm_alloc_tot(:,j)
+
+       ENDDO
+     
+
+       !! 5.4 Calculate growth respiration of each plant compartment
+       !      Growth respiration of a plant compartment is a fraction of the allocatable biomass remaining after
+       !      maintenance respiration losses have been taken into account. The fraction of allocatable biomass 
+       !      removed for growth respiration is the same for all plant compartments and is defined by the parameter
+       !      frac_growth_resp in stomate_constants.f90. Allocatable biomass ::bm_alloc is updated as a result of 
+       !      the removal of growth resp (gC m-2 dt-1).
+       DO k = 1,nparts
+
+          resp_growth_part(:,k) = frac_growthresp(j) * bm_alloc(:,j,k,icarbon) / dt
+          bm_alloc(:,j,k,icarbon) =  ( 1. - frac_growthresp(j) ) * bm_alloc(:,j,k,icarbon)
+
+       ENDDO
+      
+
+       !! 5.5 Total growth respiration 
+       !      Calculate total growth respiration of the plant as the sum of growth respiration of all plant parts	
+       resp_growth(:,j) = zero
+       DO k = 1, nparts
+          
+          ! Total growth respiration. Calculate total growth respiration of the plant as the 
+          ! sum of growth respiration of all plant parts
+          resp_growth(:,j) = resp_growth(:,j) + resp_growth_part(:,k)
+
+       ENDDO ! # biomass compartments
+
+    ENDDO ! # of PFTs
+
+    
+ !! 6. Update the biomass with newly allocated biomass after respiration
+ 
+    !  Save the old leaf biomass for later. "old" leaf mass is leaf mass after maintenance respiration in the case 
+    !  where maintenance respiration has required taking biomass from tissues in section 3.2    
+    lm_old(:,:) = biomass(:,:,ileaf,icarbon)
+    biomass(:,:,:,icarbon) = biomass(:,:,:,icarbon) + bm_alloc(:,:,:,icarbon)
+
+   
+ !! 7. Deal with negative biomasses
+
+    !  Biomass can become negative in some rare cases, as the GPP can be negative (dark respiration). In this case, 
+    !  we set biomass to some small value min_stomate. This creation of matter (carbon) is taken into account by 
+    !  decreasing the autotrophic respiration by the same amount that has been added to biomass for it to become 
+    !  positive. In this case, maintenance respiration can become negative !!!
+   
+    DO k = 1, nparts	! Loop over # of plant parts
+
+       WHERE ( biomass(:,:,k,icarbon) .LT. zero )
+
+          bm_create(:,:) = min_stomate - biomass(:,:,k,icarbon)     
+          biomass(:,:,k,icarbon) = biomass(:,:,k,icarbon) + bm_create(:,:)    
+          resp_maint(:,:) = resp_maint(:,:) - bm_create(:,:) / dt
+
+       ENDWHERE
+
+    ENDDO	! Loop over # plant parts
+    
+
+ !! 8. Calculate NPP (See Eq 1 in header)
+    
+    ! Calculate the NPP @tex $(gC.m^{-2}dt^{-1})$ @endtex as the difference between GPP
+    ! and autotrophic respiration (maintenance and growth respirations)
+    ! This is a diagnostic calculation
+    npp(:,:) = gpp(:,:) - resp_growth(:,:) - resp_maint(:,:)
+    
+
+ !! 9. Update leaf age
+
+    !  Leaf age is needed for calculation of turnover and vmax in stomate_turnover.f90 and stomate_vmax.f90 routines. 
+    !  Leaf biomass is distributed according to its age into several "age classes" with age class=1 representing the
+    !  youngest class, and consisting of the most newly allocated leaf biomass 
+    
+    !! 9.1 Update quantity and age of the leaf biomass in the youngest class
+    !      The new amount of leaf biomass in the youngest age class (leaf_mass_young) is the sum of :
+    !      - the leaf biomass that was already in the youngest age class (leaf_frac(:,j,1) * lm_old(:,j)) with the 
+    !        leaf age given in leaf_age(:,j,1) 
+    !      - and the new biomass allocated to leaves (bm_alloc(:,j,ileaf)) with a leaf age of zero.
+    DO j = 2,nvm
+
+       leaf_mass_young(:,j) = leaf_frac(:,j,1) * lm_old(:,j) + bm_alloc(:,j,ileaf,icarbon)
+
+    ENDDO
+
+    ! The age of the updated youngest age class is the average of the ages of its 2 components: bm_alloc(leaf) of age
+    ! '0', and leaf_frac*lm_old(=leaf_mass_young-bm_alloc) of age 'leaf_age(:,j,1)' 
+    DO j = 2,nvm
+
+       WHERE ( ( bm_alloc(:,j,ileaf,icarbon) .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,icarbon) ) / &
+             & leaf_mass_young(:,j) )
+          
+       ENDWHERE
+
+    ENDDO
+
+    !  For age class 1 (youngest class), because we have added biomass to the youngest class, we need to update
+    !  the fraction of total leaf biomass that belongs to the youngest age class : updated mass in class divided
+    !  by new total leaf mass
+    DO j = 2,nvm
+
+       WHERE ( biomass(:,j,ileaf,icarbon) .GT. min_stomate )
+
+          leaf_frac(:,j,1) = leaf_mass_young(:,j) / biomass(:,j,ileaf,icarbon)
+
+       ENDWHERE
+
+    ENDDO
+
+    !! 9.2 Update age of other age classes
+    !  Because the total leaf biomass has changed, we need to update the fraction of leaves in each age class:
+    !  mass in leaf age class (from previous fraction of leaves in this class and previous total leaf biomass) 
+    !  divided by new total mass
+    DO m = 2, nleafages	
+
+       DO j = 2,nvm
+
+          WHERE ( biomass(:,j,ileaf,icarbon) .GT. min_stomate )
+
+             leaf_frac(:,j,m) = leaf_frac(:,j,m) * lm_old(:,j) / biomass(:,j,ileaf,icarbon)
+
+          ENDWHERE
+
+       ENDDO
+
+    ENDDO
+
+
+ !! 10. Update whole-plant age 
+    
+    !! 10.1 PFT age
+    !  At every time step, increase age of the biomass that was already present at previous time step. 
+    !  Age is expressed in years, and the time step 'dt' in days so age increase is: dt divided by number 
+    !  of days in a year.
+    WHERE ( PFTpresent(:,:) )
+
+       age(:,:) = age(:,:) + dt/one_year
+
+    ELSEWHERE
+
+       age(:,:) = zero
+
+    ENDWHERE
+
+
+    !! 10.2 Age of grasses and crops
+    !  For grasses and crops, biomass with age 0 has been added to the whole plant with age 'age'. New biomass is the sum of 
+    !  the current total biomass in all plant parts (bm_new), bm_new(:) = SUM( biomass(:,j,:,icarbon), DIM=2 ). The biomass 
+    !  that has just been added is the sum of the allocatable biomass of all plant parts (bm_add), its age is zero. bm_add(:) = 
+    !  SUM( bm_alloc(:,j,:,icarbon), DIM=2 ). Before allocation, the plant biomass is bm_new-bm_add, its age is "age(:,j)". 
+    !  The age of the new biomass is the average of the ages of previous and added biomass.
+    !  For trees, age is treated in "establish" if vegetation is dynamic, and in turnover routines if it is static (in this 
+    !  case, only the age of the heartwood is accounted for).
+    DO j = 2,nvm
+
+       IF ( .NOT. is_tree(j) ) THEN
+
+          bm_new(:) = biomass(:,j,ileaf,icarbon) + biomass(:,j,isapabove,icarbon) + &
+               biomass(:,j,iroot,icarbon) + biomass(:,j,ifruit,icarbon)
+          bm_add(:) = bm_alloc(:,j,ileaf,icarbon) + bm_alloc(:,j,isapabove,icarbon) + &
+               bm_alloc(:,j,iroot,icarbon) + bm_alloc(:,j,ifruit,icarbon)
+
+          WHERE ( ( bm_new(:) .GT. zero ) .AND. ( bm_add(:) .GT. min_stomate ) )
+
+             age(:,j) = age(:,j) * ( bm_new(:) - bm_add(:) ) / bm_new(:)
+          
+          ENDWHERE
+
+       ENDIF ! is .NOT. tree
+
+    ENDDO  ! Loop over #PFTs 
+
+
+ !! 11. Write history files
+
+    ! Save in history file the variables describing the biomass allocated to the plant parts
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_LEAF', itime, &
+         bm_alloc(:,:,ileaf,icarbon), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_SAP_AB', itime, &
+         bm_alloc(:,:,isapabove,icarbon), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_SAP_BE', itime, &
+         bm_alloc(:,:,isapbelow,icarbon), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_ROOT', itime, &
+         bm_alloc(:,:,iroot,icarbon), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_FRUIT', itime, &
+         bm_alloc(:,:,ifruit,icarbon), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_RES', itime, &
+         bm_alloc(:,:,icarbres,icarbon), npts*nvm, horipft_index)
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving resource limited growth'
+
+
+  END SUBROUTINE growth_res_lim
+
+END MODULE stomate_growth_res_lim
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_io.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_io.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_io.f90	(revision 7236)
@@ -0,0 +1,3199 @@
+! =================================================================================================================================
+! MODULE       : stomate_io
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2011)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        This module reads and writes STOMATE variables in restart files.
+!!
+!!\n DESCRIPTION:  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.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	: None
+!!
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_stomate/stomate_io.f90 $
+!! $Date: 2014-12-17 23:40:26 +0100 (Wed, 17 Dec 2014) $
+!! $Revision: 2442 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE stomate_io
+
+  USE stomate_data
+  USE constantes
+  USE structures
+  USE constantes_soil
+  USE mod_orchidee_para
+  USE ioipsl_para
+  USE interpol_help
+  USE function_library,   ONLY : wood_to_qmheight, biomass_to_lai 
+  USE grid
+
+  IMPLICIT NONE
+
+  PRIVATE
+  PUBLIC readrestart, writerestart, readbc, get_reftemp_clear
+
+  LOGICAL, SAVE                                :: firstcall = .TRUE. !! first call?
+!$OMP THREADPRIVATE(firstcall)
+
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE :: trefe              !! reference temperature (K)
+!$OMP THREADPRIVATE(trefe)
+
+
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE   : readrestart
+!!
+!>\BRIEF         read start file
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE readrestart (npts, index, lalo, resolution, neighbours, contfrac, &
+       day_counter, dt_days, date, ind, &
+       adapted, regenerate, moiavail_daily, gdd_init_date, &
+       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, &
+       moiavail_growingseason, 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_from_growthinit, 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, senescence_days, 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, lignin_wood, turnover_time, &
+       prod_s, prod_m, prod_l, flux_s, flux_m, flux_l, &
+       cflux_prod_s, cflux_prod_m, cflux_prod_l, bm_to_litter, &
+       carb_mass_total, &
+       age_stand, rotation_n, last_cut, &
+       forest_managed, forest_managed_lastyear, global_years, &
+       ok_equilibrium, nbp_accu, nbp_flux, MatrixV, &
+       VectorU, previous_stock, current_stock, rue_longterm, &
+       fpc_max, circ_class_n, circ_class_biomass, &
+       KF, mai, &
+       pai, previous_wood_volume, mai_count, coppice_dens, &
+       vir_moiavail_growingseason, lai_per_level, laieff_fit, &
+       temp_growth, wstress_season, wstress_month, vir_wstress_fac, &
+       c_buried, k_latosa_adapt,&
+species_change_map,lpft_replant,counter_psi,counter_2,counter_0,resp_hetero_litter,resp_hetero_soil)
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                                          :: npts                    !! Domain size
+    INTEGER(i_std), DIMENSION(npts), INTENT(in)                         :: index                   !! Indices of the points on the map
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)                          :: lalo                    !! Geogr. coordinates 
+    !! (latitude,longitude) (degrees)
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)                          :: resolution              !! size in x an y of the grid (m)
+    INTEGER(i_std),DIMENSION (npts,8), INTENT(in)                       :: neighbours              !! Neighbouring land grid cell
+    REAL(r_std),DIMENSION (npts), INTENT(in)                            :: contfrac                !! Fraction of land in each grid box
+
+    INTEGER(i_std), DIMENSION(npts,nvm), INTENT(in)                     :: forest_managed          !! forest management flag
+
+    !! 0.2 Output variables
+
+    REAL(r_std), INTENT(out)                                            :: day_counter             !! counts time until next STOMATE time step
+    REAL(r_std), INTENT(out)                                            :: dt_days                 !! time step of STOMATE in days
+    INTEGER(i_std), INTENT(out)                                         :: date                    !! date (d)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: ind                     !! density of individuals
+    !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: adapted                 !! Winter too cold? between 0 and 1
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: regenerate              !! Winter sufficiently cold? between 0 and 1
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: moiavail_daily          !! daily moisture availability
+    REAL(r_std), DIMENSION(npts,4), INTENT(out)                         :: gdd_init_date           !! date for beginning of gdd count
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: litterhum_daily         !! daily litter humidity
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: t2m_daily               !! daily 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: t2m_min_daily           !! daily minimum 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: tsurf_daily             !! daily surface temperatures (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(out)                      :: tsoil_daily             !! daily soil temperatures (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(out)                      :: soilhum_daily           !! daily soil humidity
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: precip_daily            !! daily precipitations (mm/day) (for phenology)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: gpp_daily               !! daily gross primary productivity
+                                                                                                   !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: npp_daily               !! daily net primary productivity 
+                                                                                                   !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(out)      :: turnover_daily          !! daily turnover rates
+                                                                                                   !! @tex $(gC m^{-2} dt_slow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: moiavail_month          !! "monthly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: moiavail_week           !! "weekly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: moiavail_growingseason  !! "growingseason" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: vir_moiavail_growingseason !! Virtual "growingseason" moisture availability
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: t2m_longterm            !! "long term" 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: t2m_month               !! "monthly" 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: t2m_week                !! "weekly" 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(out)                      :: tsoil_month             !! "monthly" soil temperatures (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(out)                      :: soilhum_month           !! "monthly" soil humidity
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: fireindex               !! Probability of fire
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: firelitter              !! Longer term total litter above 
+    !! the ground
+    !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: maxmoiavail_lastyear    !! last year's maximum 
+    !! moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: maxmoiavail_thisyear    !! this year's maximum 
+    !! moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: minmoiavail_lastyear    !! last year's minimum 
+    !! moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: minmoiavail_thisyear    !! this year's minimum 
+    !! moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: maxgppweek_lastyear     !! last year's maximum weekly GPP
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: maxgppweek_thisyear     !! this year's maximum weekly GPP
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: gdd0_lastyear           !! last year's annual GDD0
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: gdd0_thisyear           !! this year's annual GDD0
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: precip_lastyear         !! last year's annual precipitation
+                                                                                                   !! (mm/year)
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: precip_thisyear         !! this year's annual precipitation 
+                                                                                                   !! (mm/year)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: gdd_m5_dormance         !! growing degree days, threshold 
+                                                                                                   !! -5 deg C (for phenology)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: gdd_from_growthinit     !! growing degree days, 
+                                                                                                   !! from begin of season
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: gdd_midwinter           !! growing degree days since 
+                                                                                                   !! midwinter (for phenology)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: ncd_dormance            !! number of chilling days since 
+                                                                                                   !! leaves were lost (for phenology)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: ngd_minus5              !! number of growing days, threshold 
+                                                                                                   !! -5 deg C (for phenology)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(out)                           :: PFTpresent              !! PFT exists (equivalent to 
+                                                                                                   !! fpc_max > 0 for natural PFTs)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: npp_longterm            !! "long term" net primary productivity 
+                                                                                                   !! (gC/m**2/year)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: lm_lastyearmax          !! last year's maximum leaf mass, 
+                                                                                                   !! for each PFT (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: lm_thisyearmax          !! this year's maximum leaf mass, 
+                                                                                                   !! for each PFT (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: maxfpc_lastyear         !! last year's maximum fpc for each 
+                                                                                                   !! natural PFT, on ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: maxfpc_thisyear         !! this year's maximum fpc for each 
+                                                                                                   !! PFT, on *total* ground (see stomate_season)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(out)      :: turnover_longterm       !! "long term" turnover rate (gC/m**2/year)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: gpp_week                !! "weekly" GPP (gC/day/(m**2 covered)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(out)      :: biomass                 !! biomass (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(out)                :: resp_maint_part         !! maintenance resp (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(out)             :: leaf_age                !! leaf age (days)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(out)             :: leaf_frac               !! fraction of leaves in leaf age class
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(out)                 :: circ_class_n            !! Number of trees in each circumference classes
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements), INTENT(out):: circ_class_biomass      !! Biomass components of the model tree within 
+                                                                                                   !! each circumference classes (gC ind^-1)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(out)                           :: senescence              !! is the plant senescent ? 
+                                                                                                   !! (only for deciduous trees - 
+                                                                                                   !! carbohydrate reserve)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: senescence_days         !! Days since start of senescence (days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: when_growthinit         !! how many days ago was the beginning
+                                                                                                   !! of the growing season
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: age                     !! mean age (years)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: resp_hetero             !! heterotrophic respiration (gC/day/m**2)
+    
+   REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: resp_hetero_litter
+   REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: resp_hetero_soil
+
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: resp_maint              !! maintenance respiration (gC/day/m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: resp_growth             !! growth respiration (gC/day/m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: co2_fire                !! 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_to_bm_dgvm          !! biomass uptaken 
+                                                                                                   !! (gC/(m**2 of total ground)/day)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: veget_lastlight         !! vegetation fractions (on ground) 
+                                                                                                   !! after last light competition
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: everywhere              !! is the PFT everywhere in the 
+                                                                                                   !! grid box or very localized 
+                                                                                                   !! (after its introduction)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(out)                           :: need_adjacent           !! in order for this PFT to be introduced, 
+                                                                                                   !! does it have to be present in an 
+                                                                                                   !! adjacent grid box?
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: RIP_time                !! How much time ago was the PFT eliminated
+                                                                                                   !! for the last time (years) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: time_lowgpp             !! Duration of dormance (days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: time_hum_min            !! time elapsed since strongest moisture
+                                                                                                   !! availability (d)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: hum_min_dormance        !! minimum moisture during dormance
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(out)                 :: litterpart              !! fraction of litter above the ground
+                                                                                                   !! belonging to different PFTs separated 
+                                                                                                   !! for natural and agricultural PFTs.
+    REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements), INTENT(out) :: litter                  !! metabolic and structural litter, 
+                                                                                                   !! natural and agricultural, above and 
+                                                                                                   !! below ground (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(out)                 :: dead_leaves             !! dead leaves on ground, per PFT, 
+                                                                                                   !! metabolic and structural, 
+                                                                                                   !! in gC/(m**2 of ground)
+    REAL(r_std), DIMENSION(npts,ncarb,nvm), INTENT(out)                 :: carbon                  !! carbon pool: active, slow, or passive,
+                                                                                                   !! (gC/m**2)
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: black_carbon            !! black carbon on the ground 
+                                                                                                   !! (gC/(m**2 of total ground))
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(out)                 :: lignin_struc            !! ratio Lignine/Carbon in structural litter,
+                                                                                                   !! above and below ground, 
+                                                                                                   !! (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(out)                 :: lignin_wood             !! ratio Lignine/Carbon in woody litter,
+                                                                                                   !! above and below ground, 
+                                                                                                   !! (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(out)                :: turnover_time           !!
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: rue_longterm            !! longterm radiation use efficiency
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: fpc_max                 !! 
+
+    INTEGER(i_std), DIMENSION(npts, nvm), INTENT(out)                   :: age_stand               !! Age of stand (years)
+    INTEGER(i_std), DIMENSION(npts, nvm), INTENT(out)                   :: rotation_n              !! Rotation number (number of rotation 
+                                                                                                   !! since pft is managed)
+    INTEGER(i_std), DIMENSION(npts, nvm), INTENT(out)                   :: last_cut                !! Years since last thinning (years)
+    INTEGER(i_std), DIMENSION (npts,nvm), INTENT(out)                   :: forest_managed_lastyear !! forest management flag for the previous year
+    REAL(r_std), DIMENSION(npts,0:nshort), INTENT(out)                  :: prod_s                  !!
+    REAL(r_std), DIMENSION(npts,0:nmedium), INTENT(out)                 :: prod_m                  !!
+    REAL(r_std), DIMENSION(npts,0:nlong), INTENT(out)                   :: prod_l                  !!
+    REAL(r_std), DIMENSION(npts,nshort), INTENT(out)                    :: flux_s                  !!
+    REAL(r_std), DIMENSION(npts,nmedium), INTENT(out)                   :: flux_m                  !!
+    REAL(r_std), DIMENSION(npts,nlong), INTENT(out)                     :: flux_l                  !!
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: cflux_prod_s            !!
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: cflux_prod_m            !!
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: cflux_prod_l            !!
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(out)      :: bm_to_litter            !!
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: carb_mass_total         !!
+    INTEGER(i_std), INTENT(out)                                         :: global_years            !!
+    LOGICAL, DIMENSION(npts), INTENT(out)                               :: ok_equilibrium          !!
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: nbp_accu                !! Accumulated Net Biospheric 
+                                                                                                   !! Production over the year
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(out)                 :: counter_psi
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(out)                 :: counter_2
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(out)                 :: counter_0
+
+    REAL(r_std), DIMENSION(npts), INTENT(out)                           :: nbp_flux                !! Net Biospheric Production over the year
+    REAL(r_std), DIMENSION(npts,nvm,nbpools,nbpools), INTENT(out)       :: MatrixV                 !!
+    REAL(r_std), DIMENSION(npts,nvm,nbpools), INTENT(out)               :: VectorU                 !!
+    REAL(r_std), DIMENSION(npts,nvm,nbpools), INTENT(out)               :: previous_stock          !! 
+    REAL(r_std), DIMENSION(npts,nvm,nbpools), INTENT(out)               :: current_stock           !!  
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: KF                      !! Scaling factor to convert sapwood mass
+                                                                                                   !! into leaf mass (m)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: k_latosa_adapt          !! Leaf to sapwood area adapted for water 
+                                                                                                   !! stress. Adaptation takes place at the 
+                                                                                                   !! end of the year (m)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: mai                     !! The mean annual increment
+                                                                                                   !! @tex $(m**3 / m**2 / year)$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: pai                     !! The period annual increment
+                                                                                                   !! @tex $(m**3 / m**2 / year)$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                       :: previous_wood_volume    !! The volume of the tree trunks
+                                                                                                   !! in a stand for the previous year.
+                                                                                                   !! @tex $(m**3 / m**2 )$ @endtex
+    INTEGER(i_std), DIMENSION(npts,nvm),INTENT(out)                     :: mai_count               !! The number of times we've
+                                                                                                   !! calculated the volume increment
+                                                                                                   !! for a stand
+    REAL(r_std), DIMENSION(npts,nvm),INTENT(out)                        :: coppice_dens            !! The density of a coppice at the first
+                                                                                                   !! cutting.
+                                                                                                   !! @tex $( 1 / m**2 )$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm,nlevels_tot),INTENT(out)            :: lai_per_level           !! The amount of LAI in each physical
+                                                                                                   !! canopy level.
+                                                                                                   !! @tex $( m**2 / m**2 )$ @endtex 
+    TYPE(laieff_type),DIMENSION (:,:,:),INTENT(out)                     :: laieff_fit              !! Fitted parameters for the effective LAI
+    REAL(r_std),DIMENSION(npts),INTENT(out)                             :: temp_growth             !! Growth temperature (Â°C) 
+                                                                                                   !! Is equal to t2m_month
+    REAL(r_std), DIMENSION(:,:), INTENT(out)                            :: vir_wstress_fac         !! Virtual water stress factor, based on hum_rel_daily
+                                                                                                   !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(out)                            :: wstress_season          !! Water stress factor, based on hum_rel_daily
+                                                                                                   !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(out)                            :: wstress_month           !! Water stress factor, based on hum_rel_daily
+                                                                                                   !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(out)                            :: c_buried                !! Carbon that is buried when land cover changes
+                                                                                                   !! to a nobio type.  
+                                                                                                   !! @tex $( gC )$ @endtex 
+    INTEGER(i_std), DIMENSION(:,:), INTENT(out)                         :: species_change_map      !! A map which gives the PFT number that each
+                                                                                                   !! PFT will be replanted as in case of a clearcut.
+                                                                                                   !! (1-nvm,unitless)
+    LOGICAL, DIMENSION(:,:), INTENT(out)                                :: lpft_replant            !! Indicates if this PFT has either died this year
+                                                                                                   !! or been clearcut/coppiced.  If it has, it is not
+                                                                                                   !! replanted until the end of the year.
+
+   !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION(npts), INTENT(inout)                         :: tlong_ref               !! "long term" reference 2 meter temperatures (K)
+
+    !! 0.4 Local variables
+
+    REAL(r_std)                                                         :: date_real               !! date, real
+    REAL(r_std), DIMENSION(npts,nvm)                                    :: PFTpresent_real         !! PFT exists (equivalent to 
+                                                                                                   !! fpc_max > 0 for natural PFTs), real
+    REAL(r_std), DIMENSION(npts,nvm)                                    :: senescence_real         !! is the plant senescent ?
+                                                                                                   !! (only for deciduous trees -
+                                                                                                   !! carbohydrate reserve), real
+    REAL(r_std), DIMENSION(npts,nvm)                                    :: need_adjacent_real      !! in order for this PFT to be introduced,
+                                                                                                   !! does it have to be present in an 
+                                                                                                   !! adjacent grid box? - real
+    CHARACTER(LEN=80)                                                   :: var_name                !! To store variables names for I/O
+    CHARACTER(LEN=10)                                                   :: part_str                !! string suffix indicating an index
+    CHARACTER(LEN=10)                                                   :: part_str2               !! string suffix indicating an index
+    CHARACTER(LEN=10)                                                   :: circ_str                !! string suffix indicating an index
+    CHARACTER(LEN=3), DIMENSION(nlitt)                                  :: litter_str              !! string suffix indicating litter type
+    CHARACTER(LEN=2), DIMENSION(nlevs)                                  :: level_str               !! string suffix indicating level
+    REAL(r_std), DIMENSION(1)                                           :: xtmp                    !! temporary storage
+    INTEGER(i_std)                                                      :: i,j,k,l,m,p,deb,&
+                                                                           idia,ifm,icut           !! index
+    REAL(r_std), DIMENSION(npts)                                        :: tref                    !! reference temperature (K)
+
+    CHARACTER(LEN=2), DIMENSION(nelements)                              :: element_str             !! string suffix indicating element
+    REAL(r_std), ALLOCATABLE, DIMENSION(:)	                        :: circ_ij                 !! circumference of idividual trees
+    INTEGER(i_std)                                                      :: ntrees                  !! first or second part of self-thinning lines
+    REAL(r_std), DIMENSION(npts,nvm)                                    :: temp_real               !! temporary real to allow restget 
+                                                                                                   !! to work on multi-dimensional integers
+    REAL(r_std)                                                         :: p_max, excedent         !! Where is the exponential distribution 
+                                                                                                   !! truncated
+    REAL(r_std), DIMENSION(20)                                          :: nb_trees_i              !! Number of trees in each twentith quantile
+    REAL(r_std)                                                         :: lambda                  !! lambda of the exponential distribution 
+                                                                                                   !! of initial diameters
+    REAL(r_std)                                                         :: min_circ_init           !! Min initial circumference 
+                                                                                                   !! of the exponential distribution
+    REAL(r_std)                                                         :: max_circ_init           !! Max initial circumference
+                                                                                                   !! of the exponential distribution
+    REAL(r_std), DIMENSION(1)                                           :: temp_global_years       !!
+    CHARACTER(LEN=7), DIMENSION(nbpools)                                :: pools_str               !!
+    REAL(r_std), DIMENSION(npts)                                        :: ok_equilibrium_real     !!
+!!$    REAL(r_std), DIMENSION (npts,nvm)                                   :: av_height               !! forest management flag for the previous year
+    CHARACTER(LEN=80)                                                   :: cut_name                !! To store variables names for I/O
+    CHARACTER(LEN=80)                                                   :: fm_name                 !! To store variables names for I/O
+    REAL(r_std),DIMENSION(npts,nvm,nlevels_tot,nparams_laieff)          :: temp_array              !! To store structure values for I/O        
+    INTEGER                                                             :: n,ilev,ipts,ivm         !! Indices
+    REAL(r_std), DIMENSION(npts,nvm)                                    :: rpft_replant            !! Getting logical values from the restart
+                                                                                                   !! is not possible, so this is a temporary
+                                                                                                   !! array where 1.0 is TRUE.
+    !_ ================================================================================================================================
+
+    IF (bavard >= 3) WRITE(numout,*) 'Entering readrestart'
+    !-
+    ! 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, neighbours, resolution, contfrac, tref )
+    !-
+    ! 1 string definitions
+    !-
+    DO l=1,nlitt
+       IF     (l == imetabolic) THEN
+          litter_str(l) = 'met'
+       ELSEIF (l == istructural) THEN
+          litter_str(l) = 'str'
+       ELSEIF (l == iwoody) THEN
+          litter_str(l) = 'wod'
+       ELSE
+          CALL ipslerr_p (3,'stomate_io', &
+               'Wrire restart - 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
+          CALL ipslerr_p (3,'stomate_io',&
+               'Wrire restart - Define level str','','')
+       ENDIF
+    ENDDO
+
+    pools_str(1:nbpools) =(/'str_ab ','str_be ','met_ab ',&
+         'met_be ','wood_ab','wood_be', &
+         'actif  ','slow   ','passif '/)
+
+    !-
+    DO l=1,nelements
+       IF     (l == icarbon) THEN
+          element_str(l) = ''
+!!$       ELSEIF (l == initrogen) THEN
+!!$          element_str(l) = '_n'
+       ELSE
+          CALL ipslerr_p (3,'stomate_io', &
+               'Wrire restart - Define element 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)
+    !-
+    ! 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
+    !-
+    gdd_init_date(:,:) = val_exp
+    var_name = 'gdd_init_date'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 4 , 1, itime, &
+         &              .TRUE., gdd_init_date, 'gather', nbp_glo, index_g)
+    IF (ALL(gdd_init_date(:,1) == val_exp)) gdd_init_date(:,1) = 365.
+    IF (ALL(gdd_init_date(:,3) == val_exp)) gdd_init_date(:,3) = zero
+    IF (ALL(gdd_init_date(:,4) == val_exp)) gdd_init_date(:,4) = 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 l = 1,nelements
+       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))//TRIM(element_str(l))
+          CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+               &                .TRUE., turnover_daily(:,:,k,l), 'gather', nbp_glo, index_g)
+          IF (ALL(turnover_daily(:,:,k,l) == val_exp)) &
+               &       turnover_daily(:,:,k,l) = zero
+       ENDDO
+    END DO
+    !-
+    ! 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
+    !-
+    moiavail_growingseason(:,:) = val_exp
+    var_name = 'moiavail_gs'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., moiavail_growingseason, 'gather', nbp_glo, index_g)
+    IF (ALL(moiavail_growingseason(:,:) == val_exp)) moiavail_growingseason(:,:) = zero
+    !-
+    vir_moiavail_growingseason(:,:) = val_exp
+    var_name = 'vir_moiavail_gs'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., vir_moiavail_growingseason, 'gather', nbp_glo, index_g)
+    IF (ALL(vir_moiavail_growingseason(:,:) == val_exp)) vir_moiavail_growingseason(:,:) = 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
+    !-
+    temp_growth(:) = val_exp
+    var_name = 'temp_growth'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &                .TRUE., temp_growth, 'gather', nbp_glo, index_g)
+    IF (ALL(temp_growth(:) == val_exp)) temp_growth(:) = zero
+    !-
+    wstress_season(:,:) = val_exp
+    var_name = 'wstress_season'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                .TRUE., wstress_season, 'gather', nbp_glo, index_g)
+    IF (ALL(wstress_season(:,:) == val_exp)) wstress_season(:,:) = un
+    !-
+    wstress_month(:,:) = val_exp
+    var_name = 'wstress_month'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                .TRUE., wstress_month, 'gather', nbp_glo, index_g)
+    IF (ALL(wstress_month(:,:) == val_exp)) wstress_month(:,:) = un
+    !-
+    vir_wstress_fac(:,:) = val_exp
+    var_name = 'vir_wstress_fac'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                .TRUE., vir_wstress_fac, 'gather', nbp_glo, index_g)
+    IF (ALL(vir_wstress_fac(:,:) == val_exp)) vir_wstress_fac(:,:) = un
+    WRITE(numout,*) 'done with waterstress'
+    !-
+    c_buried(:,:) = val_exp
+    var_name = 'c_buried'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nnobio, 1, itime, &
+         &                .TRUE., c_buried, 'gather', nbp_glo, index_g)
+    IF (ALL(c_buried(:,:) == val_exp)) c_buried(:,:) = un
+    WRITE(numout,*) 'done with c_buried'
+
+    !-
+    ! 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_estab
+    !-
+    ! 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_from_growthinit(:,:) = val_exp
+    var_name = 'gdd_from_growthinit'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., gdd_from_growthinit, 'gather', nbp_glo, index_g)
+    IF (ALL(gdd_from_growthinit(:,:) == val_exp)) &
+         &     gdd_from_growthinit(:,:) = zero
+    !-
+    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
+    !-
+
+    !+++++++++ CHECK MJM +++++++++++++++
+    ! why is this done here?
+!!$    IF ( control%forest_management ) THEN
+!!$       
+!!$       IF ( .NOT. ALLOCATED(circ_ij)) ALLOCATE(circ_ij(MAXVAL(nmaxtrees)))
+!!$
+!!$       !! initializing circ_ij and setting m to the smallest cir_ij greater than zero
+!!$       p_max = 100./MAXVAL(nmaxtrees)
+!!$       circ_ij(:) = zero
+!!$       nb_trees_i(:) = 0
+!!$
+!!$       !! lambda of the exponential distribution of initial diameters
+!!$       !! (Dhote 2003 : lambda = SQRT(2)/Dg and Dginit = 1 cm)
+!!$       lambda = 2._r_std**0.5_r_std/pi
+!!$
+!!$       !! The distribution is truncated when P(X>max_circ_init)<100/maxval(nmaxtrees)
+!!$       min_circ_init = pi
+!!$       max_circ_init = 1./lambda*LOG(1/p_max)       
+!!$
+!!$       DO p = 1,20
+!!$          nb_trees_i(p) = NINT(MAXVAL(nmaxtrees)*(EXP(-lambda*max_circ_init*(p-1)/20)-EXP(-lambda*max_circ_init*p/20)))
+!!$       ENDDO
+!!$       excedent = REAL(MAXVAL(nmaxtrees),r_std)-SUM(nb_trees_i)
+!!$       nb_trees_i(:) = nb_trees_i(:) + FLOOR(excedent/20)
+!!$       nb_trees_i(1) = nb_trees_i(1) + NINT(excedent) - 20*FLOOR(excedent/20)
+!!$
+!!$       DO p = 1,20
+!!$          IF (nb_trees_i(p) > 0) THEN
+!!$             deb = 0
+!!$             IF (p > 1) deb = SUM(nb_trees_i(1:(p-1)))
+!!$             DO k = 1,NINT(nb_trees_i(p))
+!!$                circ_ij(deb+k) = min_circ_init + REAL(p-1)/20*max_circ_init + k*max_circ_init/(20*nb_trees_i(p))
+!!$             ENDDO
+!!$          ENDIF
+!!$       ENDDO
+!!$       circ_ij(:) = circ_ij(:)*0.01 !changed to meters
+!!$       ntrees = COUNT(MASK = circ_ij .GT. zero)
+!!$
+!!$    END IF ! control%forest_management
+    !++++++++++++++++++++
+
+    !-
+    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)) THEN 
+       ind(:,:) = zero
+       !+++++ CHECK +++++
+       ! this makes it so managed forests don't go through prescribe, which seems incorrect
+       ! maybe it was needed for the old allocation scheme?
+       !       IF ( control%forest_management ) THEN
+       !          DO j = 2,nvm
+       !             WHERE ( forest_managed(:,j) > 0 ) ind(:,j) = REAL(ntrees)/10000.
+       !          ENDDO
+       !       END IF
+       !+++++++++++++++++
+    ENDIF
+    !-
+    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
+    DO k = 1,nparts
+       WRITE(part_str,'(I2)') k
+       IF ( k < 10 ) part_str(1:1) = '0'
+       var_name = 'turnover_time_'//part_str(1:LEN_TRIM(part_str))
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., turnover_time(:,:,k), 'gather', nbp_glo, index_g)
+       IF ( ALL( turnover_time(:,:,k) == val_exp)) turnover_time(:,:,k) = 100.
+    ENDDO
+    !-
+    turnover_longterm(:,:,:,:) = val_exp
+    DO l = 1,nelements
+       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))//TRIM(element_str(l))
+          CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+               &              .TRUE., turnover_longterm(:,:,k,l), 'gather', nbp_glo, index_g)
+          IF (ALL(turnover_longterm(:,:,k,l) == val_exp)) &
+               &       turnover_longterm(:,:,k,l) = zero
+       ENDDO
+    END DO
+    !-
+    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 l = 1,nelements
+       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))//TRIM(element_str(l))
+          CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+               &                   .TRUE., biomass(:,:,k,l), 'gather', nbp_glo, index_g)
+          IF (ALL(biomass(:,:,k,l) == val_exp)) biomass(:,:,k,l) = zero
+       ENDDO
+    END DO
+    !-
+    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
+    !-
+    circ_class_n(:,:,:) = val_exp
+    DO m=1,ncirc
+       WRITE(part_str,'(I2)') m
+       IF ( m < 10 ) part_str(1:1) = '0'
+       var_name = 'circ_class_n_'//part_str(1:LEN_TRIM(part_str))
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &                  .TRUE., circ_class_n(:,:,m), 'gather', nbp_glo, index_g)
+       IF (ALL(circ_class_n(:,:,m) == val_exp)) circ_class_n(:,:,m) = zero
+    ENDDO
+    !-
+
+    ! added by yitong yao 07 Jan 2020 16:13 
+    counter_psi(:,:,:) = val_exp
+    DO m=1,ncirc
+       WRITE(part_str,'(I2)') m
+       IF ( m < 10 ) part_str(1:1) = '0'
+       var_name = 'counter_psi_'//part_str(1:LEN_TRIM(part_str))
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &                  .TRUE., counter_psi(:,:,m), 'gather', nbp_glo,index_g)
+       IF (ALL(counter_psi(:,:,m) == val_exp)) counter_psi(:,:,m) = zero
+    ENDDO
+    ! added by yitong yao 07 Jan 2020 16:13 
+
+    ! added by yitong yao 07 Jan 2020 16:13
+    counter_2(:,:,:) = val_exp
+    DO m=1,ncirc
+       WRITE(part_str,'(I2)') m
+       IF ( m < 10 ) part_str(1:1) = '0'
+       var_name = 'counter_2_'//part_str(1:LEN_TRIM(part_str))
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &                  .TRUE., counter_2(:,:,m), 'gather', nbp_glo,index_g)
+       IF (ALL(counter_2(:,:,m) == val_exp)) counter_2(:,:,m) = zero
+    ENDDO
+    ! added by yitong yao 07 Jan 2020 16:13
+    
+    ! added by yitong yao 07 Jan 2020 16:13
+    counter_0(:,:,:) = val_exp
+    DO m=1,ncirc
+       WRITE(part_str,'(I2)') m
+       IF ( m < 10 ) part_str(1:1) = '0'
+       var_name = 'counter_0_'//part_str(1:LEN_TRIM(part_str))
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &                  .TRUE., counter_0(:,:,m), 'gather', nbp_glo,index_g)
+       IF (ALL(counter_0(:,:,m) == val_exp)) counter_0(:,:,m) = zero
+    ENDDO
+    ! added by yitong yao 07 Jan 2020 16:13
+
+
+
+
+
+
+
+    circ_class_biomass(:,:,:,:,:) = val_exp
+    DO m = 1,nelements
+       DO l = 1,nparts
+          DO k = 1,ncirc 
+             WRITE(part_str,'(I2)') l
+             IF ( l < 10 ) part_str(1:1) = '0'
+             WRITE(circ_str, '(I2.2)') k
+             var_name = 'cc_bio_'//part_str(1:LEN_TRIM(part_str))//TRIM(element_str(m))//'_'//TRIM(circ_str)
+             CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+                  &         .TRUE., circ_class_biomass(:,:,k,l,m), 'gather', nbp_glo, index_g)
+             IF (ALL(circ_class_biomass(:,:,k,l,m) == val_exp)) circ_class_biomass(:,:,k,l,m) = zero
+          ENDDO
+       ENDDO
+    ENDDO
+    !-
+    lai_per_level(:,:,:) = val_exp
+    DO m=1,nlevels_tot
+       WRITE(part_str,'(I2)') m
+       IF ( m < 10 ) part_str(1:1) = '0'
+       var_name = 'lai_per_level_'//part_str(1:LEN_TRIM(part_str))
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &                  .TRUE., lai_per_level(:,:,m), 'gather', nbp_glo, index_g)
+       IF (ALL(lai_per_level(:,:,m) == val_exp)) lai_per_level(:,:,m) = zero
+    ENDDO
+    !
+    ! This is ugly, since the restart routines were not developed to deal with structures. 
+    ! But all I have to do is copy some things to arrays.
+    temp_array(:,:,:,:) = val_exp
+    DO m=1,nlevels_tot
+       WRITE(part_str,'(I2)') m
+       IF ( m < 10 ) part_str(1:1) = '0'
+       DO n=1,nparams_laieff
+          WRITE(part_str2,'(I2)') n
+          IF ( n < 10 ) part_str2(1:1) = '0'
+
+          var_name = 'laieff_fit__'//part_str(1:LEN_TRIM(part_str)) // '_' &
+               // part_str2(1:LEN_TRIM(part_str2))
+          CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+               .TRUE., temp_array(:,:,m,n), 'gather', nbp_glo, index_g)
+          IF (ALL(temp_array(:,:,m,n) == val_exp)) temp_array(:,:,m,n) = zero
+       ENDDO
+    ENDDO
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          DO ilev=1,nlevels_tot
+             laieff_fit(ipts,ivm,ilev)%a=temp_array(ipts,ivm,ilev,1)
+             laieff_fit(ipts,ivm,ilev)%b=temp_array(ipts,ivm,ilev,2)
+             laieff_fit(ipts,ivm,ilev)%c=temp_array(ipts,ivm,ilev,3)
+             laieff_fit(ipts,ivm,ilev)%d=temp_array(ipts,ivm,ilev,4)
+             laieff_fit(ipts,ivm,ilev)%e=temp_array(ipts,ivm,ilev,5)
+          ENDDO
+       ENDDO
+    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
+    !-
+    senescence_days(:,:) = val_exp
+    var_name = 'senescence_days'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., senescence_days, 'gather', nbp_glo, index_g)
+    IF (ALL(senescence_days(:,:) == val_exp)) &
+         &     senescence_days(:,:) = zero
+    !-
+    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)
+    ! Assume the last growing season started 8 months ago. This way deciduous
+    ! pft can have leaves in year one although the phenology in the first year
+    ! of a cold start may be off by up to 60 days or so.
+    IF (ALL(when_growthinit(:,:) == val_exp)) &
+         &     when_growthinit(:,:) = 240
+    !-
+    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
+    !-
+    KF(:,:) = val_exp
+    var_name = 'KF'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &                .TRUE., KF, 'gather', nbp_glo, index_g)
+    ! I don't want to set it equal to zero, since this is a problem if these
+    ! values are not here!  Better it blows up later on
+    !IF (ALL(KF(:,:) == val_exp)) KF(:,:) = zero
+
+    k_latosa_adapt(:,:) = val_exp
+    var_name = 'k_latosa_adapt'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &                .TRUE., k_latosa_adapt, 'gather', nbp_glo, index_g)
+    DO ivm = 1,nvm
+       IF (ALL(k_latosa_adapt(:,ivm) == val_exp)) k_latosa_adapt(:,ivm) = k_latosa_min(ivm)
+    ENDDO
+
+    !-
+    ! 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_hetero_litter(:,:) = val_exp
+    var_name = 'resp_hetero_litter'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                .TRUE., resp_hetero_litter, 'gather', nbp_glo, index_g)
+    IF (ALL(resp_hetero_litter(:,:) == val_exp)) resp_hetero_litter(:,:) = zero
+    !-
+
+    resp_hetero_soil(:,:) = val_exp
+    var_name = 'resp_hetero_soil'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                .TRUE., resp_hetero_soil, 'gather', nbp_glo, index_g)
+    IF (ALL(resp_hetero_soil(:,:) == val_exp)) resp_hetero_soil(:,:) = 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 k = 1,nelements
+       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)//TRIM(element_str(k))
+             CALL restget_p (rest_id_stomate, var_name, nbp_glo, nlitt , 1, itime, &
+                  &                     .TRUE., litter(:,:,m,l,k), 'gather', nbp_glo, index_g)
+             IF (ALL(litter(:,:,m,l,k) == val_exp)) litter(:,:,m,l,k) = zero
+          ENDDO
+       ENDDO
+    END DO
+    !-
+    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
+    !-
+    lignin_wood(:,:,:) = val_exp
+    DO l=1,nlevs
+       var_name = 'lignin_wood_'//level_str(l)
+       CALL restget_p &
+            &    (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &     .TRUE., lignin_wood(:,:,l), 'gather', nbp_glo, index_g)
+       IF (ALL(lignin_wood(:,:,l) == val_exp)) lignin_wood(:,:,l) = zero
+    ENDDO
+    !-
+    ! 18 land cover change
+    !-
+    prod_s(:,:) = val_exp
+    var_name = 'prod_s'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nshort+1 , 1, itime, &
+         &                .TRUE., prod_s, 'gather', nbp_glo, index_g)
+    IF (ALL(prod_s(:,:) == val_exp)) prod_s(:,:) = zero
+
+    prod_m(:,:) = val_exp
+    var_name = 'prod_m'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nmedium+1, 1, itime, &
+         &                .TRUE., prod_m, 'gather', nbp_glo, index_g)
+    IF (ALL(prod_m(:,:) == val_exp)) prod_m(:,:) = zero
+
+    prod_l(:,:) = val_exp
+    var_name = 'prod_l'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nlong+1     , 1, itime, &
+         &                .TRUE., prod_l, 'gather', nbp_glo, index_g)
+    IF (ALL(prod_l(:,:) == val_exp)) prod_l(:,:) = zero
+
+    flux_s(:,:) = val_exp
+    var_name = 'flux_s'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nshort     , 1, itime, &
+         &                .TRUE., flux_s, 'gather', nbp_glo, index_g)
+    IF (ALL(flux_s(:,:) == val_exp)) flux_s(:,:) = zero
+
+    flux_m(:,:) = val_exp
+    var_name = 'flux_m'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nmedium     , 1, itime, &
+         &                .TRUE., flux_m, 'gather', nbp_glo, index_g)
+    IF (ALL(flux_m(:,:) == val_exp)) flux_m(:,:) = zero
+
+    flux_l(:,:) = val_exp
+    var_name = 'flux_l'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nlong     , 1, itime, &
+         &                .TRUE., flux_l, 'gather', nbp_glo, index_g)
+    IF (ALL(flux_l(:,:) == val_exp)) flux_l(:,:) = zero
+
+    cflux_prod_s(:) = val_exp
+    var_name = 'cflux_prod_s'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &              .TRUE., cflux_prod_s, 'gather', nbp_glo, index_g)
+    IF (ALL(cflux_prod_s(:) == val_exp)) cflux_prod_s(:) = zero
+
+    cflux_prod_m(:) = val_exp
+    var_name = 'cflux_prod_m'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &              .TRUE., cflux_prod_m, 'gather', nbp_glo, index_g)
+    IF (ALL(cflux_prod_m(:) == val_exp)) cflux_prod_m(:) = zero
+
+    cflux_prod_l(:) = val_exp
+    var_name = 'cflux_prod_l'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &              .TRUE., cflux_prod_l, 'gather', nbp_glo, index_g)
+    IF (ALL(cflux_prod_l(:) == val_exp)) cflux_prod_l(:) = zero
+
+    rue_longterm(:,:) = val_exp
+    var_name = 'rue_longterm'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm , 1, itime, &
+         &        .TRUE., rue_longterm(:,:), 'gather', nbp_glo, index_g)
+    IF (ALL(rue_longterm(:,:) == val_exp)) rue_longterm(:,:) = 1.
+
+!!$    lai_target(:,:) = val_exp
+!!$    var_name = 'lai_target'
+!!$    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm , 1, itime, &
+!!$         &        .TRUE., lai_target(:,:), 'gather', nbp_glo, index_g)
+!!$    IF (ALL(lai_target(:,:) == val_exp)) lai_target(:,:) = zero
+
+    fpc_max(:,:) = val_exp
+    var_name = 'fpc_max'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm , 1, itime, &
+         &        .TRUE., fpc_max(:,:), 'gather', nbp_glo, index_g)
+    IF (ALL(fpc_max(:,:) == val_exp)) fpc_max(:,:) = .25
+
+    bm_to_litter(:,:,:,:) = val_exp
+    DO l = 1,nelements
+       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))//TRIM(element_str(l))
+          CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+               &                .TRUE., bm_to_litter(:,:,k,l), 'gather', nbp_glo, index_g)
+          IF (ALL(bm_to_litter(:,:,k,l) == val_exp)) bm_to_litter(:,:,k,l) = zero
+       ENDDO
+    END DO
+
+    carb_mass_total(:) = val_exp
+    var_name = 'carb_mass_total'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &              .TRUE., carb_mass_total, 'gather', nbp_glo, index_g)
+    IF (ALL(carb_mass_total(:) == val_exp)) carb_mass_total(:) = zero
+
+    ! The routines don't like to store integer variables.  So instead
+    ! we create a real array.  If the value of the real array is one,
+    ! we assign a value of TRUE to the logical array.  Anything
+    ! else is .FALSE.
+    rpft_replant(:,:) = val_exp
+    var_name = 'sc_map'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm , 1, itime, &
+         &        .TRUE., rpft_replant(:,:), 'gather', nbp_glo, index_g)
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          IF( rpft_replant(ipts,ivm) .LT. nvm*2)THEN
+             species_change_map(ipts,ivm)=NINT(rpft_replant(ipts,ivm))
+          ELSE
+             species_change_map(ipts,ivm)=0
+          ENDIF
+       ENDDO
+    ENDDO
+
+    ! The routines don't like to store logical variables.  So instead
+    ! we create a real array.  If the value of the real array is one,
+    ! we assign a value of TRUE to the logical array.  Anything
+    ! else is .FALSE.
+    rpft_replant(:,:) = val_exp
+    var_name = 'lpft_replant'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm , 1, itime, &
+         &        .TRUE., rpft_replant(:,:), 'gather', nbp_glo, index_g)
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          IF(ABS(rpft_replant(ipts,ivm) - un) .LT. 0.001)THEN
+             lpft_replant(ipts,ivm)=.TRUE.
+          ENDIF
+       ENDDO
+    ENDDO
+
+   !-
+    ! 19. Spinup
+    !-
+    IF (spinup_analytic) THEN
+
+       IF (is_root_prc) THEN
+          temp_global_years(1) = val_exp
+          var_name = 'Global_years'
+          CALL restget (rest_id_stomate, var_name, 1 ,1  , 1, itime, &
+               &                .TRUE., temp_global_years)
+          IF(temp_global_years(1) == val_exp) temp_global_years(1) = zero
+          global_years = INT(temp_global_years(1))
+       ENDIF
+       CALL bcast(global_years)
+
+       nbp_accu(:) = val_exp
+       var_name = 'nbp_sum'
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+            &              .TRUE., nbp_accu, 'gather', nbp_glo, index_g)
+       IF (ALL(nbp_accu(:) == val_exp)) nbp_accu(:) = zero    
+
+       nbp_flux(:) = val_exp
+       var_name = 'nbp_flux'
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+            &              .TRUE., nbp_flux, 'gather', nbp_glo, index_g)
+       IF (ALL(nbp_flux(:) == val_exp)) nbp_flux(:) = zero     
+
+       !-
+       ok_equilibrium_real(:) = val_exp
+       var_name = 'ok_equilibrium'
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo , 1  , 1, itime, &
+            &                .TRUE., ok_equilibrium_real,'gather', nbp_glo, index_g)
+       IF (ALL(ok_equilibrium_real(:) == val_exp)) ok_equilibrium_real(:) = zero
+       WHERE(ok_equilibrium_real(:) >= 0.5) 
+          ok_equilibrium = .TRUE.
+       ELSEWHERE
+          ok_equilibrium = .FALSE.
+       ENDWHERE
+
+       MatrixV(:,:,:,:) = val_exp
+       DO k = 1,nbpools
+          DO j = 1,nbpools
+             WRITE(part_str,'(I2)') k
+             IF (k < 10) part_str(1:1) = '0'             
+             var_name = 'MatrixV_'//part_str(1:LEN_TRIM(part_str))//'_'//TRIM(pools_str(j))
+             CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm , 1, itime, &
+                  &                     .TRUE., MatrixV(:,:,k,j), 'gather', nbp_glo, index_g)
+          ENDDO
+       ENDDO
+       ! If nothing is found in the restart file, we initialize each submatrix by identity
+       IF (ALL(MatrixV(:,:,:,:) == val_exp))  THEN 
+          MatrixV(:,:,:,:) = zero
+          DO l = 1,nbpools
+             MatrixV(:,:,l,l) = un
+          END DO
+       END IF
+
+       VectorU(:,:,:)  = val_exp
+       DO k= 1,nbpools
+          WRITE(part_str,'(I2)') k
+          IF (k < 10) part_str(1:1) = '0' 
+          var_name = 'Vector_U_'//part_str(1:LEN_TRIM(part_str))
+          CALL restget_p &
+               &    (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+               &     .TRUE., VectorU(:,:,k), 'gather', nbp_glo, index_g)
+          IF (ALL(VectorU(:,:,k) == val_exp))  VectorU(:,:,k) = zero
+       ENDDO
+
+       previous_stock(:,:,:)  = val_exp
+       DO k= 1,nbpools
+          WRITE(part_str,'(I2)') k
+          IF (k < 10) part_str(1:1) = '0' 
+          var_name = 'previous_stock_'//part_str(1:LEN_TRIM(part_str))
+          CALL restget_p &
+               &    (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+               &     .TRUE., previous_stock(:,:,k), 'gather', nbp_glo, index_g)
+          IF (ALL(previous_stock(:,:,k) == val_exp))  previous_stock(:,:,k) = undef_sechiba
+       ENDDO
+
+       current_stock(:,:,:)  = val_exp
+       DO k= 1,nbpools
+          WRITE(part_str,'(I2)') k
+          IF (k < 10) part_str(1:1) = '0' 
+          var_name = 'current_stock_'//part_str(1:LEN_TRIM(part_str))
+          CALL restget_p &
+               &    (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+               &     .TRUE., current_stock(:,:,k), 'gather', nbp_glo, index_g)
+          IF (ALL(current_stock(:,:,k) == val_exp))  current_stock(:,:,k) = zero
+       ENDDO
+
+    ENDIF ! spinup_matrix_method
+
+    !-
+    ! 20. Forest management.  Notice that if we're using functional allocation, we are also
+    !    doing forestry in the sense that we have all the same information available.
+    !-
+    IF ( control%forest_management .OR. control%ok_functional_allocation ) THEN
+
+       temp_real(:,:) = val_exp
+       var_name = 'age_stand'
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &              .TRUE., temp_real, 'gather', nbp_glo, index_g)
+       IF ( ALL(temp_real(:,:) == val_exp) ) THEN
+          age_stand(:,:) = 0
+       ELSE
+          age_stand = NINT(temp_real)
+       ENDIF
+
+       mai(:,:) = val_exp
+       var_name = 'mai'
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &              .TRUE., mai, 'gather', nbp_glo, index_g)
+       IF ( ALL(mai(:,:) == val_exp) ) mai(:,:) = zero
+
+       pai(:,:) = val_exp
+       var_name = 'pai'
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &              .TRUE., pai, 'gather', nbp_glo, index_g)
+       IF ( ALL(pai(:,:) == val_exp) ) pai(:,:) = zero
+
+       previous_wood_volume(:,:) = val_exp
+       var_name = 'previous_wood_volume'
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &              .TRUE., previous_wood_volume, 'gather', nbp_glo, index_g)
+       IF ( ALL(previous_wood_volume(:,:) == val_exp) ) previous_wood_volume(:,:) = zero
+
+       temp_real(:,:) = val_exp
+       var_name = 'mai_count'
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &              .TRUE., temp_real, 'gather', nbp_glo, index_g)
+       IF ( ALL(temp_real(:,:) == val_exp) ) THEN
+          mai_count(:,:) = 0
+       ELSE
+          mai_count = NINT(temp_real)
+       ENDIF
+
+       coppice_dens(:,:) = val_exp
+       var_name = 'coppice_dens'
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &              .TRUE., coppice_dens, 'gather', nbp_glo, index_g)
+       IF ( ALL(coppice_dens(:,:) == val_exp) ) coppice_dens(:,:) = zero
+
+       !-
+       temp_real(:,:) = val_exp
+       var_name = 'fm_lyear'
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &              .TRUE., temp_real, 'gather', nbp_glo, index_g)
+       IF ( ALL(temp_real(:,:) == val_exp) ) THEN
+          forest_managed_lastyear(:,:) = 0
+       ELSE
+          forest_managed_lastyear = NINT(temp_real)
+       ENDIF
+       !-
+       !+++CHECK+++
+       ! The comment is true for height but not for av_height
+!!$       ! av_height is read just to show that it is in the restart file. It is not used 
+!!$       ! and therefore it is not passed to stomate.f90. It is however written because to
+!!$       ! restart file because slowproc.f90 checks wether it has a value. If it has a value
+!!$       ! that value is used by sechiba. If not it implies that stomate.f90 was not used
+!!$       ! and then it uses a prescribed height.
+!!$       av_height(:,:) = val_exp
+!!$       var_name = 'av_height'
+!!$       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+!!$            &              .TRUE., av_height, 'gather', nbp_glo, index_g)
+!!$       IF ( ALL(av_height(:,:) == val_exp) ) av_height(:,:) = un
+       !+++++++++++
+       !-  
+       temp_real(:,:) = val_exp
+       var_name = 'rotation_n'
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &              .TRUE., temp_real, 'gather', nbp_glo, index_g)
+       IF ( ALL(temp_real(:,:) == val_exp) ) THEN
+          rotation_n(:,:) = 1
+       ELSE
+          rotation_n(:,:) = NINT(temp_real(:,:))
+       ENDIF
+       !-
+       temp_real(:,:) = val_exp
+       var_name = 'last_cut'
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &              .TRUE., temp_real, 'gather', nbp_glo, index_g)
+       IF ( ALL(temp_real(:,:) == val_exp) ) THEN
+          last_cut(:,:) = 0
+       ELSE
+          last_cut(:,:) = NINT(temp_real(:,:))
+       ENDIF
+       !-
+!!$       lai_max_calc(:,:) = val_exp
+!!$       var_name = 'lai_max_calc'
+!!$       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+!!$            &              .TRUE., lai_max_calc, 'gather', nbp_glo, index_g)
+!!$       IF ( ALL(lai_max_calc(:,:) == val_exp) ) lai_max_calc(:,:) = un
+!!$       !-
+!!$       biomass_lastyear(:,:,:,:) = val_exp
+!!$       DO k = 1,nparts
+!!$          WRITE(part_str,'(I2)') k
+!!$          IF ( k < 10 ) part_str(1:1) = '0'
+!!$          var_name = 'bm_lyear_'//part_str(1:LEN_TRIM(part_str))
+!!$          CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+!!$               &                .TRUE., biomass_lastyear(:,:,k,icarbon), 'gather', nbp_glo, index_g)
+!!$          IF ( ALL(biomass_lastyear(:,:,k,icarbon) == val_exp) ) biomass_lastyear(:,:,k,icarbon) = zero
+!!$       ENDDO
+!!$       !-
+!!$       lai_max_lastyear(:,:) = val_exp
+!!$       var_name = 'lai_max_lyear'
+!!$       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+!!$            &              .TRUE., lai_max_lastyear, 'gather', nbp_glo, index_g)
+!!$       IF ( ALL(lai_max_lastyear(:,:) == val_exp) ) lai_max_lastyear(:,:) = zero
+
+    END IF ! (control%forest_management)
+
+    IF (bavard >= 4) WRITE(numout,*) 'Leaving readrestart'
+
+  END SUBROUTINE readrestart
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : writerestart
+!!
+!>\BRIEF         writes start file
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE writerestart (npts, index, day_counter, dt_days, &
+       date, ind, adapted, regenerate, &
+       moiavail_daily, gdd_init_date, 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, moiavail_growingseason, 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_from_growthinit, 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, senescence_days, &
+       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, & 
+       lignin_wood, turnover_time, prod_s, prod_m, prod_l, &
+       flux_s, flux_m, flux_l, cflux_prod_s, cflux_prod_m, &
+       cflux_prod_l, bm_to_litter, carb_mass_total, &
+       age_stand, &
+       rotation_n, last_cut, forest_managed, forest_managed_lastyear, &
+       global_years, ok_equilibrium, nbp_accu, &
+       nbp_flux, MatrixV, VectorU, previous_stock, &
+       current_stock, rue_longterm, fpc_max, &
+       circ_class_n, circ_class_biomass, KF, &
+       mai, pai, previous_wood_volume, &
+       mai_count, coppice_dens, vir_moiavail_growingseason, lai_per_level,&
+       laieff_fit, temp_growth, wstress_season, wstress_month, &
+       vir_wstress_fac, c_buried, k_latosa_adapt, species_change_map, &
+       lpft_replant,counter_psi,counter_2,counter_0,resp_hetero_litter,resp_hetero_soil)
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                                         :: npts                    !! Domain size
+    INTEGER(i_std), DIMENSION(npts), INTENT(in)                        :: index                   !! Indices of the points on the map
+    REAL(r_std), INTENT(in)                                            :: day_counter             !! counts time until next STOMATE time step
+    REAL(r_std), INTENT(in)                                            :: dt_days                 !! time step of STOMATE in days
+    INTEGER(i_std), INTENT(in)                                         :: date                    !! date (d)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: ind                     !! density of individuals (1/m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: adapted                 !! Winter too cold? between 0 and 1
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: regenerate              !! Winter sufficiently cold? between 0 and 1
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: moiavail_daily          !! daily moisture availability
+    REAL(r_std), DIMENSION(npts,4), INTENT(in)                         :: gdd_init_date           !! date for beginning of gdd count
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: litterhum_daily         !! daily litter humidity
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: t2m_daily               !! daily 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: t2m_min_daily           !! daily minimum 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: tsurf_daily             !! daily surface temperatures (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)                      :: tsoil_daily             !! daily soil temperatures (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)                      :: soilhum_daily           !! daily soil humidity
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: precip_daily            !! daily precipitations (mm/day) (for phenology)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: gpp_daily               !! daily gross primary productivity (gC/m**2/day)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: npp_daily               !! daily net primary productivity (gC/m**2/day)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(in)      :: turnover_daily          !! daily turnover rates (gC/m**2/day)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: moiavail_month          !! "monthly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: moiavail_week           !! "weekly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: moiavail_growingseason  !! "growing season" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: vir_moiavail_growingseason !! Virtual "growing season" moisture availability
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: t2m_longterm            !! "long term" 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: tlong_ref               !! "long term" reference 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: t2m_month               !! "monthly" 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: t2m_week                !! "weekly" 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)                      :: tsoil_month             !! "monthly" soil temperatures (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)                      :: soilhum_month           !! "monthly" soil humidity
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: fireindex               !! Probability of fire
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: firelitter              !! Longer term total litter above 
+                                                                                                  !! the ground, gC/m**2 of ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: maxmoiavail_lastyear    !! last year's maximum 
+                                                                                                  !! moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: maxmoiavail_thisyear    !! this year's maximum 
+                                                                                                  !! moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: minmoiavail_lastyear    !! last year's minimum 
+                                                                                                  !! moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: minmoiavail_thisyear    !! this year's minimum 
+                                                                                                  !! moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: maxgppweek_lastyear     !! last year's maximum weekly GPP
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: maxgppweek_thisyear     !! this year's maximum weekly GPP
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: gdd0_lastyear           !! last year's annual GDD0
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: gdd0_thisyear           !! this year's annual GDD0
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: precip_lastyear         !! last year's annual precipitation
+                                                                                                  !! (mm/year)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: precip_thisyear         !! this year's annual precipitation 
+                                                                                                  !! (mm/year)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: gdd_m5_dormance         !! growing degree days, threshold 
+                                                                                                  !! -5 deg C (for phenology)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: gdd_from_growthinit     !! growing degree days, 
+                                                                                                  !! from begin of season
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: gdd_midwinter           !! growing degree days since 
+                                                                                                  !! midwinter (for phenology)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: ncd_dormance            !! number of chilling days since 
+                                                                                                  !! leaves were lost (for phenology)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: ngd_minus5              !! number of growing days, threshold 
+                                                                                                  !! -5 deg C (for phenology)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                           :: PFTpresent              !! PFT exists (equivalent to 
+                                                                                                  !! fpc_max > 0 for natural PFTs)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: npp_longterm            !! "long term" net primary productivity 
+                                                                                                  !! (gC/m**2/year)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: lm_lastyearmax          !! last year's maximum leaf mass, 
+                                                                                                  !! for each PFT (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: lm_thisyearmax          !! this year's maximum leaf mass, 
+                                                                                                  !! for each PFT (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: maxfpc_lastyear         !! last year's maximum fpc for each 
+                                                                                                  !! natural PFT, on ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: maxfpc_thisyear         !! this year's maximum fpc for each 
+                                                                                                  !! PFT, on *total* ground (see stomate_season)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(in)      :: turnover_longterm       !! "long term" turnover rate (gC/m**2/year)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: gpp_week                !! "weekly" GPP (gC/day/(m**2 covered)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(in)      :: biomass                 !! biomass (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(in)                :: resp_maint_part         !! maintenance resp (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(in)             :: leaf_age                !! leaf age (days)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(in)             :: leaf_frac               !! fraction of leaves in leaf age class
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(in)                 :: circ_class_n            !! Number of trees in each circumference classes
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements), INTENT(in):: circ_class_biomass      !! Biomass components of the model tree within 
+                                                                                                  !! each circumference classes (gC ind-1)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                           :: senescence              !! is the plant senescent ? 
+                                                                                                  !! (only for deciduous trees - 
+                                                                                                  !! carbohydrate reserve)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: senescence_days         !! Days since start of senescence
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: when_growthinit         !! how many days ago was the beginning
+                                                                                                  !! of the growing season
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: age                     !! mean age (years)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: resp_hetero             !! heterotrophic respiration (gC/day/m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: resp_hetero_litter
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                           :: resp_hetero_soil 
+
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: resp_maint              !! maintenance respiration (gC/day/m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: resp_growth             !! growth respiration (gC/day/m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: co2_fire                !! 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_to_bm_dgvm          !! biomass uptaken 
+                                                                                                  !! (gC/(m**2 of total ground)/day)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: veget_lastlight         !! vegetation fractions (on ground) 
+                                                                                                  !! after last light competition
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: everywhere              !! is the PFT everywhere in the 
+                                                                                                  !! grid box or very localized 
+                                                                                                  !! (after its introduction)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                           :: need_adjacent           !! in order for this PFT to be introduced, 
+                                                                                                  !! does it have to be present in an 
+                                                                                                  !! adjacent grid box?
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: RIP_time                !! How much time ago was the PFT eliminated 
+                                                                                                  !! for the last time (y)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: time_lowgpp             !! Duration of dormance (d)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: time_hum_min            !! time elapsed since strongest moisture
+                                                                                                  !! availability (d)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: hum_min_dormance        !! minimum moisture during dormance
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(in)                 :: litterpart              !! fraction of litter above the ground
+                                                                                                  !! belonging to different PFTs separated 
+                                                                                                  !! for natural and agricultural PFTs.
+    REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements), INTENT(in) :: litter                  !! metabolic and structural litter, 
+                                                                                                  !! natural and agricultural, above and 
+                                                                                                  !! below ground (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(in)                 :: dead_leaves             !! dead leaves on ground, per PFT, 
+                                                                                                  !! metabolic and structural, 
+                                                                                                  !! in gC/(m**2 of ground)
+    REAL(r_std), DIMENSION(npts,ncarb,nvm), INTENT(in)                 :: carbon                  !! carbon pool: active, slow, or passive,
+                                                                                                  !! (gC/m**2)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: black_carbon            !! black carbon on the ground 
+                                                                                                  !! (gC/(m**2 of total ground))
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(in)                 :: lignin_struc            !! ratio Lignine/Carbon in structural litter,
+                                                                                                  !! above and below ground, 
+                                                                                                  !! (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(in)                 :: lignin_wood             !! ratio Lignine/Carbon in woody litter,
+                                                                                                  !! above and below ground, 
+                                                                                                  !! (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(in)                :: turnover_time           !!
+    INTEGER(i_std), DIMENSION(npts,nvm), INTENT(in)                    :: age_stand               !! Age of stand (years)
+    INTEGER(i_std), DIMENSION(npts,nvm), INTENT(in)                    :: rotation_n              !! Rotation number (number of rotation 
+                                                                                                  !! since pft is managed)
+    INTEGER(i_std), DIMENSION(npts,nvm), INTENT(in)                    :: last_cut                !! Years since last thinning (years)
+    INTEGER(i_std), DIMENSION(npts,nvm), INTENT(in)                    :: forest_managed          !! forest management flag
+    INTEGER(i_std), DIMENSION(npts,nvm), INTENT(in)                    :: forest_managed_lastyear !! forest management flag for the previous year
+    REAL(r_std), DIMENSION(npts,0:nshort), INTENT(in)                  :: prod_s                  !!
+    REAL(r_std), DIMENSION(npts,0:nmedium), INTENT(in)                 :: prod_m                  !!
+    REAL(r_std), DIMENSION(npts,0:nlong), INTENT(in)                   :: prod_l                  !!
+    REAL(r_std), DIMENSION(npts,nshort), INTENT(in)                    :: flux_s                  !!
+    REAL(r_std), DIMENSION(npts,nmedium), INTENT(in)                   :: flux_m                  !!
+    REAL(r_std), DIMENSION(npts,nlong), INTENT(in)                     :: flux_l                  !!
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: cflux_prod_s            !!
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: cflux_prod_m            !!
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: cflux_prod_l            !!
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(in)      :: bm_to_litter            !!
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: carb_mass_total         !!
+    INTEGER(i_std), INTENT(in)                                         :: global_years            !!
+    LOGICAL, DIMENSION(npts), INTENT(in)                               :: ok_equilibrium          !!
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: nbp_accu                !! Accumulated Net Biospheric 
+                                                                                                  !! Production over the year
+    ! added by yitong yao 07 Jan 2020 16:17
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(in)                 :: counter_psi
+    ! added by yitong yao 07 Jan 2020 16:17 above line
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(in)                 :: counter_2
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(in)                 :: counter_0
+
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: nbp_flux                !! Net Biospheric Production over the year
+    REAL(r_std), DIMENSION(npts,nvm,nbpools,nbpools), INTENT(in)       :: MatrixV                 !!
+    REAL(r_std), DIMENSION(npts,nvm,nbpools), INTENT(in)               :: VectorU                 !!
+    REAL(r_std), DIMENSION(npts,nvm,nbpools), INTENT(in)               :: previous_stock          !! 
+    REAL(r_std), DIMENSION(npts,nvm,nbpools), INTENT(in)               :: current_stock           !!
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: rue_longterm            !! Longterm radiation use efficiency
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: fpc_max                 !! Leaf projective cover  
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: KF                      !! Scaling factor to convert sapwood mass
+                                                                                                  !! into leaf mass (m)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: k_latosa_adapt          !! Leaf to sapwood area adapted for water 
+                                                                                                  !! stress. Adaptation takes place at the 
+                                                                                                  !! end of the year (m)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: mai                     !! The mean annual increment
+                                                                                                  !! @tex $(m**3 / m**2 / year)$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: pai                     !! The period annual increment
+                                                                                                  !! @tex $(m**3 / m**2 / year)$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                       :: previous_wood_volume    !! The volume of the tree trunks
+                                                                                                  !! in a stand for the previous year.
+                                                                                                  !! @tex $(m**3 / m**2 )$ @endtex
+    INTEGER(i_std), DIMENSION(npts,nvm),INTENT(in)                     :: mai_count               !! The number of times we've
+                                                                                                  !! calculated the volume increment
+                                                                                                  !! for a stand
+    REAL(r_std), DIMENSION(npts,nvm),INTENT(in)                        :: coppice_dens            !! The density of a coppice at the first
+                                                                                                  !! cutting.
+                                                                                                  !! @tex $( 1 / m**2 )$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm,nlevels_tot), INTENT(in)           :: lai_per_level           !! The amount of LAI in each physical
+                                                                                                  !! canopy level.
+                                                                                                  !! @tex $( m**2 / m**2 )$ @endtex 
+    TYPE(laieff_type),DIMENSION (:,:,:),INTENT(in)                     :: laieff_fit              !! Fitted parameters for the effective LAI
+    REAL(r_std),DIMENSION(npts),INTENT(in)                             :: temp_growth             !! Growth temperature (Â°C) 
+                                                                                                  !! Is equal to t2m_month
+    REAL(r_std), DIMENSION(:,:), INTENT(in)                            :: vir_wstress_fac         !! Virtual water stress factor, based on hum_rel_daily
+                                                                                                  !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)                            :: wstress_season          !! Water stress factor, based on hum_rel_daily
+                                                                                                  !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)                            :: wstress_month           !! Water stress factor, based on hum_rel_daily
+                                                                                                  !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)                            :: c_buried                !! Carbon that is buried when land cover changes
+                                                                                                  !! to a nobio type.  
+                                                                                                  !! @tex $( gC )$ @endtex 
+    INTEGER(i_std), DIMENSION(:,:), INTENT(in)                         :: species_change_map      !! A map which gives the PFT number that each
+                                                                                                  !! PFT will be replanted as in case of a clearcut.
+                                                                                                  !! (1-nvm,unitless)
+    LOGICAL, DIMENSION(:,:), INTENT(in)                                :: lpft_replant            !! Indicates if this PFT has either died this year
+                                                                                                  !! or been clearcut/coppiced.  If it has, it is not
+                                                                                                  !! replanted until the end of the year.
+
+    !! 0.4 Local variables
+
+    REAL(r_std)                                                        :: date_real               !! date, real
+    REAL(r_std), DIMENSION(npts,nvm)                                   :: PFTpresent_real         !! PFT exists (equivalent to 
+                                                                                                  !! fpc_max > 0 for natural PFTs), real
+    REAL(r_std), DIMENSION(npts,nvm)                                   :: senescence_real         !! is the plant senescent ?
+                                                                                                  !! (only for deciduous trees -
+                                                                                                  !! carbohydrate reserve), real
+    REAL(r_std), DIMENSION(npts,nvm)                                   :: need_adjacent_real      !! in order for this PFT to be introduced,
+                                                                                                  !! does it have to be present in an 
+                                                                                                  !! adjacent grid box? - real
+    CHARACTER(LEN=80)                                                  :: var_name                !! To store variables names for I/O
+    CHARACTER(LEN=10)                                                  :: part_str                !! string suffix indicating an index
+    CHARACTER(LEN=10)                                                  :: part_str2               !! string suffix indicating an index
+    CHARACTER(LEN=10)                                                  :: circ_str                !! string suffix indicating an index
+    CHARACTER(LEN=3), DIMENSION(nlitt)                                 :: litter_str              !! string suffix indicating litter type
+    CHARACTER(LEN=2), DIMENSION(nlevs)                                 :: level_str               !! string suffix indicating level
+    REAL(r_std), DIMENSION(1)                                          :: xtmp                    !! temporary storage
+    INTEGER(i_std)                                                     :: j,k,l,m,p,ibp           !! index
+    INTEGER(i_std)                                                     :: idia, icut, ifm         !! index
+    INTEGER(i_std)                                                     :: ipts, ivm               !! index
+    CHARACTER(LEN=2), DIMENSION(nelements)                             :: element_str             !! string suffix indicating element
+    REAL(r_std), DIMENSION(npts,nvm)                                   :: temp_real               !! temporary real to allow restget 
+                                                                                                  !! to work on multi-dimensional integers
+    REAL(r_std), DIMENSION(1)                                          :: temp_global_years       !!
+    CHARACTER(LEN=7), DIMENSION(nbpools)                               :: pools_str               !!
+    REAL(r_std), DIMENSION(npts)                                       :: ok_equilibrium_real     !!
+    REAL(r_std), DIMENSION(npts,nvm)                                   :: lai                     !! Leaf area index 
+                                                                                                  !! @tex $(m^{2}.m^{-2})$ @endtex 
+    CHARACTER(LEN=80)                                                  :: cut_name                !! To store variables names for I/O
+    CHARACTER(LEN=80)                                                  :: fm_name                 !! To store variables names for I/O
+    REAL(r_std),DIMENSION(npts,nvm,nlevels_tot,nparams_laieff)         :: temp_array              !! To store structure values for I/O        
+    INTEGER                                                            :: n,ilev                  !! Indices
+    REAL(r_std), DIMENSION(npts,nvm)                                   :: rpft_replant            !! Writing integer and logical values
+                                                                                                  !! to the restart file is not possible,
+                                                                                                  !! so we convert to real first.
+                                                                                                  !! 1.0 is TRUE for a logical array.
+!_ ================================================================================================================================
+
+    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'
+       ELSEIF (l == iwoody) THEN
+          litter_str(l) = 'wod'
+       ELSE
+          CALL ipslerr_p (3,'stomate_io', &
+               'Write restart - 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
+          CALL ipslerr_p (3,'stomate_io', &
+               'Write restart - Define level str','','')
+       ENDIF
+    ENDDO
+    !-
+    DO l=1,nelements
+       IF     (l == icarbon) THEN
+          element_str(l) = ''
+!!$       ELSEIF (l == initrogen) THEN
+!!$          element_str(l) = '_n'
+       ELSE
+          CALL ipslerr_p (3,'stomate_io', &
+               'Write restart - Define element str','','')
+       ENDIF
+    ENDDO
+    !-
+    pools_str(1:nbpools) =(/'str_ab ','str_be ','met_ab ','met_be ','wood_ab','wood_be', &
+         'actif  ','slow   ','passif '/)
+    !-
+    IF (is_root_prc) THEN
+       CALL ioconf_setatt_p ('UNITS','-')
+       CALL ioconf_setatt_p ('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 = 'gdd_init_date'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo,    4, 1, itime, &
+         &              gdd_init_date, '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)
+    !-
+    var_name = 'temp_growth'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo,    1, 1, itime, &
+         &                temp_growth, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'wstress_season'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                wstress_season, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'wstress_month'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                wstress_month, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'vir_wstress_fac'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                vir_wstress_fac, 'scatter', nbp_glo, index_g)
+    var_name = 'c_buried'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nnobio, 1, itime, &
+         &                c_buried, '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 l = 1,nelements
+       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))//TRIM(element_str(l))
+          CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+               &                   turnover_daily(:,:,k,l), 'scatter', nbp_glo, index_g)
+       ENDDO
+    END DO
+    !-
+    ! 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 = 'moiavail_gs' 
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, & 
+         &              moiavail_growingseason, 'scatter', nbp_glo, index_g)
+    !- 
+    var_name = 'vir_moiavail_gs' 
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, & 
+         &              vir_moiavail_growingseason, '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_from_growthinit'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &              gdd_from_growthinit, '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)
+    !-
+    DO k = 1,nparts
+       WRITE(part_str,'(I2)') k
+       IF (k < 10) part_str(1:1) = '0'
+       var_name = 'turnover_time_'//part_str(1:LEN_TRIM(part_str))
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                turnover_time(:,:,k), 'scatter', nbp_glo, index_g)
+    ENDDO
+
+    !-
+    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 l = 1,nelements
+       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))//TRIM(element_str(l))
+          CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+               &                   turnover_longterm(:,:,k,l), 'scatter', nbp_glo, index_g)
+       ENDDO
+    END DO
+    !-
+    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 l = 1,nelements
+       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))//TRIM(element_str(l))
+          CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+               &                   biomass(:,:,k,l), 'scatter', nbp_glo, index_g)
+       ENDDO
+    END DO
+    !-
+    DO ivm = 1,nvm
+       DO ipts = 1,npts
+          lai(ipts,ivm) = biomass_to_lai(biomass(ipts,ivm,ileaf,icarbon),ivm)
+       ENDDO
+    ENDDO
+    var_name = 'lai'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                  lai, 'scatter', nbp_glo, index_g)
+    !-
+    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
+    !-
+    DO m=1,nlevels_tot
+       WRITE(part_str,'(I2)') m
+       IF (m < 10) part_str(1:1) = '0'
+       var_name = 'lai_per_level_'//part_str(1:LEN_TRIM(part_str))
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &                   lai_per_level(:,:,m), 'scatter', nbp_glo, index_g)
+    ENDDO
+    !-
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          DO ilev=1,nlevels_tot
+             temp_array(ipts,ivm,ilev,1)=laieff_fit(ipts,ivm,ilev)%a
+             temp_array(ipts,ivm,ilev,2)=laieff_fit(ipts,ivm,ilev)%b
+             temp_array(ipts,ivm,ilev,3)=laieff_fit(ipts,ivm,ilev)%c
+             temp_array(ipts,ivm,ilev,4)=laieff_fit(ipts,ivm,ilev)%d
+             temp_array(ipts,ivm,ilev,5)=laieff_fit(ipts,ivm,ilev)%e
+          ENDDO
+       ENDDO
+    ENDDO
+    DO m=1,nlevels_tot
+       WRITE(part_str,'(I2)') m
+       IF ( m < 10 ) part_str(1:1) = '0'
+       DO n=1,nparams_laieff
+          WRITE(part_str2,'(I2)') n
+          IF ( n < 10 ) part_str2(1:1) = '0'
+
+          var_name = 'laieff_fit__'//part_str(1:LEN_TRIM(part_str)) // '_' &
+               // part_str2(1:LEN_TRIM(part_str2))
+          CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+               &                   temp_array(:,:,m,n), 'scatter', nbp_glo, index_g)
+       ENDDO
+    ENDDO
+    !
+    DO m=1,ncirc
+       WRITE(part_str,'(I2)') m
+       IF (m < 10) part_str(1:1) = '0'
+       var_name = 'circ_class_n_'//part_str(1:LEN_TRIM(part_str))
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &                   circ_class_n(:,:,m), 'scatter', nbp_glo, index_g)
+    ENDDO
+    
+    ! added by yitong yao 07 Jan 2020 16:19
+    DO m=1,ncirc
+       WRITE(part_str,'(I2)') m
+       IF (m < 10) part_str(1:1) = '0'
+       var_name = 'counter_psi_'//part_str(1:LEN_TRIM(part_str))
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &                   counter_psi(:,:,m), 'scatter', nbp_glo,index_g)
+    ENDDO
+    ! added by yitong yao 07 Jan 2020 16:19 above line
+
+    !-
+
+    DO m=1,ncirc
+       WRITE(part_str,'(I2)') m
+       IF (m < 10) part_str(1:1) = '0'
+       var_name = 'counter_2_'//part_str(1:LEN_TRIM(part_str))
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &                   counter_2(:,:,m), 'scatter', nbp_glo,index_g)
+    ENDDO
+
+    DO m=1,ncirc
+       WRITE(part_str,'(I2)') m
+       IF (m < 10) part_str(1:1) = '0'
+       var_name = 'counter_0_'//part_str(1:LEN_TRIM(part_str))
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &                   counter_0(:,:,m), 'scatter', nbp_glo,index_g)
+    ENDDO
+
+
+
+
+
+
+
+
+
+
+    DO m = 1,nelements
+       DO l = 1,nparts
+          DO k = 1,ncirc 
+             WRITE(part_str,'(I2)') l
+             IF ( l < 10 ) part_str(1:1) = '0'
+             WRITE(circ_str, '(I2.2)') k
+             var_name = 'cc_bio_'//part_str(1:LEN_TRIM(part_str))//TRIM(element_str(m))//'_'//TRIM(circ_str)
+             CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+                &         circ_class_biomass(:,:,k,l,m), 'scatter', nbp_glo, index_g)
+          ENDDO
+       ENDDO
+    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 = 'senescence_days'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &              senescence_days, '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)
+    !-
+    var_name = 'KF'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+          &              KF(:,:), 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'k_latosa_adapt'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+          &              k_latosa_adapt(:,:), 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'rue_longterm'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+          &              rue_longterm(:,:), 'scatter', nbp_glo, index_g)
+    !-
+!!$    var_name = 'lai_target'
+!!$    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+!!$          &              lai_target(:,:), 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'fpc_max'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+          &              fpc_max(:,:), '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_hetero_litter'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                resp_hetero_litter, 'scatter', nbp_glo, index_g)
+
+    var_name = 'resp_hetero_soil'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                resp_hetero_soil, '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 k = 1,nelements
+       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)//TRIM(element_str(k))
+             CALL restput_p (rest_id_stomate, var_name, nbp_glo, nlitt, 1, itime, &
+                  &                     litter(:,:,m,l,k), 'scatter', nbp_glo, index_g)
+          ENDDO
+       ENDDO
+    END DO
+    !-
+    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
+    !-
+    DO l=1,nlevs
+       var_name = 'lignin_wood_'//level_str(l)
+       CALL restput_p &
+            &    (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &     lignin_wood(:,:,l), 'scatter', nbp_glo, index_g)
+    ENDDO
+    !-
+    ! 18 land cover change
+    !-
+    var_name = 'prod_s'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nshort+1, 1, itime, &
+         &                prod_s, 'scatter', nbp_glo, index_g)
+    var_name = 'prod_m'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nmedium+1, 1, itime, &
+         &                prod_m, 'scatter', nbp_glo, index_g)
+    var_name = 'prod_l'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nlong+1, 1, itime, &
+         &                prod_l, 'scatter', nbp_glo, index_g)
+    var_name = 'flux_s'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nshort, 1, itime, &
+         &                flux_s, 'scatter', nbp_glo, index_g)
+    var_name = 'flux_m'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nmedium, 1, itime, &
+         &                flux_m, 'scatter', nbp_glo, index_g)
+    var_name = 'flux_l'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nlong, 1, itime, &
+         &                flux_l, 'scatter', nbp_glo, index_g)
+    var_name = 'cflux_prod_s'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
+         &              cflux_prod_s, 'scatter', nbp_glo, index_g)
+    var_name = 'cflux_prod_m'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
+         &              cflux_prod_m, 'scatter', nbp_glo, index_g)
+    var_name = 'cflux_prod_l'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
+         &              cflux_prod_l, 'scatter', nbp_glo, index_g)
+    DO l = 1,nelements
+       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))//TRIM(element_str(l))
+          CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+               &                bm_to_litter(:,:,k,l), 'scatter', nbp_glo, index_g)
+       ENDDO
+    END DO
+
+    var_name = 'carb_mass_total'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
+         &              carb_mass_total, 'scatter', nbp_glo, index_g)
+
+    ! For these next two variables, we have to convert to a real array first.
+    rpft_replant(:,:)=REAL(species_change_map(:,:),r_std)
+    var_name = 'sc_map'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &              rpft_replant, 'scatter', nbp_glo, index_g)
+    
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          IF(lpft_replant(ipts,ivm))THEN
+             rpft_replant(ipts,ivm)=un
+          ELSE
+             rpft_replant(ipts,ivm)=zero
+          ENDIF
+       END DO
+    END DO
+    var_name = 'lpft_replant'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &              rpft_replant, 'scatter', nbp_glo, index_g)
+    !-
+    ! 19. Spinup
+    !-
+    IF (spinup_analytic) THEN
+
+       IF (is_root_prc) THEN
+          temp_global_years(1) = REAL(global_years)
+          var_name='Global_years'
+          CALL restput (rest_id_stomate, var_name, 1, 1, 1, itime, temp_global_years)
+       ENDIF
+       
+       var_name = 'nbp_sum'
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
+            &              nbp_accu, 'scatter', nbp_glo, index_g)
+
+       var_name = 'nbp_flux'
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
+            &              nbp_flux, 'scatter', nbp_glo, index_g)
+
+       var_name = 'ok_equilibrium'
+       WHERE(ok_equilibrium(:))
+          ok_equilibrium_real = un
+       ELSEWHERE
+          ok_equilibrium_real = zero
+       ENDWHERE
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
+            &               ok_equilibrium_real, 'scatter', nbp_glo, index_g)
+       
+       DO k = 1,nbpools
+          DO j = 1,nbpools
+             WRITE(part_str,'(I2)') k
+             IF (k < 10) part_str(1:1) = '0'             
+             var_name = 'MatrixV_'//part_str(1:LEN_TRIM(part_str))//'_'//TRIM(pools_str(j))
+             CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+                  &                MatrixV(:,:,k,j), 'scatter', nbp_glo, index_g)
+          ENDDO
+       ENDDO
+          
+       DO k = 1,nbpools
+          WRITE(part_str,'(I2)') k
+          IF (k < 10) part_str(1:1) = '0' 
+          var_name = 'Vector_U_'//part_str(1:LEN_TRIM(part_str))
+          CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+               &                VectorU(:,:,k), 'scatter', nbp_glo, index_g)
+       ENDDO
+          
+       DO k = 1,nbpools
+          WRITE(part_str,'(I2)') k
+          IF (k < 10) part_str(1:1) = '0' 
+          var_name = 'previous_stock_'//part_str(1:LEN_TRIM(part_str))
+          CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+               &                previous_stock(:,:,k), 'scatter', nbp_glo, index_g)
+       ENDDO
+          
+       DO k = 1,nbpools
+          WRITE(part_str,'(I2)') k
+          IF (k < 10) part_str(1:1) = '0' 
+          var_name = 'current_stock_'//part_str(1:LEN_TRIM(part_str))
+          CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+               &                current_stock(:,:,k), 'scatter', nbp_glo, index_g)
+       ENDDO
+       
+    ENDIF !(spinup_analytic)
+
+    !-
+    ! 20. Forest management
+    !-
+    IF ( control%forest_management .OR. control%ok_functional_allocation) THEN
+
+!!$       var_name = 'lai_max_calc'
+!!$       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+!!$            &              lai_max_calc, '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_lyear_'//part_str(1:LEN_TRIM(part_str))
+!!$          CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+!!$               &                biomass_lastyear(:,:,k,icarbon), 'scatter', nbp_glo, index_g)
+!!$       ENDDO
+!!$
+!!$       var_name = 'lai_max_lyear'
+!!$       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+!!$            &              lai_max_lastyear, 'scatter', nbp_glo, index_g)
+
+       var_name = 'mai'
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &              mai, 'scatter', nbp_glo, index_g)
+
+       var_name = 'pai'
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &              pai, 'scatter', nbp_glo, index_g)
+
+       var_name = 'coppice_dens'
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &              coppice_dens, 'scatter', nbp_glo, index_g)
+
+       var_name = 'previous_wood_volume'
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &              previous_wood_volume, 'scatter', nbp_glo, index_g)
+
+       var_name = 'age_stand'
+       temp_real = REAL(age_stand,r_std)
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &              temp_real, 'scatter', nbp_glo, index_g)
+
+       var_name = 'rotation_n'
+       temp_real = REAL(rotation_n,r_std)  
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &              temp_real, 'scatter', nbp_glo, index_g)
+
+       var_name = 'last_cut'
+       temp_real = REAL(last_cut,r_std)
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &              temp_real, 'scatter', nbp_glo, index_g)
+
+       var_name = 'fm_lyear'
+       temp_real = REAL(forest_managed_lastyear,r_std)
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &              temp_real, 'scatter', nbp_glo, index_g)
+
+       var_name = 'mai_count'
+       temp_real = REAL(mai_count,r_std)
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &              temp_real, 'scatter', nbp_glo, index_g)
+
+    END IF ! control%forest_management
+
+    IF (bavard >= 4) WRITE(numout,*) 'Leaving writerestart'
+
+  END SUBROUTINE writerestart
+
+!! ================================================================================================================================
+!! SUBROUTINE   : readbc
+!!
+!>\BRIEF         
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S):
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE readbc (npts, lalo, neighbours, resolution, contfrac, tref)
+
+    IMPLICIT NONE
+
+    !! 0. Parameters and variables declaration
+    
+    !! 0.1 Input variables  
+    
+    INTEGER(i_std), INTENT(in)                  :: npts        !! Domain size
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)  :: lalo        !! Geogr. coordinates (latitude,longitude) (degrees)
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)  :: resolution  !! size in x an y of the grid (m)
+    INTEGER(i_std),DIMENSION (npts,8), INTENT(in):: neighbours !! Neighbouring land grid cell
+    REAL(r_std),DIMENSION (npts), INTENT(in)     :: contfrac   !! Fraction of land in each grid box 
+
+
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION(npts), INTENT(inout) :: tref        !! "long term" reference 2 meter temperatures (K)
+
+!_ ================================================================================================================================
+
+    !! 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, neighbours, resolution, contfrac, 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, neighbours, resolution, contfrac, 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  !! Vector of latitude and longitudes (degrees)
+    INTEGER(i_std), DIMENSION (npts,8), INTENT(in) :: neighbours  !! Vector of neighbours for each grid point 
+    REAL(r_std), DIMENSION (npts), INTENT(in)      :: contfrac    !! Fraction of land in each grid cell (unitless)   
+
+    !-
+    ! 0.2 output
+    !-
+    ! reference temperature (K)
+    REAL(r_std), DIMENSION(npts),INTENT(out)       :: tref_out    !! interpolated reference temperature
+    !-
+    ! 0.3 local
+    !-
+    INTEGER(i_std)                                 :: nbvmax      !! nbvmax for interpolation (unitless). It is the 
+    CHARACTER(LEN=80)                              :: filename    !! filename of temperature file
+    INTEGER(i_std)                                :: iml, jml, lml, &
+              & tml, fid, ib, ip, jp, fopt, ilf, lastjp, nbexp,ic      !! Indices
+    REAL(r_std)                                   :: lev(1), date, dt      !! Help variables to read in file data
+    INTEGER(i_std)                                :: itau(1)               !! Help variables to read in file data
+    REAL(r_std)                                   :: sgn                   !! Help variable to normalise temp.
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lat_rel               !! Help variable to read file data and allocate memory
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lon_rel               !! Help variable to read file data and allocate memory
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: tref_file             !! Help variable to read file data and allocate memory
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: sub_area              !! Help variable to read file data and allocate memory
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: sub_index             !! Help variable to read file data and allocate memory
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: mask                  !! Help variable to read file data and allocate memory
+    CHARACTER(LEN=30)                             :: callsign              !! Help variable to read file data and allocate memory
+    LOGICAL                                       :: ok_interpol = .FALSE. !! Optional return of aggregate_2d
+    INTEGER                                       :: ALLOC_ERR             !! Help varialbe to count allocation error
+!_ ================================================================================================================================
+    !-
+    ! 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 memory for temperature
+         ALLOC_ERR=-1
+         ALLOCATE(trefe(npts), STAT=ALLOC_ERR)
+         IF (ALLOC_ERR/=0) THEN
+            WRITE(numout,*) "ERROR IN ALLOCATION of trefe : ",ALLOC_ERR
+            CALL ipslerr_p (3,'stomate_io', 'get_reftemp','','') 
+         ENDIF
+         !-
+        trefe(:) = zero
+
+        !-
+        tref_out(:) = zero
+ 
+
+       ! - 
+       !---
+       !-- 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 temperature is read
+       !Config If    = OK_STOMATE
+       !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)
+       !Config Units = [FILE]
+       !---
+       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 memory for latitudes
+       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
+          CALL ipslerr_p (3,'stomate_io', 'get_reftemp','','')
+       ENDIF
+       !-
+       lat_rel(:,:) = zero
+       !-
+       ! Allocate memory for longitude
+       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
+          CALL ipslerr_p (3,'stomate_io', 'get_reftemp','','')
+       ENDIF
+       !-
+       lon_rel(:,:) = zero
+       !-
+       ! Allocate memory for mask
+       ALLOC_ERR=-1
+       ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
+       IF (ALLOC_ERR/=0) THEN
+          WRITE(numout,*) "ERROR IN ALLOCATION of mask : ",ALLOC_ERR
+          CALL ipslerr_p (3,'stomate_io', 'get_reftemp','','')
+       ENDIF
+       !-
+       mask(:,:) = zero
+       !-
+       ! Allocate memory for temperature data
+       ALLOC_ERR=-1
+       ALLOCATE(tref_file(iml,jml), STAT=ALLOC_ERR)
+       IF (ALLOC_ERR/=0) THEN
+          WRITE(numout,*) "ERROR IN ALLOCATION of tref_file : ",ALLOC_ERR
+          CALL ipslerr_p (3,'stomate_io', 'get_reftemp','','')
+       ENDIF
+       !-
+       tref_file(:,:) = zero
+       !-
+       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, 'temperature', iml, jml, lml, tml, &
+            &                                  1, 1, tref_file)
+       CALL bcast(tref_file)
+       !-
+       IF (is_root_prc) CALL flinclo (fid)
+       !-
+       ! Create mask with values of temperature
+       mask(:,:) = zero
+       DO ip=1,iml
+          DO jp=1,jml
+             IF (tref_file(ip,jp) > min_sechiba) THEN
+                mask(ip,jp) = un
+             ENDIF
+          ENDDO
+       ENDDO
+       !---
+       ! Set nbvmax to 200 for interpolation
+       ! This number is the dimension of the variables in which we store 
+       ! the list of points of the source grid which fit into one grid box of the target. 
+       nbvmax = 200
+       !---
+       callsign = 'Reference temperature'
+       !---
+       ! Start with interpolation
+       DO WHILE ( .NOT. ok_interpol )
+          WRITE(numout,*) "Projection arrays for ",callsign," : "
+          WRITE(numout,*) "nbvmax = ",nbvmax
+          !---
+          ALLOC_ERR=-1
+          ALLOCATE(sub_area(npts,nbvmax), STAT=ALLOC_ERR)
+          IF (ALLOC_ERR/=0) THEN
+             WRITE(numout,*) "ERROR IN ALLOCATION of sub_area : ",ALLOC_ERR
+             CALL ipslerr_p (3,'stomate_io', 'get_reftemp','','')
+          ENDIF
+          sub_area(:,:)=zero
+          ALLOC_ERR=-1
+          ALLOCATE(sub_index(npts,nbvmax,2), STAT=ALLOC_ERR)
+          IF (ALLOC_ERR/=0) THEN
+             WRITE(numout,*) "ERROR IN ALLOCATION of sub_index : ",ALLOC_ERR
+             CALL ipslerr_p (3,'stomate_io', 'get_reftemp','','') 
+          ENDIF
+          sub_index(:,:,:)=0
+          !-
+          WRITE(numout,*) "Start interpolation in STOMATE_IO: get_reftemp"
+          !-
+          CALL aggregate_p(npts, 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
+       !-
+       ! Check how many points are found
+       !-
+       nbexp = zero
+       trefe(:) = zero
+       !-       
+       DO ib=1,npts ! Loop over domain size
+          !-
+          fopt =  COUNT(sub_area(ib,:) > zero)
+          !-
+          !! Compute the temperature parameters
+          !-
+          IF ( fopt .GT. 0) THEN      ! If no points were interpolated
+             !-
+             sgn = zero
+             !-
+             DO ilf = 1,fopt         ! If points were interpolated
+                !- 
+                ip = sub_index(ib,ilf,1)
+                jp = sub_index(ib,ilf,2)
+                !-
+                ! Weighted values by interpolation area
+                trefe(ib) = trefe(ib) + tref_file(ip,jp) * sub_area(ib,ilf)
+                sgn = sgn + sub_area(ib,ilf)
+                !-
+             ENDDO
+             !-
+             ! Normalize the surface
+             IF ( sgn .LT. min_sechiba) THEN
+                nbexp = nbexp + 1
+             ELSE
+                trefe(ib) = trefe(ib)/sgn         
+             ENDIF
+             !-
+          ELSE
+             !-
+             nbexp = nbexp + 1
+             !-
+             !
+!jot ++++++++++++++TEMP
+!    Here we set all pixels that didn't have enough surrounding pixels
+!    for the interpolation to the mean average 2m temperature. This
+!    is not ideal. 
+!    The ideal case: here the pixels get the value 'undef' and in 
+!    a next step these pixels get the value from a surrounding pixel
+!    that has an interpolated value.
+!    We tried this, see the following loop. We used the 'neighbours'
+!    variable calculated in grid.f90 to check if one of the eight 
+!    surrounding pixels has a temperature value. 
+!    However, this doesn't work. The dimensions of refe(neighbours(ib,ic)
+!    aren't correct. Maybe something goes wrong with the 
+!    parallelisation? Needs to be checked.
+!jot ++++++++++++++TEMP  
+             ! 
+             trefe(ib) = mstemp
+!jot             trefe(ib) = undef
+             !- 
+          ENDIF
+          !-
+       ENDDO
+       !- 
+       !
+       IF ( nbexp .GT. 0 ) THEN
+          WRITE(numout,*) 'STOMATE_IO, get_reftemp : The interpolation of the temperature had ', nbexp
+          WRITE(numout,*) 'STOMATE_IO, get_reftemp : points without data out of total', SIZE(trefe)
+          WRITE(numout,*) 'STOMATE_IO, get_reftemp : interpolation points.' 
+          WRITE(numout,*) 'STOMATE_IO, get_reftemp : We will start now with replacing the pixel'
+          WRITE(numout,*) 'STOMATE_IO, get_reftemp : by the value of the nearest neighbour'
+       ENDIF
+       !- 
+       ! look for values that have the value undef to replace them by the value 
+       ! of the nearest neighbour
+       ! -
+       DO ib=1,npts ! Loop over domain size
+          !-
+          ! check if this point is one without a temperature value
+          !-
+          IF (trefe(ib) .EQ. undef) THEN
+              !-
+              ! in the module grid.f90 the variable neighbours is calculated
+              ! it tests the 8 neighbour pixels, a value of -1 means that this
+              ! is not a land point or outside of the domain, here we loop over
+              ! these eight pixels to see if we find a pixel with a temperature
+              ! value 
+              !- 
+              DO ic=1,8 ! number of neighbour pixels
+                 !-
+                 ! check if there is a neighbour land pixel
+                 !-
+                 IF (neighbours(ib,ic) .GT. 0 ) THEN
+                    !-
+                    ! now we have neighbouring land pixel but 
+                    ! check if his pixel contains a temperature
+                    ! value and that this not an 'artifial' value
+                    !-     
+                    IF (trefe(neighbours(ib,ic)) .NE. undef .AND. &
+                        trefe(neighbours(ib,ic)) .NE. mstemp ) THEN
+                        !-
+                        ! set the temperature value
+                        !- 
+                        trefe(ib) =  trefe(neighbours(ib,ic))
+                        !-
+                        ! cool - we replaced the pixel having no 
+                        ! temperature value with the temperature value
+                        ! of a neighbouring land pixel, continue checking
+                        ! the following pixels
+                        !-
+                        EXIT
+                        !-
+                    ENDIF 
+                    !-
+                    ! when we tested the last neighbouring pixel and
+                    ! still haven't found a pixel with a temperatue value
+                    ! then replace it with the global annual mean surface
+                    ! temperature value
+                    !-                
+                 ELSEIF (ic .EQ. 8) THEN ! if all neighbours are checked
+                    !- 
+                    trefe(ib) = mstemp
+                    !-
+                 ENDIF
+                 !-
+                 ! 
+             ENDDO ! neighbouring pixels  
+             !-
+          ENDIF
+          !-
+          !
+       ENDDO !domain size
+       !-
+       ! transform into Kelvin
+       !-
+       trefe(:) = trefe(:) + ZeroCelsius
+       !-
+       ! deallocate
+       !-                       
+       DEALLOCATE (lat_rel)
+       DEALLOCATE (lon_rel)
+       !  
+    ENDIF
+    !-
+    ! output the reference temperaturei
+    !-
+    tref_out(:) = trefe(:)
+    !-
+    WRITE(numout,*) 'STOMATE_IO, get_reftemp : Done'
+    !-
+    !
+  END SUBROUTINE get_reftemp
+  !      
+  !-
+END MODULE stomate_io
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_kill.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_kill.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_kill.f90	(revision 7236)
@@ -0,0 +1,1412 @@
+! =================================================================================================================================
+! MODULE       : stomate_kill
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Simulate mortality of individuals and update biomass, litter and 
+!! stand density of the PFT
+!!
+!!\n DESCRIPTION : Simulate mortality of individuals and update biomass, litter and 
+!! stand density of the PFT. This module replaces lpj_gap/kill.  Biomass actually
+!! dies here and is moved to the litter pools.  This does not work with the DGVM
+!! at the moment.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S) : 
+!! - Sitch, S., B. Smith, et al. (2003), Evaluation of ecosystem dynamics,
+!!         plant geography and terrestrial carbon cycling in the LPJ dynamic 
+!!         global vegetation model, Global Change Biology, 9, 161-185.\n
+!! - Waring, R. H. (1983). "Estimating forest growth and efficiency in relation 
+!!         to canopy leaf area." Advances in Ecological Research 13: 327-354.\n
+!! 
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_stomate/stomate_kill.f90 $
+!! $Date: 2013-09-27 09:59:24 +0200 (Fri, 27 Sep 2013) $
+!! $Revision: 1485 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE stomate_kill
+
+  ! modules used:
+
+  USE stomate_data
+  USE pft_parameters
+  USE ioipsl_para 
+  USE function_library,       ONLY : distribute_mortality_biomass,&
+                                     nmax,  wood_to_dia
+  USE constantes
+  USE stomate_prescribe
+  USE sapiens_lcchange,       ONLY : merge_biomass_pfts
+  USE stomate_prescribe
+!  USE lpj_kill 
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC gap_prognostic, gap_clear, gap_clean
+  
+  ! Variable declaration 
+
+  LOGICAL, SAVE             :: firstcall = .TRUE.                !! first call flag
+!$OMP THREADPRIVATE(firstcall)
+
+CONTAINS
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : gap_clear
+!!
+!>\BRIEF        Set the firstcall flag back to .TRUE. to prepare for the next simulation.
+!_ ================================================================================================================================
+  
+  SUBROUTINE gap_clear
+     firstcall = .TRUE.
+  END SUBROUTINE gap_clear
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : gap_prognostic
+!!
+!>\BRIEF        Transfer dead biomass to litter and update stand density for trees
+!!              which die of natural causes.
+!!
+!! DESCRIPTION  : This routine has a simple purpose: kill individuals by natural causes.  
+!!   The variable circ_class_kill indicates how many individuals need to be killed by the various
+!!   processes in the code, and is calculated in other modules.  gap_prognostic takes
+!!   this variable and decides on the correct order of which to actually kill the
+!!   trees, making sure that we don't double count.  
+!!
+!! RECENT CHANGE(S): 
+!!
+!! MAIN OUTPUT VARIABLE(S): ::circ_class_biomass; biomass, ::ind density of individuals, 
+!! ::mortality mortality (fraction of 
+!! trees that is dying per time step)
+!!
+!! REFERENCE(S)   :
+!! - Sitch, S., B. Smith, et al. (2003), Evaluation of ecosystem dynamics,
+!!         plant geography and terrestrial carbon cycling in the LPJ dynamic 
+!!         global vegetation model, Global Change Biology, 9, 161-185.
+!! - Waring, R. H. (1983). "Estimating forest growth and efficiency in relation 
+!!         to canopy leaf area." Advances in Ecological Research 13: 327-354.
+!!
+!! FLOWCHART    : None
+!!\n
+!_ ================================================================================================================================
+ 
+  SUBROUTINE gap_prognostic (npts, biomass, ind,  bm_to_litter, &
+       circ_class_biomass, circ_class_kill, circ_class_n, &
+       veget_max, circ_class_cwd, circ_class_leafcwd)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables 
+    INTEGER(i_std), INTENT(in)                                   :: npts               !! Domain size (-)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)                   :: veget_max          !! Maximum fraction of vegetation type 
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables   
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                             INTENT(inout)       :: biomass            !! Biomass @tex $(gC m^{-2}) $@endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)              :: ind                !! Stand level number of individuals 
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements), &                         
+                                              INTENT(inout)      :: circ_class_biomass !! Biomass of the components of the model  
+                                                                                       !! tree within a circumference
+                                                                                       !! class @tex $(gC ind^{-1})$ @endtex  
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(inout)        :: circ_class_n       !! Number of individuals in each circ class
+                                                                                       !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nfm_types,ncut_times),&
+                                                  INTENT(inout)  :: circ_class_kill    !! Number of trees within a circ that needs
+   REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(inout)        :: circ_class_cwd                    
+                                                                 !! to be killed @tex $(ind m^{-2})$ @endtex
+        REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(inout)        :: circ_class_leafcwd    
+REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                                  INTENT(inout)  :: bm_to_litter       !! Biomass transfer to litter 
+                                                                                       !! @tex $(gC m^{-2})$ @endtex
+
+    !! 0.4 Local variables
+    INTEGER(i_std)                                               :: ipts, ivm, ipar    !! Indices
+    INTEGER(i_std)                                               :: iele, icir, imbc   !! Indices
+    INTEGER(i_std)                                               :: ifm,icut           !! Indices
+    INTEGER,DIMENSION(nvm)                                       :: nkilled            !! the number of grid points at which a given
+                                                                                       !! given PFT's biomass has been reduced to zero
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements)           :: check_intern       !! Contains the components of the internal
+                                                                                       !! mass balance chech for this routine
+                                                                                       !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)                   :: closure_intern     !! Check closure of internal mass balance
+                                                                                       !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)                   :: pool_start         !! Start pool of this routine 
+                                                                                       !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)                   :: pool_end           !! End pool of this routine 
+                                                                                       !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+
+!_ ================================================================================================================================
+
+    !! 1. Set firstcall flag
+
+    IF ( firstcall ) THEN
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering gap. Use constant mortality = ', &
+         control%ok_constant_mortality
+
+    !! 2. Initialize variables
+    nkilled(:)=0
+    
+    ! 2.1 Initialize check for mass balance closure
+    !  The mass balance is calculated at the end of this routine
+    !  in section .
+    pool_start = zero
+    DO ipar = 1,nparts
+       DO iele = 1,nelements
+          !  Initial litter and biomass
+          pool_start(:,:,iele) = pool_start(:,:,iele) + &
+               (biomass(:,:,ipar,iele) * veget_max(:,:)) + &
+               (bm_to_litter(:,:,ipar,iele) * veget_max(:,:))
+       ENDDO
+    ENDDO
+
+
+ !! 3. Kill plants
+    DO  ipts = 1,npts ! loop over land_points
+
+       DO ivm = 2,nvm  ! loop over #PFT
+
+
+          IF(veget_max(ipts,ivm) == zero)THEN
+              ! this vegetation type is not present, so no reason to do the 
+              ! calculation
+               CYCLE
+          ENDIF
+
+
+          !! First, all the plants that are supposed to be killed by fire are killed.
+          !! We do not yet know how to handle this, so this will have to be taken
+          !! into account when SPITFIRE is coupled.
+
+          DO iele = 1,nelements
+
+             !! All of the natural death is grouped 
+             !! together in one pool since all of the biomass will be left on 
+             !! site (moved to the litter pools).
+
+             ! Killing is done a little differently for trees and non-trees, since
+             ! circ_classes are not defined for non-trees.
+
+             DO ifm=1,nfm_types
+                DO icut=1,ncut_times
+
+                   ! Since we gave circ_class_kill the same dimensions as the
+                   ! harvest pool, we need to explicitly say which combinations
+                   ! of ifm and icut are killed in which ways.  Currently, I am
+                   ! putting all natural death into ifm_none, even if it happens
+                   ! in another management type (for example, self-thinning will 
+                   ! happen with ifm_thin, but it's really a natural death).
+                   IF(ifm .NE. ifm_none)CYCLE
+                   IF((icut .NE. icut_thin) .AND. (icut .NE. icut_clear))CYCLE
+
+                   IF(is_tree(ivm))THEN
+
+                      DO icir=1,ncirc
+
+                         IF(test_pft == ivm .AND. test_grid == ipts .AND. ld_kill)&
+                              WRITE(numout,*) 'killing before: ',ipts,ivm,icir,ifm,icut,&
+                              circ_class_kill(ipts,ivm,icir,ifm,icut),circ_class_n(ipts,ivm,icir)
+
+                         ! move the dead biomass to the respective litter pool
+
+                         bm_to_litter(ipts,ivm,:,iele) = bm_to_litter(ipts,ivm,:,iele) + &
+                              circ_class_biomass(ipts,ivm,icir,:,iele)*&
+                              circ_class_kill(ipts,ivm,icir,ifm,icut)
+                         ! litter in each circ
+                        circ_class_cwd(ipts,ivm,icir)=(circ_class_biomass(ipts,ivm,icir,1,iele)+circ_class_biomass(ipts,ivm,icir,2,iele)+circ_class_biomass(ipts,ivm,icir,4,iele)+circ_class_biomass(ipts,ivm,icir,7,iele))*circ_class_kill(ipts,ivm,icir,ifm,icut)
+                        circ_class_leafcwd(ipts,ivm,icir)=circ_class_biomass(ipts,ivm,icir,1,iele)*circ_class_kill(ipts,ivm,icir,ifm,icut)
+                         ! remove the number of individuals that died
+                         circ_class_n(ipts,ivm,icir) = circ_class_n(ipts,ivm,icir) - &
+                              circ_class_kill(ipts,ivm,icir,ifm,icut)
+
+
+                         ! remove the dead biomass
+                         biomass(ipts,ivm,:,iele) = biomass(ipts,ivm,:,iele) - &
+                              circ_class_biomass(ipts,ivm,icir,:,iele)*&
+                              circ_class_kill(ipts,ivm,icir,ifm,icut)
+
+                         ! adjust the number of individuals
+                         ind(ipts,ivm)=ind(ipts,ivm)-&
+                              circ_class_kill(ipts,ivm,icir,ifm,icut)
+
+                         ! Here, it's possible that the number of individuals left
+                         ! will be a very, very small amount.  If it's very low,
+                         ! we will just move all that biomass to the dead pool
+                         ! and set the number of individuals equal to zero,
+                         ! effectively killing the circ class.
+                         IF(circ_class_n(ipts,ivm,icir) .LE. min_stomate)THEN
+
+                            bm_to_litter(ipts,ivm,:,iele) = bm_to_litter(ipts,ivm,:,iele) + &
+                                 circ_class_biomass(ipts,ivm,icir,:,iele)*&
+                                 circ_class_n(ipts,ivm,icir)
+                            biomass(ipts,ivm,:,iele) = biomass(ipts,ivm,:,iele) - &
+                                 circ_class_biomass(ipts,ivm,icir,:,iele)*&
+                                 circ_class_n(ipts,ivm,icir)
+                            ind(ipts,ivm)=ind(ipts,ivm)-&
+                                 circ_class_n(ipts,ivm,icir)
+
+                            ! zero the number of individuals in this circ class
+                            circ_class_n(ipts,ivm,icir) = circ_class_n(ipts,ivm,icir) - &
+                                 circ_class_n(ipts,ivm,icir)
+                            ! 20210503yyt
+                       circ_class_cwd(ipts,ivm,icir)=(circ_class_biomass(ipts,ivm,icir,1,iele)+circ_class_biomass(ipts,ivm,icir,2,iele)+circ_class_biomass(ipts,ivm,icir,4,iele)+circ_class_biomass(ipts,ivm,icir,7,iele))*circ_class_n(ipts,ivm,icir)
+                        circ_class_leafcwd(ipts,ivm,icir)=circ_class_biomass(ipts,ivm,icir,1,iele)*circ_class_n(ipts,ivm,icir)       
+                 write(numout,*) 'circ_class_cwd ', icir, circ_class_cwd(ipts,ivm,icir) 
+                        !write(*,*) 'circ_class_cwd ', icir, circ_class_cwd(ipts,ivm,icir)
+                          ENDIF
+
+!!$                         IF(test_pft == ivm .AND. test_grid == ipts)&
+!!$                              WRITE(numout,*) 'killing after: ',ipts,ivm,icir,ifm,icut,&
+!!$                              circ_class_kill(ipts,ivm,icir,ifm,icut),circ_class_n(ipts,ivm,icir)
+                     ENDDO ! loop over circ classes
+
+ 
+                   ELSE
+
+                      !! WARNING !!
+                      ! This is not very clean.  We don't use circ classes for grasses 
+                      ! and crops.  All mortality is done based on biomass.  However, 
+                      ! it's cleaner here to just pass circ_class_kill from lpj_kill, 
+                      ! and it is in line with what is done for the forests.  So we take
+                      ! the total grass/crop biomass that is scheduled for killing in 
+                      ! lpj_kill and define circ_class_kill(:,:,inatural,1) and 
+                      ! circ_class_biomass(:,:,1,:,:) so that the product of these two
+                      ! matches the amount of biomass scheduled for killing.  We do NOT
+                      ! change the number of individuals after killing, either.
+
+                      ! Let us compute the fraction of plants which die of natural
+                      ! causes in this step.
+                      ! Individuals are not killed for grasses and crops, so we cannot
+                      ! calculate the mortality as a function of the individuals
+
+                      ! We renormalize by circ_class_n below.  If it's zero,
+                      ! we have an error.  Of course, if it's zero there is no
+                      ! reason to be here in the first place.
+                      IF(circ_class_n(ipts,ivm,1) .LE. min_stomate)CYCLE
+
+                      ! move the dead biomass to the respective litter pool
+                      bm_to_litter(ipts,ivm,:,iele) = bm_to_litter(ipts,ivm,:,iele) + &
+                           circ_class_biomass(ipts,ivm,1,:,iele)*&
+                           circ_class_kill(ipts,ivm,1,ifm,icut)
+
+                      ! remove the dead biomass
+                      biomass(ipts,ivm,:,iele) = biomass(ipts,ivm,:,iele) - &
+                           circ_class_biomass(ipts,ivm,1,:,iele)*&
+                           circ_class_kill(ipts,ivm,1,ifm,icut)
+                      
+                      ! circ_class_biomass has to change such that the biomass
+                      ! and circ_class_biomass*circ_class_n are in sync.  So we
+                      ! will just sync it here.  This has to be done this way
+                      ! since circ_class_n never changes for grass/crops.  
+                      circ_class_biomass(ipts,ivm,1,:,iele) = biomass(ipts,ivm,:,iele)/&
+                           circ_class_n(ipts,ivm,1)
+
+                      ! In order for something to be prescribed, ind must be zero.
+                      ! We don't change ind and circ_class_n if we just kill some
+                      ! of the biomass, but if we kill all of it we must set
+                      ! it to zero in order for it to be prescribed.
+                      ! IF(ivm == test_pft) WRITE(numout,*) 'Killing? ',SUM(biomass(ipts,ivm,:,iele))
+                      IF(SUM(biomass(ipts,ivm,:,iele)) .LE. min_stomate)THEN
+                         circ_class_n(ipts,ivm,:)=zero
+                         ind(ipts,ivm)=zero
+                      ENDIF
+                      
+
+                   ENDIF ! checking for a tree
+
+                   ! This stuff should never been killed again.  
+                   ! To make sure of that, reset all the
+                   ! variables to zero.
+                   ! added by Yitong Yao commented the below line in Jan 05 2020 20:17
+                   !circ_class_kill(ipts,ivm,:,ifm,icut)=zero ! to make this var do not equal to 0
+                ENDDO
+             ENDDO
+
+          ENDDO ! loop over elements
+
+       ENDDO  ! loop over pfts
+
+    END DO ! loop over land points
+
+ !! 4. Check mass balance closure
+   
+    !  Consider this whole routine as a black box with incoming and outgoing 
+    !  fluxes and a change in the mass of the box. Express in absolute 
+    !  units gC (or gN), hence, multiply with dt and veget_max. In most routines 
+    !  veget_max does not change and could be omitted but a general approach 
+    !  was prefered.
+
+    !! 4.1 Calculate pools at the end of the routine
+    pool_end = zero
+    DO ipar = 1,nparts
+       DO iele = 1,nelements
+          pool_end(:,:,iele) = pool_end(:,:,iele) + &
+               (biomass(:,:,ipar,iele) * veget_max(:,:)) + &
+               (bm_to_litter(:,:,ipar,iele) * veget_max(:,:))
+       ENDDO
+    ENDDO
+
+    !! 4.2 Calculate components of the mass balance
+    check_intern(:,:,iatm2land,icarbon) = zero
+    check_intern(:,:,iland2atm,icarbon) = -un * zero
+    check_intern(:,:,ilat2out,icarbon) = zero
+    check_intern(:,:,ilat2in,icarbon) = -un * zero
+    check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - pool_start(:,:,icarbon))
+    closure_intern = zero
+    DO imbc = 1,nmbcomp
+       closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + check_intern(:,:,imbc,icarbon)
+    ENDDO
+ 
+    ! Write outcome
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          IF(ABS(closure_intern(ipts,ivm,icarbon)) .LE. min_stomate)THEN
+             IF (ld_massbal) WRITE(numout,*) 'Mass balance closure in stomate_kill.f90'
+          ELSE
+             WRITE(numout,*) 'Error: mass balance is not closed in stomate_kill.f90'
+             WRITE(numout,*) '   ipts,ivm; ', ipts,ivm
+             WRITE(numout,*) '   Difference is, ', closure_intern(ipts,ivm,icarbon)
+             WRITE(numout,*) '   pool_end,pool_start: ', pool_end(ipts,ivm,icarbon), pool_start(ipts,ivm,icarbon)
+             IF(ld_stop)THEN
+                CALL ipslerr_p (3,'gap_prognostic', 'Mass balance error.','','')
+             ENDIF
+          ENDIF
+       ENDDO
+    ENDDO
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving gap_prognostic'
+
+  END SUBROUTINE gap_prognostic
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : gap_clean
+!!
+!>\BRIEF        After biomass has been killed, there are some clean-up operations
+!!              to do.
+!!
+!! DESCRIPTION  : If all the biomass has been killed for a PFT, we want to reset
+!!                some counters.  There is also the chance that we will have
+!!                killed all the biomass in a circ class of trees.  If this is
+!!                the case, we want to redistribute the biomass in the remaining
+!!                classes so that all circ classes have some biomass in them.
+!!                A circ class with no biomass causes allocation to crash.
+!!
+!! RECENT CHANGE(S): 
+!!
+!! MAIN OUTPUT VARIABLE(S): ::circ_class_biomass
+!!
+!! REFERENCE(S)   :
+!! - Sitch, S., B. Smith, et al. (2003), Evaluation of ecosystem dynamics,
+!!         plant geography and terrestrial carbon cycling in the LPJ dynamic 
+!!         global vegetation model, Global Change Biology, 9, 161-185.
+!! - Waring, R. H. (1983). "Estimating forest growth and efficiency in relation 
+!!         to canopy leaf area." Advances in Ecological Research 13: 327-354.
+!!
+!! FLOWCHART    : None
+!!\n
+!_ ================================================================================================================================
+ 
+  SUBROUTINE gap_clean (npts, biomass, circ_class_biomass, &
+       circ_class_n, age, everywhere, leaf_age, &
+       leaf_frac, senescence, when_growthinit, circ_class_dist, &
+       age_stand, PFTpresent, last_cut, mai_count, &
+       veget_max, npp_longterm, KF, co2_to_bm, ind, &
+       wstress_season, lm_lastyearmax, lignin_struc, lignin_wood, &
+       carbon, litter,  vir_wstress_fac, veget, dt_days, &
+       forest_managed, bm_to_litter, lab_fac, gdd_from_growthinit,&
+       gdd_midwinter, time_hum_min, gdd_m5_dormance, ncd_dormance,&
+       moiavail_month, moiavail_week, gpp_week, gpp_daily, resp_maint,&
+       resp_growth, npp_daily, use_reserve, mai, pai, ngd_minus5,&
+       rue_longterm, previous_wood_volume,&
+!!$       t_photo_stress, rue_longterm, previous_wood_volume,&
+       tau_eff_leaf, tau_eff_sap, tau_eff_root, moiavail_growingseason,&
+       orphan_flux, k_latosa_adapt)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables 
+    INTEGER(i_std), INTENT(in)                       :: npts                   !! Domain size (-)
+    REAL(r_std), DIMENSION(ncirc), INTENT(in)        :: circ_class_dist        !! The probability distribution of trees 
+                                                                               !! in a circ class in case of a 
+                                                                               !! redistribution (unitless).
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: vir_wstress_fac        !! Water stress factor, based on hum_rel_daily
+                                                                               !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: veget                  !! Fraction of vegetation type including 
+                                                                               !! non-biological fraction (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: tau_eff_root           !! Effective root turnover time that accounts
+                                                                               !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: tau_eff_sap            !! Effective sapwood turnover time that accounts
+                                                                               !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: tau_eff_leaf           !! Effective leaf turnover time that accounts
+                                                                               !! waterstress (days)  
+    REAL(r_std), INTENT(in)                          :: dt_days                !! Time step of vegetation dynamics for stomate (days)
+    INTEGER(i_std), DIMENSION (:,:), INTENT(in)      :: forest_managed         !! forest management flag
+    
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables   
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: biomass                !! Biomass @tex $(gC m^{-2}) $@endtex
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: circ_class_biomass     !! Biomass of the components of the model  
+                                                                               !! tree within a circumference
+                                                                               !! class @tex $(gC ind^{-1})$ @endtex  
+    LOGICAL, DIMENSION(:,:), INTENT(inout)           :: senescence             !! Is the plant senescent? (only for deciduous 
+                                                                               !! trees - carbohydrate reserve) (true/false)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: age                    !! Mean age (years)  
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: when_growthinit        !! How many days ago was the beginning of the 
+                                                                               !! growing season (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: everywhere             !! Is the PFT everywhere in the grid box or very
+                                                                               !! localized (after its introduction)
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: leaf_age               !! Leaf age (days)
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: leaf_frac              !! Fraction of leaves in leaf age class 
+                                                                               !! (unitless;0-1)
+    INTEGER(i_std), DIMENSION(:,:), INTENT(inout)    :: age_stand              !! Age of the forest stand (years)  
+    INTEGER(i_std), DIMENSION(:,:), INTENT(inout)    :: last_cut               !! Years since last thinning (years)
+    INTEGER(i_std), DIMENSION(:,:), INTENT(inout)    :: mai_count              !! The number of times we've
+                                                                               !! calculated the volume increment
+                                                                               !! for a stand
+    LOGICAL, DIMENSION(:,:), INTENT(inout)           :: PFTpresent             !! PFT present (0 or 1)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: KF                     !! Scaling factor to convert sapwood mass into leaf 
+                                                                               !! mass (m)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: k_latosa_adapt         !! Leaf to sapwood area adapted for long 
+                                                                               !! term water stress (m)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: veget_max              !! "maximal" coverage fraction of a PFT on the ground
+                                                                               !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: co2_to_bm              !! CO2 taken from the atmosphere to get C to create  
+                                                                               !! the seedlings @tex (gC.m^{-2}dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: ind                    !! Density of individuals at the stand level 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: wstress_season         !! Water stress factor, based on hum_rel_daily
+                                                                               !! (unitless, 0-1) 
+
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: npp_longterm           !! "long term" net primary productivity
+                                                                               !! @tex ($gC m^{-2} year^{-1}$) @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: lm_lastyearmax         !! last year's maximum leaf mass for each PFT 
+                                                                               !! @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: lignin_struc           !! ratio Lignine/Carbon in structural litter,
+                                                                               !! above and below ground
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: lignin_wood            !! ratio Lignine/Carbon in woody litter,
+                                                                               !! above and below ground
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: carbon                 !! carbon pool: active, slow, or passive 
+                                                                               !! @tex ($gC m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: litter                 !! metabolic and structural litter, above and 
+                                                                               !! below ground @tex ($gC m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: circ_class_n           !! Number of individuals in each circ class
+                                                                               !! @tex $(ind m^{-2})$ @endtex  
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: bm_to_litter           !! Transfer of biomass to litter 
+                                                                               !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: lab_fac                !! Activity of labile pool factor (??units??)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: gdd_from_growthinit    !! growing degree days, since growthinit 
+                                                                               !! for crops
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: gdd_midwinter          !! Growing degree days (K), since midwinter 
+                                                                               !! (for phenology) - this is written to the
+                                                                               !!  history files 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: time_hum_min           !! Time elapsed since strongest moisture 
+                                                                               !! availability (days) 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: gdd_m5_dormance        !! Growing degree days (K), threshold -5 deg 
+                                                                               !! C (for phenology)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: ncd_dormance           !! Number of chilling days (days), since 
+                                                                               !! leaves were lost (for phenology) 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: moiavail_month         !! "Monthly" moisture availability (0 to 1, 
+                                                                               !! unitless) 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: moiavail_week          !! "Weekly" moisture availability 
+                                                                               !! (0 to 1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: gpp_week               !! Mean weekly gross primary productivity 
+                                                                               !! @tex $(gC m^{-2} day^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: gpp_daily              !! Daily gross primary productivity  
+                                                                               !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: resp_maint             !! Maintenance respiration  
+                                                                               !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: resp_growth            !! Growth respiration  
+                                                                               !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: npp_daily              !! Net primary productivity 
+                                                                               !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: use_reserve            !! Mass taken from carbohydrate reserve 
+                                                                               !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)  :: mai                    !! The mean annual increment
+                                                                               !! @tex $(m**3 / m**2 / year)$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)  :: pai                    !! The period annual increment
+                                                                               !! @tex $(m**3 / m**2 / year)$ @endtex          
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: ngd_minus5             !! Number of growing days (days), threshold 
+                                                                               !! -5 deg C (for phenology)   
+!!$    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: t_photo_stress         !! Temperature stress for CEXCHANGE 
+!!$                                                                               !! photosynthesis (0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: rue_longterm           !! Longterm radiation use efficiency 
+                                                                               !! (??units??) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)  :: previous_wood_volume   !! The volume of the tree trunks
+                                                                               !! in a stand for the previous year.
+                                                                               !! @tex $(m**3 / m**2 )$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: moiavail_growingseason !! Mean growingseason moisture 
+                                                                               !! availability (0 to 1, unitless)
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: orphan_flux            !! Storage for fluxes of PFTs that no longer exist. 
+                                                                               !! Following the total destruction of a PFT in LCC 
+                                                                               !! (veget_max_new = 0), a flux from before LCC needs a 
+                                                                               !! storage @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+
+    !! 0.4 Local variables
+    REAL(r_std)                                      :: share_young            !! Share of the veget_max of the youngest age class
+                                                                               !! (unitless, 0-1)
+    INTEGER(i_std)                                   :: ipts,ivm,ilage         !! Indices
+    INTEGER(i_std)                                   :: icir,jcir,ilev         !! Indices
+    INTEGER(i_std)                                   :: ipar,iele,imbc         !! Indices
+    INTEGER(i_std)                                   :: ilit,icarb             !! Indices
+    INTEGER(i_std)                                   :: inc                    !! Indices
+    LOGICAL                                          :: lredistribute          !! Flag if we need to redistribute individuals
+                                                                               !! among the circ classes
+    INTEGER,DIMENSION(nvm)                           :: nkilled                !! the number of grid points at which a given
+                                                                               !! given PFT's biomass has been reduced to 
+                                                                               !! zero
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements)&
+                                                     :: check_intern           !! Contains the components of the internal
+                                                                               !! mass balance chech for this routine
+                                                                               !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)       :: closure_intern         !! Check closure of internal mass balance
+                                                                               !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)       :: pool_start             !! Start pool of this routine 
+                                                                               !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)       :: pool_end               !! End pool of this routine 
+                                                                               !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                    :: old_trees_left
+    REAL(r_std), DIMENSION(ncirc)                    :: circ_class_n_new
+    REAL(r_std), DIMENSION(ncirc,nparts)             :: circ_class_biomass_new
+    REAL(r_std)                                      :: trees_needed
+    LOGICAL                                          :: lyoungest
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements):: new_biomass            !! Temporary variable for biomass 
+                                                                               !! @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nleafages)       :: new_leaf_frac          !! Temporary variable for leaf_frac (unitless;0-1)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: new_ind                !! Temporary variable for ind @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                    :: est_circ_class_n       !! Temporary variable for circ_class_n of the 
+                                                                               !! established vegetation @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                    :: tmp_circ_class_n       !! Temporary variable for circ_class_n of the 
+                                                                               !! established vegetation @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc)           :: new_circ_class_n       !! Temporary variable for circ_class_n of the
+                                                                               !! new vegetation
+                                                                               !! @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(ncirc,nparts,nelements)   :: est_circ_class_biomass !! Temporary variable for circ_class_biomass of the
+                                                                               !! established vegetation @tex $(g C ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc,nparts,nelements)   :: tmp_circ_class_biomass !! Temporary variable for circ_class_biomass of the
+                                                                               !! established vegetation @tex $(g C ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements) &
+                                                     :: new_circ_class_biomass !! Temporary variable for circ_class_biomass of the
+                                                                               !! new vegetation @tex $(g C ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                    :: est_circ_class_dia     !! Variable to store temporary values for 
+                                                                               !! circ_class (m)
+    REAL(r_std), DIMENSION(ncirc)                    :: tmp_circ_class_dia     !! Variable to store temporary values for 
+                                                                               !! circ_class (m)
+    REAL(r_std), DIMENSION(npts,nvm,ncirc)           :: new_circ               !! Temporary variable for circ (m)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: new_co2_to_bm          !! Temporary variable for co2_to_bm 
+                                                                               !! @tex (gC.m^{-2}dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                 :: new_age                !! Temporary variable for age (years)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: new_lm_lastyearmax     !! Temporary variable for lm_last_year 
+                                                                               !! @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                 :: new_everywhere         !! Temporary variable for everywhere (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: dum_when_growthinit    !! Dummy for when_growthinit (days)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: dum_npp_longterm       !! Dummy for npp_long_term
+                                                                               !! @tex ($gC m^{-2} year^{-1}$) @endtex
+    INTEGER(i_std) :: ivma
+    LOGICAL, DIMENSION(npts,nvm)                     :: dum_PFTpresent         !! Dummy for PFTpresent (0 or 1)
+    LOGICAL, DIMENSION(npts,nvm)                     :: dum_senescence         !! Dummy for senescence (true/false)
+    REAL(r_std)                                      :: moi_bank               !! bank to store moiavail_growingseason of the cleared
+                                                                               !! PFT's (unitless; 0-1)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: loss_gain              !! The same as delta_veget but distributed of all
+                                                                               !! age classes and thus taking the age-classes into 
+                                                                               !! account (unitless, 0-1)
+    REAL(r_std)                                      :: total_losses           !! Sum of losses only in delta_veget (unitless, 0-1)
+    REAL(r_std), DIMENSION(nlitt,nlevs,nelements)    :: litter_bank            !! Bank to store the litter that becomes available when
+                                                                               !! part of a PFT is removed @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(ncarb)                    :: soil_bank              !! Bank to store soil carbon that becomes available when
+                                                                               !! part of a PFT is removed  @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(nlevs)                    :: struct_ltr_bank        !! Bank to store the lignin in structural litter that 
+                                                                               !! becomes available when part of a PFT is removed 
+                                                                               !! (0-1,unitless)
+    REAL(r_std),DIMENSION(nlevs)                     :: woody_ltr_bank         !! Bank to store the lignin in woody litter that 
+                                                                               !! becomes available when part of a PFT is removed 
+                                                                               !! (0-1,unitless)
+    REAL(r_std),DIMENSION(nvm,nparts,nelements)      :: fresh_litter           !! Pool of fresh litter that is being released during 
+                                                                               !! LCC @tex ($gC m^{-2}$) @endtex 
+    REAL(r_std),DIMENSION(nparts,nelements)          :: fresh_ltr_bank         !! Bank to store all the fresh litter from site 
+                                                                               !! clearing during LCC. Weighted value of fresh_litter
+                                                                               !! @tex ($gC m^{-2}$) @endtex
+    INTEGER(i_std) :: iyoung
+    REAL(r_std), DIMENSION(npts,nvm,norphans,nelements) &
+                                               :: orphan_flux_local            !! Storage for fluxes of PFTs that no longer exist. 
+                                                                               !! This is only for co2bm at the moment, since that
+                                                                               !! is the only one used in this routine. Following the 
+                                                                               !! total destruction of a PFT by death
+                                                                               !! (veget_max_new = 0), a flux from before death needs  
+                                                                               !! storage @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(nlitt,nlevs)                :: litter_weight_young  !! The fraction of litter on the young
+                                                                               !! PFT.
+                                                                               !! @tex $-$ @endtex
+    REAL(r_std), DIMENSION(nparts)                     :: v1                   !! temporay variable for sorting circ_class_biomass
+    REAL(r_std)                                        :: v2                   !! temporay variables for sorting circ_class_n
+    REAL(r_std)                                        :: sort                 !! flag triggering sorting routine (0 or 1)
+    REAL(r_std), DIMENSION(ncirc)                      :: tree_size            !! temporay variables for checking the biomass
+                                                                               !! for each circ class @tex ($gC tree^{-1}$) @endtex
+    
+!_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering gap_clean.'
+
+ !! 1. Initialize check for mass balance closure
+  
+    !  The mass balance is calculated at the end of this routine
+    !  in section .
+    pool_start = zero
+    DO iele = 1,nelements
+       DO ipar = 1,nparts
+          !  Initial biomass
+          pool_start(:,:,iele) = pool_start(:,:,iele) + &
+               (biomass(:,:,ipar,iele) * veget_max(:,:)) 
+       ENDDO
+
+       ! The litter and soil carbon pools can be moved around
+       ! if age classes are changed.
+       
+       ! Litter pool (gC m-2) *  (m2 m-2) 
+       DO ilit = 1,nlitt
+          DO ilev = 1,nlevs
+             pool_start(:,:,iele) = pool_start(:,:,iele) + &
+                  litter(:,ilit,:,ilev,iele) * veget_max(:,:)
+          ENDDO
+       ENDDO
+
+       ! Soil carbon (gC m-2) *  (m2 m-2)
+       DO icarb = 1,ncarb
+          pool_start(:,:,iele) = pool_start(:,:,iele) + &
+               carbon(:,icarb,:) * veget_max(:,:)
+       ENDDO
+
+    ENDDO
+    ! It is possible that the orphan fluxes are not zero here.  For example,
+    ! if we prescribed biomass at the beginning of this timestep,
+    ! ico2bm will be some value.  We are only interested in what happens in this
+    ! step for the moment, so we use a local variable for this flux.
+    orphan_flux_local(:,:,:,:)=zero
+
+ !! 2. Redistribute biomass
+  
+    DO  ipts = 1,npts ! loop over land_points
+
+       DO ivm = 2,nvm  ! loop over #PFT
+
+
+          IF(veget_max(ipts,ivm) == zero)THEN
+              ! this vegetation type is not present, so no reason to do the 
+              ! calculation
+               CYCLE
+          ENDIF
+
+
+
+          ! First we check to see if one of the circ classes is empty.  We only need
+          ! to do this if there is some biomass, since we don't care if all
+          ! of the circ classes are empty.
+          IF(SUM(biomass(ipts,ivm,:,icarbon)) .GT. min_stomate)THEN
+             IF(is_tree(ivm))THEN
+
+                !+++++ CHECK +++++
+                ! Try redistributing at every timestep
+!!$                lredistribute=.FALSE.
+!!$                DO icir=1,ncirc
+!!$                   IF(SUM(circ_class_biomass(ipts,ivm,icir,:,icarbon))*&
+!!$                        circ_class_n(ipts,ivm,icir) .LT. min_stomate) &
+!!$                        lredistribute=.TRUE.
+!!$                ENDDO
+
+                lredistribute=.TRUE.
+                !+++++++++++++++++
+
+                IF(lredistribute) THEN
+
+                   IF(ld_biomass .AND. ivm==test_pft)THEN
+                      WRITE(numout,*) 'Start of redistributing biomass in gap_clean'
+                      WRITE(numout,*) 'ipts,ivm',ipts,ivm
+                      WRITE(numout,*) 'circ_class_n, ',circ_class_n(ipts,ivm,:)
+                      WRITE(numout,*) 'circ_class_biomass, ', &
+                           SUM(circ_class_biomass(ipts,ivm,:,:,icarbon),2)
+                   ENDIF
+
+                   ! What we want to do is recreate the circumference class distribution,
+                   ! since if we have hit this point we have at least one class that
+                   ! is empty and this will cause the allocation to crash.  
+
+                   ! The first step is to decide of the distribution of individuals 
+                   ! that we want in each class, for example, a uniform or exponential 
+                   ! distribution.
+                   ! Make this an input parameter.
+
+                   ! Now we need to populate the new distribution of trees among
+                   ! the circumference classes, and move the heartwood and sap masses 
+                   ! to the new distributions. We also need to move the other pools.  
+                   ! This is tricky because the allometric relations for the new
+                   ! tree sizes will NOT give the same amount of biomass for
+                   ! the non-woody pools.  Let us first try it just distributing
+                   ! everything equally, and then if that doesn't work we can
+                   ! redistribute the non-woody pools more cleverly, even if that 
+                   ! means we change the total amount of biomass we have in this
+                   ! stand.  I want to try it this way because we conserve biomass 
+                   ! this way, and I hope that the stress on the trees will be
+                   ! small enough that it doesn't cause problems.  This
+                   ! redistribution should only happen rarely, so the trees
+                   ! should have a chance to equilibrate.
+
+                   circ_class_n_new(:)=circ_class_dist(:)*SUM(circ_class_n(ipts,ivm,:))
+                   circ_class_biomass_new(:,:)=zero
+
+                   ! now we populate the new classes
+                   old_trees_left(:)=circ_class_n(ipts,ivm,:)
+
+                   ! The subsequent calculation nicely closes the carbon
+                   ! balance but within the precision 10-16. If there are
+                   ! enough trees (first case in the IF-loop), we introduce
+                   ! a precision error in the number of trees. This implies
+                   ! that when the number of trees is very small, the
+                   ! precision issue can become a numerical issue. This is 
+                   ! especially true for the largest circumference classes 
+                   ! because they contains the fewest individuals. 
+                   ! We observed the largest circumference classes 
+                   ! containing 10-4 to 10-5 gC less than the previous 
+                   ! class. The rest of the code shouldn't care too much 
+                   ! whether the circumferences classes are in order or not 
+                   ! but to reduce the chances this problem occurs
+                   ! we inverted the DO-loops. That way the precision error
+                   ! occurs in carried to the smaller diameter classes 
+                   ! which have more individuals and so the precision error
+                   ! stays a precision issue. Note that this routine is
+                   ! called every day so the problem is likely to be 
+                   ! corrected the next day.
+                   DO icir=ncirc,1,-1
+
+                      trees_needed=circ_class_n_new(icir)
+
+                      DO jcir=ncirc,1,-1
+
+                         IF(trees_needed .LE. zero)EXIT
+
+                         !+++TEMP+++
+                         IF(ld_biomass .AND. ivm==test_pft)THEN
+                            WRITE(numout,*) 'start of loop'
+                            WRITE(numout,*) 'circ_class_biomass_new, ',&
+                                 icir,SUM(circ_class_biomass_new(icir,:))
+                            WRITE(numout,*) 'old_trees_left, ', &
+                                 jcir, old_trees_left(jcir)
+                            WRITE(numout,*) 'trees needed, ',trees_needed
+                         ENDIF
+                         !++++++++++
+
+                         IF(old_trees_left(jcir) .GE. trees_needed )THEN
+
+                            ! we can get all the trees we need from this class
+                            ! and don't have to continue searching
+                            circ_class_biomass_new(icir,:)=circ_class_biomass_new(icir,:)+&
+                                 circ_class_biomass(ipts,ivm,jcir,:,icarbon)*trees_needed
+                            old_trees_left(jcir)=old_trees_left(jcir)-trees_needed
+                            trees_needed = zero
+
+                            !+++TEMP+++
+                            IF(ld_biomass .AND. ivm==test_pft)THEN
+                               WRITE(numout,*) 'enough trees'
+                            ENDIF
+                            !++++++++++
+   
+                            EXIT
+
+                         ELSE
+
+                            ! the trees in this class are not sufficient, so we
+                            ! need to move all of them to the new class.
+                            circ_class_biomass_new(icir,:)=circ_class_biomass_new(icir,:)+&
+                                 circ_class_biomass(ipts,ivm,jcir,:,icarbon)*&
+                                 old_trees_left(jcir)
+                            trees_needed = trees_needed-old_trees_left(jcir)
+                            old_trees_left(jcir)=zero
+
+                            !+++TEMP+++
+                            IF(ld_biomass .AND. ivm==test_pft)THEN
+                               WRITE(numout,*) 'not enough trees'
+                            ENDIF
+                            !++++++++++
+
+                         ENDIF
+                         
+                         !+++TEMP+++
+                         IF(ld_biomass .AND. ivm==test_pft)THEN
+                            WRITE(numout,*) 'start of loop'
+                            WRITE(numout,*) 'circ_class_biomass_new, ',&
+                                 icir,SUM(circ_class_biomass_new(icir,:))
+                            WRITE(numout,*) 'old_trees_left, ', &
+                                 jcir, old_trees_left(jcir)
+                            WRITE(numout,*) 'trees needed, ',trees_needed
+                         ENDIF
+                         !++++++++++
+
+                      ENDDO ! jcir=1,ncirc
+
+                   ENDDO ! icir=1,ncirc
+
+                   ! right now, circ_class_biomass_new gives the total biomass
+                   ! in each class, but it should only be for a model tree. 
+                   ! So let's normalize it.
+                   DO icir=1,ncirc
+                      circ_class_biomass_new(icir,:)=circ_class_biomass_new(icir,:)/&
+                           circ_class_n_new(icir)
+                   ENDDO
+
+                   ! Check whether the order was preserved. We expect that the
+                   ! biomass of an individual tree increases with an increasing
+                   ! circ class. This is probably not important for the correct
+                   ! functioning of the model. We try to preserve the order as
+                   ! an additional mean to control the quality of the simulations
+                   ! If the order was not preserved we will sort the biomasses.
+                   tree_size(:)=zero
+                   DO icir=1,ncirc
+
+                      tree_size(icir)=SUM(circ_class_biomass_new(icir,:))
+                      
+                   ENDDO
+                   sort = zero
+                   DO icir=2,ncirc
+
+                      IF(tree_size(icir) .LT. tree_size(icir-1))THEN
+                         
+                         ! The order is not preserved
+                         sort = un
+                         EXIT
+
+                      ENDIF
+
+                   ENDDO
+                   
+                   ! Sort the biomasses. Note that at the same time we also 
+                   ! have to sort circ_class_n. We made use of the Shell sort
+                   ! method
+                   IF (sort==1) THEN
+
+                      !+++TEMP+++
+                      IF(ld_biomass)THEN
+                         WRITE(numout,*) 'gap_clean: sort begin', &
+                              SUM(circ_class_biomass_new(:,:),2),&
+                              circ_class_n_new(:)
+                      ENDIF
+                      !++++++++++
+                      
+                      inc = 1
+                      DO
+                         inc=3*inc+1
+                         IF (inc .GT. ncirc) EXIT
+                      ENDDO
+                      DO
+                         inc = inc/3
+                         DO icir=inc+1,ncirc
+                            v1(:) = circ_class_biomass_new(icir,:)
+                            v2 = circ_class_n_new(icir)
+                            jcir=icir
+                            DO
+                               IF (SUM(circ_class_biomass_new(jcir-inc,:)) .LE. SUM(v1(:))) EXIT
+                               circ_class_biomass_new(jcir,:) = &
+                                    circ_class_biomass_new(jcir-inc,:)
+                               circ_class_n_new(jcir) = circ_class_n_new(jcir-inc) 
+                               jcir = jcir-inc
+                               IF (jcir .LE. inc) EXIT
+                            ENDDO
+                            circ_class_biomass_new(jcir,:)=v1(:)
+                            circ_class_n_new(jcir)=v2
+                         ENDDO
+                         IF (inc .LE. 1) EXIT
+                      ENDDO
+
+                      !+++TEMP+++
+                      IF(ld_biomass)THEN
+                         WRITE(numout,*) 'gap_clean: sort end', &
+                              SUM(circ_class_biomass_new(:,:),2),&
+                              circ_class_n_new(:)
+                      ENDIF
+                      !++++++++++
+
+                   ENDIF
+
+                   ! now update the variables that pass this information around
+                   DO icir=1,ncirc
+                      circ_class_biomass(ipts,ivm,icir,:,icarbon)=circ_class_biomass_new(icir,:)
+                      circ_class_n(ipts,ivm,icir)=circ_class_n_new(icir)
+                   ENDDO
+
+
+                ENDIF ! redistribute
+                
+                !---TEMP---
+                IF(ld_biomass .AND. ivm==test_pft)THEN
+                   WRITE(numout,*) 'End of redistributing biomass in gap_clean'
+                   WRITE(numout,*) 'ipts,ivm',ipts,ivm
+                   WRITE(numout,*) 'circ_class_n, ',circ_class_n(ipts,ivm,:)
+                   WRITE(numout,*) 'circ_class_biomass, ', &
+                        SUM(circ_class_biomass(ipts,ivm,:,:,icarbon),2)
+                ENDIF
+                !----------
+
+             ELSE
+
+                ! we have biomass here and it's not a tree.  Don't need to do anything.
+
+             ENDIF
+
+          ELSE 
+
+             ! all the biomass was killed for this site.  Some flags to
+             ! be reset in this case.
+
+             IF(PFTpresent(ipts,ivm))THEN
+                
+                nkilled(ivm)=nkilled(ivm)+1 ! purely an informational variable
+
+                !! 1.5 Reinitialize vegetation characteristics in STOMATE
+                senescence(ipts,ivm) = .FALSE.
+                age(ipts,ivm) = zero
+                when_growthinit(ipts,ivm) = large_value 
+
+                !! 1.6 Update leaf ages
+                DO ilage = 1, nleafages
+                   
+                   leaf_age(ipts,ivm,ilage) = zero 
+                   leaf_frac(ipts,ivm,ilage) = zero 
+                   
+                ENDDO
+
+                ! This used to be done in lpj_kill.  If we have grasses,
+                ! we reset the long term GPP.  This value as 500 in the
+                ! old code.  We externalized the variable, but we are
+                ! leaving the default at 500.  Many PFTs should have
+                ! a long term value of less than 500, so someone could
+                ! do some work on this in the future.
+                IF (.NOT. is_tree(ivm) .AND. .NOT. control%ok_constant_mortality) THEN
+                   
+                   npp_longterm(ipts,ivm) = npp_reset_value(ivm)
+
+                ENDIF
+
+                
+             ENDIF ! is PFT present?
+
+          ENDIF ! check if biomass is equal to zero
+
+          ! If we have no vegetation left, this stand has been completely cleared.
+          ! We have to reset the age, regardless if it was for natural or human reasons.
+          IF(is_tree(ivm))THEN
+
+             IF( SUM(biomass(ipts,ivm,:,icarbon)) .LT. min_stomate)THEN
+
+                age_stand(ipts,ivm)=0
+
+                IF(ld_forestry .OR. ld_kill)THEN
+                   WRITE(numout,*) 'Getting reset in stomate_kill'
+                   WRITE(numout,*) 'ivm,ipts',ivm,ipts
+                ENDIF
+                
+                ! We should reset these flags as well, since we are
+                ! doing management somewhere.
+                last_cut(ipts,ivm)=0
+                mai_count(ipts,ivm)=0
+
+                ! If we are using age classes, we need to reset a lot of counters
+                ! and change veget_max, moving veget_max from this age class to
+                ! the lowest age class.  If veget_max is greater than zero and there
+                ! is no biomass, prescribe will attempt to grow trees here in the
+                ! next timestep.  This is fine if we have no age classes, but it doesn't
+                ! make any sense to prescribe trees that are 50 years old.  We should
+                ! only prescribe trees which are 0 years old.
+                !  This is essentially the same code that is found in land cover change,
+                ! since the same simulation happens there.  Notice that here we do not
+                ! need to use the _bank variables, since we assume that if a stand dies
+                ! due to natural causes it will always be replaced by the same species.
+                ! We also assume that if a stand is clearcut, the model will replace it
+                ! by the same species.  To do so otherwise would require something more
+                ! like a DGVM.
+                IF(nagec .GT. 1)THEN
+
+                   ! First, we need to find the youngest age class of this PFT.
+                   iyoung=start_index(agec_group(ivm))
+                   IF(ivm == iyoung)THEN
+                      lyoungest=.TRUE.
+                   ELSE
+                      lyoungest=.FALSE.
+                   ENDIF
+
+                   IF(lyoungest)THEN
+
+                      ! We don't need to do anything.  Things will be handled properly with
+                      ! prescribe in the next step.
+
+                   ELSE
+
+                      ! All of our counters for this stand are zero.  We need to merge that
+                      ! with the youngest age class.  There are a couple possibilities.
+                      ! One is that nothing exists right now in the youngest age class, in 
+                      ! which case the veget_max of the old age class becomes that of the 
+                      ! youngest and we prescribe.  Another possibility is that something 
+                      ! does exist in the youngest age class, in which case we prescribe 
+                      ! to the current age class and then merge biomass with the youngest.  
+                      ! A third is that both the youngest age class and the current age 
+                      ! class have died.  In that case we can do the same thing as if there 
+                      ! is no vegetation in the small age class, we just have to make sure 
+                      ! to add the veget_max and not replace it.
+                      ! Veget_max after PFT expansion. As ::veget_max is used in the 
+                      ! IF-statements we won't update it until the end of this routine. If 
+                      ! we would updatebefore that, the same PFT may be subject to 
+                      ! conflicting actions.
+                      share_young = veget_max(ipts,iyoung) / &
+                           ( veget_max(ipts,iyoung) + veget_max(ipts,ivm) )
+
+                      ! We also need a scaling factor which includes the litter
+                      DO ilev=1,nlevs
+                         DO ilit=1,nlitt
+                            IF(litter(ipts,ilit,iyoung,ilev,icarbon) .GT. min_stomate)THEN
+
+                               litter_weight_young(ilit,ilev)=&
+                                    litter(ipts,ilit,iyoung,ilev,icarbon)*veget_max(ipts,iyoung)/ &
+                                    (litter(ipts,ilit,ivm,ilev,icarbon)*veget_max(ipts,ivm) + &
+                                    litter(ipts,ilit,iyoung,ilev,icarbon)*veget_max(ipts,iyoung))
+
+                            ELSE
+
+                               litter_weight_young(ilit,ilev)=zero
+
+                            ENDIF
+                         END DO
+                      ENDDO
+
+                      IF( SUM(biomass(ipts,iyoung,:,icarbon)) .LT. min_stomate)THEN
+
+                         IF(ld_agec)THEN
+                            WRITE(numout,*) 'Merging our biomass to the youngest age class.'
+                            WRITE(numout,*) 'No current biomass in the youngest age class.'
+                            WRITE(numout,*) 'ipts,iyoung,ivm: ',ipts,iyoung,ivm
+                            WRITE(numout,*) 'share_young: ',share_young
+                            WRITE(numout,*) 'veget_max(young and current): ',&
+                                 veget_max(ipts,iyoung),veget_max(ipts,ivm)
+                         ENDIF
+
+                         ! Is there anything in the smallest age class?  It
+                         ! does not matter if the youngest age class died in this
+                         ! step or not.                         
+                         veget_max(ipts,iyoung)=veget_max(ipts,iyoung)+veget_max(ipts,ivm)
+                         
+                         moiavail_growingseason(ipts,iyoung) = &
+                              share_young * moiavail_growingseason(ipts,iyoung) + &
+                              moiavail_growingseason(ipts,ivm) * &
+                              (un - share_young)
+
+                         ! I am not sure why we merge wstress here.  wstress is recalculated
+                         ! everyday from moiavail_growingseason.
+                         wstress_season(ipts,iyoung) = &
+                              share_young * wstress_season(ipts,iyoung) + &
+                              wstress_season(ipts,ivm) * (un - share_young)
+
+                         ! The litter variables also need to be merged, since these will not
+                         ! get updated in prescribe in the next step.
+                         litter(ipts,:,iyoung,:,:) =   &
+                              share_young * litter(ipts,:,iyoung,:,:) + &
+                              litter(ipts,:,ivm,:,:) * &
+                              (un - share_young)
+                         carbon(ipts,:,iyoung) =  &
+                              share_young *  carbon(ipts,:,iyoung) + &
+                               carbon(ipts,:,ivm) * &
+                              (un - share_young)
+                         DO ilev=1,nlevs
+                            lignin_struc(ipts,iyoung,ilev) = &
+                                 litter_weight_young(istructural,ilev) * &
+                                 lignin_struc(ipts,iyoung,ilev) + &
+                                 (un - litter_weight_young(istructural,ilev)) * &
+                                 lignin_struc(ipts,ivm,ilev) 
+                            lignin_wood(ipts,iyoung,ilev) = &
+                                 litter_weight_young(iwoody,ilev) * &
+                                 lignin_wood(ipts,iyoung,ilev) + &
+                                 (un - litter_weight_young(iwoody,ilev) ) * &
+                                 lignin_wood(ipts,ivm,ilev) 
+                         ENDDO
+
+                         bm_to_litter(ipts,iyoung,:,:) = &
+                              share_young * bm_to_litter(ipts,iyoung,:,:) + &
+                              bm_to_litter(ipts,ivm,:,:) * &
+                              (un - share_young)
+
+
+                      ELSE
+
+                         ! There are two important things to do here.  First,
+                         ! we need to prescribe biomass to this PFT, since it
+                         ! is currently empty.  Then we need to merge this biomass
+                         ! with what is already in the youngest age class of this PFT.
+
+                         ! We want to make use of prescribe_prognostic but it should 
+                         ! be noted that the youngest PFT already contains biomass. 
+                         ! Therefore we will create a temporary PFT without biomass which 
+                         ! can be used to establish the  new vegetation within the 
+                         ! youngest. For most of the INTENT(inout)  variables of 
+                         ! prescribe_prognostic we receive temporary variables back this 
+                         ! helps us to calculate the weighted mean of the newly established 
+                         ! vegetation and the vegetation that is already there. For some 
+                         ! other variables we receive dummies as we are simply not
+                         ! going to use these values but will continue using the values of the
+                         ! vegetation that is already there.
+
+                         IF(ld_agec)THEN
+                            WRITE(numout,*) 'Merging our biomass to the youngest age class.'
+                            WRITE(numout,*) 'Biomass already in the youngest age class.'
+                            WRITE(numout,*) 'ipts,iyoung,ivm: ',ipts,iyoung,ivm
+                            WRITE(numout,*) 'share_young: ',share_young
+                            WRITE(numout,*) 'veget_max(young and current): ',&
+                                 veget_max(ipts,iyoung),veget_max(ipts,ivm)
+                         ENDIF
+
+                         !! 5.2.3.1 Initialize new and dummy variables
+                         new_biomass(:,:,:,:) = zero
+                         new_circ_class_biomass(:,:,:,:,:) = zero
+                         new_ind(:,:) = zero
+                         new_circ_class_n(:,:,:) = zero
+                         new_lm_lastyearmax(:,:) = zero
+                         new_age(:,:) = zero
+                         new_leaf_frac(:,:,:) = zero
+                         new_co2_to_bm(:,:) = zero
+                         new_everywhere(:,:) = zero 
+                         dum_when_growthinit(:,:) = large_value
+                         dum_npp_longterm(:,:) = zero
+                         dum_PFTpresent(:,:) = .TRUE.
+                         dum_senescence(:,:) = .FALSE.
+                
+                         !! 5.2.3.2 Merge the new and already available vegetation
+
+                         ! Assign value to moiavail_growingseason
+                         ! We do this differently from LCC, because we are replanting
+                         ! the same stand that we just cut.
+                         moiavail_growingseason(ipts,iyoung) = &
+                              moiavail_growingseason(ipts,iyoung) * &
+                              share_young + moiavail_growingseason(ipts,ivm) * (un - share_young)
+                         wstress_season(ipts,iyoung) = wstress_season(ipts,iyoung) * &
+                              share_young + wstress_season(ipts,ivm) * (un - share_young)
+     
+                         !! 5.2.3.3 Initialize the newly established vegetation: 
+                         !  Initialize the newly established vegetation: density of 
+                         !  individuals, biomass, allocation factors, leaf age distribution, 
+                         !  etc to some reasonable value ::veget_max is not updated yet, 
+                         !  therefore loss_gain is passed in the argument list.
+                         !  For loss_gain, we only want to replant the current PFT.
+                         loss_gain(:,:)=zero
+                         loss_gain(ipts,ivm)=veget_max(ipts,ivm)
+                         CALL prescribe_prognostic (npts,loss_gain,veget, dt_days,dum_PFTpresent, &
+                              new_everywhere, dum_when_growthinit, new_biomass, new_leaf_frac, &
+                              new_ind, new_circ_class_n, new_circ_class_biomass, new_co2_to_bm, &
+                              forest_managed, KF, &
+                              dum_senescence, new_age, dum_npp_longterm, new_lm_lastyearmax, &
+                              tau_eff_leaf, tau_eff_sap, tau_eff_root, k_latosa_adapt)
+
+                         !! 5.2.3.3.1 Merge biomass of new and already available trees
+                         ! Unlike LCC, we are only at this point if we are dealing
+                         ! with forests, so we don't have to check for that here.
+
+                         ! Copy the number of individuals and the biomass of the established 
+                         ! vegetation to a temporary variable. In the subroutine ::circ_class_n
+                         ! and ::circ_class_biomass will be overwritten with the characteristics
+                         ! of the merged vegetation
+                         ! The term "established" here refers to the youngest age class, while
+                         ! "tmp" is the prescribed vegetation that we just created.
+                         est_circ_class_n(:) = circ_class_n(ipts,iyoung,:)
+                         est_circ_class_biomass(:,:,:) = circ_class_biomass(ipts,iyoung,:,:,:)
+                         tmp_circ_class_n(:) = new_circ_class_n(ipts,ivm,:)
+                         tmp_circ_class_biomass(:,:,:) = new_circ_class_biomass(ipts,ivm,:,:,:)
+                         
+                         ! Store circumference (m) in a temporary variable that can be 
+                         ! sorted from small to large - note that the dimension of these
+                         ! variables are 2*ncirc
+                         est_circ_class_dia(:) = wood_to_dia(est_circ_class_biomass(:,:,icarbon),ivm)
+                         tmp_circ_class_dia(:) = wood_to_dia(tmp_circ_class_biomass(:,:,icarbon),ivm)
+
+                         ! Merge the biomass 
+                         CALL merge_biomass_pfts(npts, share_young, circ_class_n, &
+                              est_circ_class_n, tmp_circ_class_n, circ_class_biomass, &
+                              est_circ_class_biomass, &
+                              tmp_circ_class_biomass, ind, biomass, circ_class_dist, &
+                              ipts, iyoung, est_circ_class_dia, tmp_circ_class_dia)
+
+                         !! 5.2.3.4 Calculate the PFT characteristics of the merged PFT
+                         !  Take the weighted mean of the existing vegetation and the new 
+                         !  vegetation in this PFT. Note that co2_to_bm is in gC. m-2 dt-1 
+                         !  so we should also take the weighted mean (rather than sum if
+                         !  this where absolute values).
+                         lm_lastyearmax(ipts,iyoung) = share_young * lm_lastyearmax(ipts,iyoung) + &
+                              (un - share_young) * new_lm_lastyearmax(ipts,ivm)
+                         age(ipts,iyoung) = share_young * age(ipts,iyoung) + &
+                              (un - share_young) * new_age(ipts,ivm)
+                         leaf_frac(ipts,iyoung,:) = share_young * leaf_frac(ipts,iyoung,:) + &
+                              (un - share_young) * new_leaf_frac(ipts,ivm,:)
+                         co2_to_bm(ipts,iyoung) = share_young * co2_to_bm(ipts,iyoung) + &
+                              (un - share_young) * new_co2_to_bm(ipts,ivm)
+
+                         ! Update the orphan flux for the CO2 turned into biomass by prescribe,
+                         ! as well as the area of vegetation regrown.
+                         orphan_flux_local(ipts,ivm,ico2bm,icarbon) = new_co2_to_bm(ipts,ivm)
+                         orphan_flux_local(ipts,ivm,ivegnew,icarbon) = veget_max(ipts,ivm)
+
+                         ! Everywhere deals with the migration of vegetation. Copy the
+                         ! status of the most migrated vegetation for the whole PFT
+                         everywhere(ipts,iyoung) = MAX(everywhere(ipts,iyoung), &
+                              new_everywhere(ipts,ivm))
+
+                         ! The new soil&litter pools are the weighted mean of the newly 
+                         ! established vegetation for that PFT and the vegetation that 
+                         ! already exists in that PFT.  Notice that we do not use the
+                         ! "bank" concept present in LCC because we are replanting
+                         ! the same PFT which already existed, just in a younger class.
+                         litter(ipts,:,iyoung,:,:) = share_young * litter(ipts,:,iyoung,:,:) + &
+                              (un - share_young) * litter(ipts,:,ivm,:,:)
+                         carbon(ipts,:,iyoung) =  share_young * carbon(ipts,:,iyoung) + &
+                              (un - share_young) * carbon(ipts,:,ivm)
+                         DO ilev=1,nlevs
+                            lignin_struc(ipts,iyoung,ilev) = &
+                                 litter_weight_young(istructural,ilev) * &
+                                 lignin_struc(ipts,iyoung,ilev) + &
+                                 (un - litter_weight_young(istructural,ilev)) * &
+                                 lignin_struc(ipts,ivm,ilev) 
+                            lignin_wood(ipts,iyoung,ilev) = &
+                                 litter_weight_young(iwoody,ilev) * &
+                                 lignin_wood(ipts,iyoung,ilev) + &
+                                 (un - litter_weight_young(iwoody,ilev) ) * &
+                                 lignin_wood(ipts,ivm,ilev) 
+                         ENDDO
+                         bm_to_litter(ipts,iyoung,:,:) = share_young * &
+                              bm_to_litter(ipts,iyoung,:,:) + & 
+                              (un - share_young) * bm_to_litter(ipts,ivm,:,:)
+
+                         ! Now move the veget_max from the current class to the young one.
+                         veget_max(ipts,iyoung)=veget_max(ipts,iyoung)+veget_max(ipts,ivm)
+
+                      ENDIF
+                
+                      ! Reset all these variables, since the PFT is dead.
+                      PFTpresent(ipts,ivm) = .FALSE.
+                      veget_max(ipts,ivm) = zero
+                      lm_lastyearmax(ipts,ivm) = zero
+                      age(ipts,ivm) = zero
+                      leaf_frac(ipts,ivm,:) = zero
+                      co2_to_bm(ipts,ivm) = zero
+                      everywhere(ipts,ivm) = zero
+                      litter(ipts,:,ivm,:,:) = zero
+                      carbon(ipts,:,ivm) = zero
+                      lignin_struc(ipts,ivm,:) = zero
+                      lignin_wood(ipts,ivm,:) = zero
+                      bm_to_litter(ipts,ivm,:,:) = zero
+                      biomass(ipts,ivm,:,:) = zero
+                      ind(ipts,ivm) = zero
+                      
+                      ! Keep ::biomass and circ_class_biomass synchronized
+                      circ_class_biomass(ipts,ivm,:,:,:) = zero
+                      circ_class_n(ipts,ivm,:) = zero
+                      
+                   ENDIF ! If this is the youngest age class
+
+                ENDIF ! If we are using age classes
+
+             ENDIF ! If we've killed all our biomass in ivm
+
+          ENDIF ! is_tree
+
+       ENDDO  ! loop over pfts
+
+    END DO ! loop over land points
+
+  !! 3. Check mass balance closure
+   
+    !  Consider this whole routine as a black box with incoming and outgoing 
+    !  fluxes and a change in the mass of the box. Express in absolute 
+    !  units gC (or gN), hence, multiply with dt and veget_max. In most routines 
+    !  veget_max does not change and could be omitted but a general approach 
+    !  was prefered.
+
+    !! 3.1 Calculate pools at the end of the routine
+    pool_end = zero
+    DO iele = 1,nelements
+       DO ipar = 1,nparts
+          pool_end(:,:,iele) = pool_end(:,:,iele) + &
+               (biomass(:,:,ipar,iele) * veget_max(:,:)) 
+       ENDDO
+
+       ! Litter pool (gC m-2) *  (m2 m-2) 
+       DO ilit = 1,nlitt
+          DO ilev = 1,nlevs
+             pool_end(:,:,iele) = pool_end(:,:,iele) + &
+                  litter(:,ilit,:,ilev,iele) * veget_max(:,:)
+          ENDDO
+       ENDDO
+
+       ! Soil carbon (gC m-2) *  (m2 m-2)
+       DO icarb = 1,ncarb
+          pool_end(:,:,iele) = pool_end(:,:,iele) + &
+               carbon(:,icarb,:) * veget_max(:,:)
+       ENDDO   
+    ENDDO
+
+    !! 4.2 Calculate components of the mass balance
+    check_intern(:,:,iatm2land,icarbon) = orphan_flux_local(:,:,ico2bm,icarbon) * &
+         orphan_flux_local(:,:,ivegnew,icarbon)
+    check_intern(:,:,iland2atm,icarbon) = -un * zero
+    check_intern(:,:,ilat2out,icarbon) = zero
+    check_intern(:,:,ilat2in,icarbon) = -un * zero
+    check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - pool_start(:,:,icarbon))
+    closure_intern = zero
+    DO imbc = 1,nmbcomp
+       closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + check_intern(:,:,imbc,icarbon)
+    ENDDO
+
+    ! Write outcome.  Need to some over all PFTs here because vegetation can
+    ! move between them when an age class dies
+    DO ipts=1,npts
+       IF(ABS(SUM(closure_intern(ipts,:,icarbon))) .LE. min_stomate)THEN
+          IF (ld_massbal) WRITE(numout,*) 'Mass balance closure in gap_clean'
+       ELSE
+          WRITE(numout,*) 'Error: mass balance is not closed in gap_clean',&
+               SUM(closure_intern(ipts,:,icarbon))
+          DO ivm=1,nvm
+             WRITE(numout,*) '   ipts,ivm; ', ipts,ivm
+             WRITE(numout,*) '   Difference is, ', closure_intern(ipts,ivm,icarbon)
+             WRITE(numout,*) '   pool_end,pool_start: ', &
+                  pool_end(ipts,ivm,icarbon), pool_start(ipts,ivm,icarbon)
+             WRITE(numout,*) '   orphan_fluxes: ', &
+                  orphan_flux_local(ipts,ivm,ico2bm,icarbon),&
+                  orphan_flux_local(ipts,ivm,ivegnew,icarbon)
+             WRITE(numout,*) '   veget_max: ', veget_max(ipts,ivm)
+          ENDDO
+          IF(ld_stop)THEN
+             CALL ipslerr_p (3,'gap_clean', 'Mass balance error.','','')
+          ENDIF
+       ENDIF
+    ENDDO
+
+    !++++ CHECK+++++
+    ! Here we should merge orphan_flux_local with the real orphan_flux passed out of this routine
+    ! Right now we get an error in stomate_lpj and stomate after age classes migrate because
+    ! we have not done this.  We get no error here, though.
+    !+++++++++++++++
+
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving gap_clean'
+
+  END SUBROUTINE gap_clean
+
+END MODULE stomate_kill
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_laieff.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_laieff.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_laieff.f90	(revision 7236)
@@ -0,0 +1,2674 @@
+! =================================================================================================================================
+! MODULE       : stomate_laieff
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Groups the subroutines that are used to calculate the effective
+!!             LAI.  Right now this is only used in the albedo routines.  I
+!!             originally tried to put these routines there, but that creates
+!!             some dependency problems that could not be resolved, since
+!!             the effective LAI is calculated in stomate.f90 along with
+!!             the LAI.
+!!
+!!\n DESCRIPTION : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! REFERENCE(S)	: None
+!!
+!! SVN :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_stomate/stomate_laieff.f90 $
+!! $Date: 2013-02-13 11:14:38 +0100 (Wed, 13 Feb 2013) $
+!! $Revision: 1182 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE stomate_laieff
+
+  ! Modules used:
+  USE constantes
+  USE pft_parameters
+  USE structures
+  USE ioipsl_para, ONLY : ipslerr_p
+  USE stomate_stand_structure
+  USE stomate_data
+  USE function_library, ONLY: wood_to_height_eff, wood_to_cn_eff, biomass_to_lai 
+  USE matrix_resolution
+
+  IMPLICIT NONE
+
+  ! Private & public routines
+
+  PUBLIC effective_lai, fitting_laieff, calculate_z_level_photo, &
+       find_lai_per_level, combine_lai_levels
+
+  INTEGER,SAVE :: ivm_save
+  INTEGER,SAVE :: ibin_save
+  INTEGER,SAVE :: ilevel_save
+
+CONTAINS
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: calculate_z_level_photo
+!!
+!>\BRIEF        
+!!
+!! DESCRIPTION  :  This is routine to calculate the physical heights of
+!!                 all the levels used to calculate photosynthesis.  The bottom layer
+!!                 will always have a height of zero, since it must be at the ground
+!!                 level.  I tried to make all the layers evenly spaced starting from
+!!                 zero to the top of the canopy, but this does not work very well
+!!                 for tall trees; all the vegetation ends up in the top level and
+!!                 nothing in the lower levels.  So now I try to find the bottom of
+!!                 the canopy for trees as well, and start the second level from there.
+!!                 The top level is always just below the top of the canopy (unless there
+!!                 is only one level).  If there are multiple levels used in the energy
+!!                 budget, the spacing between the levels will not be uniform.
+!!
+!!                 If there is no leaf biomass, all the levels are set to zero since
+!!                 they should not be used and it would be a waste of time to calculate.
+!!
+!!    NOTE:
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::z_level_photo
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART : None
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE calculate_z_level_photo(npts, circ_class_biomass, &
+       circ_class_n, biomass, z_level_photo)
+
+  !! 0 Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+    
+    INTEGER(i_std),INTENT(IN)                        :: npts                 !! Domain size - number of pixels (unitless)
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(IN)  &
+                                                     :: circ_class_biomass   !! Biomass of the componets of the model  
+                                                                             !! tree within a circumference
+                                                                             !! class @tex $(gC ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(IN)        :: circ_class_n         !! Number of trees within each circ class
+                                                                             !! class @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(in)      :: biomass              !! Stand level biomass @tex $(gC m^{-2})$ @endtex
+    !! 0.2 Output variables
+    REAL(r_std),DIMENSION(:,:,:),INTENT(OUT)         :: z_level_photo        !! the height of the bottom of each of our levels 
+                                                                             !! @tex $(m)$ @endtex
+                                                                             !! note that level 1 is closest to the ground
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER :: ipts,ivm,il,il_photo,nl_photo,icir                            !! Indices (unitless)
+    REAL(r_std),DIMENSION(ncirc)  :: heights                                 !! Tree heights @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(ncirc)  :: cn_dia                                  !! Crown diameters @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(ncirc)  :: cn_bottom                               !! Height of the bottom of the crown @tex $(m)$ @endtex
+    REAL(r_std) :: max_height                                                !! Highest actual vegetation height @tex $(m)$ @endtex
+    REAL(r_std) :: min_height                                                !! Lowest bottom of the canopy @tex $(m)$ @endtex
+    REAL(r_std) :: upper_level_boundary                                      !! The height of the top of the current energy budget
+                                                                             !! level @tex $(m)$ @endtex
+    REAL(r_std) :: lower_level_boundary                                      !! The height of the bottom of the current energy budget
+                                                                             !! level @tex $(m)$ @endtex
+    REAL(r_std) :: ideal_level_thickness                                     !! The thickness of the photosynthesis levels in this
+                                                                             !! energy budget level if there are no other concerns.
+                                                                             !! @tex $(m)$ @endtex
+    REAL(r_std) :: block_thickness                                           !! The thickness of a chunk of PS levels together.
+                                                                             !! @tex $(m)$ @endtex
+    REAL(r_std) :: canopy_thickness                                          !! The thickness of the whole vegetation layer.
+                                                                             !! @tex $(m)$ @endtex
+    REAL(r_std) :: canopy_center                                             !! The height of the center of the whole vegetation layer.
+                                                                             !! @tex $(m)$ @endtex
+!_ ================================================================================================================================
+    
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering calculate_z_level_photo',nlevels,nlevels_tot
+
+    nl_photo=nlevels_tot/nlevels ! the number of photosynthesis levels per energy level
+
+    ! If we are not using any additional levels for 
+    ! the photosynthesis, this is easy.
+    IF(nlevels_photo .EQ. 1) THEN
+       DO il=1,nlevels
+          z_level_photo(:,:,il)=z_level(il)
+       ENDDO
+       RETURN
+    ENDIF
+
+    IF(nlevels .GT. 1)THEN
+       WRITE(numout,*) 'WARNING: calculate_z_level_photo has not been tested yet'
+       WRITE(numout,*) 'WARNING: for the multilevel energy budget.  Be sure to '
+       WRITE(numout,*) 'WARNING: do this and then remove this warning message.'
+    ENDIF
+
+    ! This is just a quick test.  The difference between the energy level heights
+    ! should not be so small that it is impossible to fit all our photosynthesis
+    ! levels in.
+
+    DO il=1,nlevels-1
+
+       ideal_level_thickness=(z_level(il+1)-z_level(il))&
+            /REAL(nl_photo,r_std)
+
+       DO ivm=1,nvm
+
+          IF(ideal_level_thickness .LE. min_level_sep(ivm))THEN
+
+             WRITE(numout,*) 'ERROR: We do not have enough space between the energy '
+             WRITE(numout,*) 'ERROR: levels to fit all the photosynthesis levels you '
+             WRITE(numout,*) 'ERROR: are asking for.  Either reduce nl_photo or min_level_sep, '
+             WRITE(numout,*) 'ERROR: or increase the width of the levels for the energy budget.'
+
+             WRITE(numout,*) 'il, ivm: ',il,ivm
+             WRITE(numout,*) 'ideal_level_thickness, min_level_sep(ivm): ',&
+                  ideal_level_thickness, min_level_sep(ivm)
+             WRITE(numout,*) 'z_level(il+1),z_level(il): ',z_level(il+1),z_level(il)
+             WRITE(numout,*) 'nl_photo: ',nl_photo
+
+             CALL ipslerr_p (3,'calculate_z_level_photo', 'Not enough space.','','')
+          ENDIF
+
+       ENDDO
+
+    ENDDO
+
+    DO ipts=1,npts
+       DO ivm=1,nvm
+
+          ! Skip all of this if we have no leaf biomass
+          IF(biomass(ipts,ivm,ileaf,icarbon) .LE. min_stomate)THEN
+             z_level_photo(ipts,ivm,:)=zero
+             CYCLE
+          ENDIF
+
+          IF(is_tree(ivm))THEN
+
+             ! We need to know the maximum height of the vegetation so that
+             ! we don't calculate a lot of levels with nothing in them
+             ! Notice that we have to use wood_to_height_eff here.  The reason is that
+             ! after coppicing, we may have zero aboveground wood, so our height calculated
+             ! with wood_to_height would be zero.
+             heights(:)=wood_to_height_eff(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)
+             max_height=MAXVAL(heights(:))
+
+             ! Find the crown diameter and subtract this from the height,
+             ! so that we know where the bottom of the canopy is.
+             cn_dia(:)=SQRT(4._r_std/pi*wood_to_cn_eff(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm))
+             cn_bottom(:)=heights(:)-cn_dia(:)
+             min_height=MINVAL(cn_bottom(:))
+
+             IF(ld_laieff)THEN
+                IF((ivm == test_pft) .AND. (ipts == test_grid))THEN
+                   WRITE(numout,*) 'This is the largest height of trees in z_level_photo'
+                   WRITE(numout,*) 'max_height, min_height: ',max_height,min_height
+                   WRITE(numout,*) 'heights: ',heights(:)
+                   WRITE(numout,*) 'cn_dia: ',cn_dia(:)
+                   DO icir=1,ncirc
+                      WRITE(numout,*) 'cc_biomass: ',circ_class_biomass(ipts,ivm,icir,:,icarbon)
+                   ENDDO
+                ENDIF
+             ENDIF
+
+          ELSE
+
+             ! I took this from stomate_growth_fun_all
+             max_height = biomass_to_lai(biomass(ipts,ivm,ileaf,icarbon),ivm)&
+                  * lai_to_height(ivm)
+
+             min_height = 0.0001_r_std ! arbitrary. Don't want it equal to zero because
+                                       ! it won't enter the correct loop below.
+
+             IF(ld_laieff)THEN
+                IF((ivm == test_pft) .AND. (ipts == test_grid))THEN
+                   WRITE(numout,*) 'This is the largest height of grasses/crops in z_level_photo'
+                   WRITE(numout,*) 'max_height, min_height: ',max_height,min_height
+                   WRITE(numout,*) 'lai_to_height: ',lai_to_height(ivm)
+                ENDIF
+             ENDIF
+
+          ENDIF
+
+          ! Loop over the levels used by the energy budget.  For each level, there are
+          ! six possibilities, based on the location of the canopy vis-a-vis the location
+          ! of this level height and the level above (if there is no level above, we take
+          ! a boundary that is equal to a very big number).
+          ! The word "slice" refers to the space between this level and the level above.
+          ! 1) Only the bottom part of the canopy is in this slice.
+          ! 2) Only the top part of the canopy is in this slice.
+          ! 3) The whole canopy is below this slice.
+          ! 4) The whole canopy is above this slice.
+          ! 5) The whole canopy is inside this slice.
+          ! 6) The top of the canopy is above the slice, the bottom is below the
+          !    slice, and we just have the middle part in the slice.
+          ! We adjust the photosynthesis levels in this slice to cover as much as the canopy as possible, assuming
+          ! a mininum distince between the levels.  This is done to avoid having a lot of levels with
+          ! very little LAI, which could cause a problem in the photosyntheis routines.
+          ! If there is too much LAI, the absorbed light saturates and we lose
+          ! sensitivity in the photosynthesis routines.  0.5 seems to be a good LAI
+          ! to have in a level, but this is just a feeling.
+
+          DO il=1,nlevels
+
+             lower_level_boundary=z_level(il)
+
+             ! The lowest photosynthesis level should always be equal to
+             ! the lower_level_boundary.  In this way we make sure that
+             ! we account for all the vegetation in this level.  We need
+             ! to make sure we don't overwrite this below.  This means that
+             ! the highest PS level in this level should always be at least
+             ! min_level_sep from the upper_boundary, and that instead of
+             ! nl_photo levels to play with, we only have nl_photo-1.  This
+             ! should not cause any divide by zero errors since there is
+             ! a loop at the beginning of the subroutine to handle the trivial
+             ! case where nl_photo=1.
+             z_level_photo(ipts,ivm,nl_photo*(il-1)+1)=lower_level_boundary
+
+             IF(il .NE. nlevels)THEN
+                upper_level_boundary=z_level(il+1)
+             ELSE
+                ! This number is arbitary, but it just needs to be larger than
+                ! the largest possible vegetation height.  10000 meters is a very
+                ! tall tree.
+                upper_level_boundary=10000.0_r_std
+             ENDIF
+
+             IF((min_height .GT. lower_level_boundary .AND. &
+                  min_height .LT. upper_level_boundary ) .AND. &
+                  (max_height .GT. upper_level_boundary))THEN
+                ! 1) This slice only has the bottom part of the canopy in it.
+                ! Ideally, we would want the second lowest PS level to be just
+                ! above the bottom of the canopy, and the highest PS level
+                ! to be just below the upper boundary.  If there is not
+                ! enough of the canopy to do this and maintain our
+                ! minimum level spacing, we just space the levels
+                ! with this minimum starting from just below the upper boundary.
+
+                ideal_level_thickness = ((upper_level_boundary-min_level_sep(ivm))-&
+                     (min_height+min_level_sep(ivm)))&
+                     /REAL(nl_photo-2,r_std)
+
+                IF(ideal_level_thickness .GT. min_level_sep(ivm))THEN
+                   ! It worked, the levels are thick enough.
+                   DO il_photo=nl_photo,2,-1
+                      z_level_photo(ipts,ivm,nl_photo*(il-1)+il_photo)=&
+                           (upper_level_boundary-min_level_sep(ivm))-&
+                           ideal_level_thickness*REAL(nl_photo-il_photo,r_std)
+                   ENDDO
+
+                ELSE
+
+                   ! Use the minimum level thickness starting from the 
+                   ! upper boundary.
+                   DO il_photo=nl_photo,2,-1
+                      z_level_photo(ipts,ivm,nl_photo*(il-1)+il_photo)=&
+                           (upper_level_boundary-min_level_sep(ivm))-&
+                           min_level_sep(ivm)*REAL(nl_photo-il_photo,r_std)
+                   ENDDO
+
+                ENDIF
+
+             ELSEIF(min_height .LT. lower_level_boundary .AND. &
+                  ((max_height .GT. lower_level_boundary) .AND. &
+                  (max_height .LT. upper_level_boundary)))THEN
+                ! 2) Only the top half of the canopy is in this slice.  We need
+                ! to do the same thing as case (1), but in the other direction.
+
+                ideal_level_thickness = ((max_height-min_level_sep(ivm))-&
+                     (lower_level_boundary+min_level_sep(ivm)))&
+                     /REAL(nl_photo-2,r_std)
+
+                IF(ideal_level_thickness .GT. min_level_sep(ivm))THEN
+                   ! It worked, the levels are thick enough.
+                   DO il_photo=2,nl_photo
+                      z_level_photo(ipts,ivm,nl_photo*(il-1)+il_photo)=&
+                           (lower_level_boundary+min_level_sep(ivm))+&
+                           ideal_level_thickness*REAL(il_photo-2,r_std)
+                   ENDDO
+
+                ELSE
+
+                   ! Use the minimum level thickness starting from the 
+                   ! upper boundary.
+                   DO il_photo=2,nl_photo
+                      z_level_photo(ipts,ivm,nl_photo*(il-1)+il_photo)=&
+                           (lower_level_boundary+min_level_sep(ivm))+&
+                           min_level_sep(ivm)*REAL(il_photo-2,r_std)
+                   ENDDO
+
+                ENDIF
+
+             ELSEIF((min_height .GT. upper_level_boundary) .OR. &
+                  (max_height .LT. lower_level_boundary) )THEN
+                ! (3) and (4) The whole canopy is below the slice, or the whole canopy
+                ! is above this slice.  Whatever we do does not
+                ! matter, since there is no LAI in the slice and therefore
+                ! there will be no PS.  
+
+                DO il_photo=2,nl_photo
+                   z_level_photo(ipts,ivm,nl_photo*(il-1)+il_photo)=lower_level_boundary+&
+                        min_level_sep(ivm)*REAL(il_photo-1,r_std)
+                ENDDO
+
+             ELSEIF((min_height .GT. lower_level_boundary) .AND. &
+                  (max_height .LT. upper_level_boundary) )THEN
+                ! (5) The whole canopy is inside this slice.  This is the trickiest
+                ! case, and unfortunately the most common.  In fact, it's the only
+                ! case which can exist with a single level energy budget.
+
+                ideal_level_thickness = ((max_height-min_level_sep(ivm))-&
+                     (min_height+min_level_sep(ivm)))&
+                     /REAL(nl_photo-2,r_std)
+
+                IF(ideal_level_thickness .GT. min_level_sep(ivm))THEN
+                   ! It worked, the levels are thick enough.
+                   DO il_photo=2,nl_photo
+                      z_level_photo(ipts,ivm,nl_photo*(il-1)+il_photo)=&
+                           (min_height+min_level_sep(ivm))+&
+                           ideal_level_thickness*REAL(il_photo-2,r_std)
+                   ENDDO
+
+                ELSE
+
+                   ! Here we have a block of min_level_sep levels.  Let's place the 
+                   ! center of this block in the center of our canopy, and check to see
+                   ! if the ends poke past the boundaries of this slice.
+
+                   block_thickness = REAL(nl_photo-2,r_std) * min_level_sep(ivm)
+                   canopy_thickness = (max_height - min_height )
+                   canopy_center = min_height + canopy_thickness / deux
+
+                   IF( ((canopy_center + block_thickness/deux) .LT. &
+                        (upper_level_boundary - min_level_sep(ivm))) .AND. &
+                        (canopy_center - block_thickness/deux) .GT. &
+                        (lower_level_boundary + min_level_sep(ivm)))THEN
+                      ! The block center can be placed at the center of the canopy, which means that
+                      ! the bottom of the block starts at canopy_center - block_thickness/2
+
+                      DO il_photo=2,nl_photo
+                         z_level_photo(ipts,ivm,nl_photo*(il-1)+il_photo)=&
+                              canopy_center - block_thickness/deux+&
+                              min_level_sep(ivm)*REAL(il_photo-2,r_std)
+                      ENDDO
+
+                   ELSEIF( (canopy_center - block_thickness/deux) .LE. &
+                        (lower_level_boundary + min_level_sep(ivm)))THEN
+                      ! we have enough space up, but not down, so move the whole block upwards.
+                      ! All we have to do is start the block above the lower boundary level.
+
+                      DO il_photo=2,nl_photo
+                         z_level_photo(ipts,ivm,nl_photo*(il-1)+il_photo)=&
+                              lower_level_boundary + &
+                              min_level_sep(ivm)*REAL(il_photo-1,r_std)
+                      ENDDO
+
+                   ELSEIF( (canopy_center + block_thickness/deux) .GE. &
+                        (upper_level_boundary - min_level_sep(ivm)))THEN
+                      ! we have enough space down, but not up, so move the whole block downwards
+                      ! All we need to do is start the block just below the upper boundary.
+
+                      DO il_photo=nl_photo,2,-1
+                         z_level_photo(ipts,ivm,nl_photo*(il-1)+il_photo)=&
+                              upper_level_boundary - &
+                              min_level_sep(ivm)*REAL(nl_photo-il_photo+1,r_std)
+                      ENDDO
+
+                   ELSE
+                      ! We should not be here!
+                      WRITE(numout,*) 'ERROR: In calculate_z_photo_level, we have reached a '
+                      WRITE(numout,*) 'ERROR: case that I have not foreseen!'
+                      WRITE(numout,*) 'ipts,ivm,il: ',ipts,ivm,il
+                      WRITE(numout,*) 'canopy_center: ',canopy_center
+                      WRITE(numout,*) 'block_thickness: ',block_thickness
+                      WRITE(numout,*) 'upper_level_boundary: ',upper_level_boundary
+                      WRITE(numout,*) 'lower_level_boundary: ',lower_level_boundary
+                      WRITE(numout,*) 'nl_photo: ',nl_photo
+
+                      CALL ipslerr_p (3,'calculate_z_level_photo', 'Unforeseen case.','','')
+
+                   ENDIF
+                ENDIF
+
+          ELSEIF((min_height .LT. lower_level_boundary) .AND. &
+               (max_height .GT. upper_level_boundary) )THEN
+             ! (6) This slice is completely filled by the canopy.  This is easy,
+             ! we just evenly space the levels in this slice.
+             
+             ideal_level_thickness = ((upper_level_boundary-min_level_sep(ivm))-&
+                  (lower_level_boundary+min_level_sep(ivm)))&
+                  /REAL(nl_photo-2,r_std)
+
+             DO il_photo=2,nl_photo
+                z_level_photo(ipts,ivm,nl_photo*(il-1)+il_photo)=&
+                     (lower_level_boundary+min_level_sep(ivm))+&
+                     ideal_level_thickness*REAL(il_photo-2,r_std)
+             ENDDO
+          
+          ELSE
+             ! Should not be here!  This is a case I haven't thought of.
+             WRITE(numout,*) 'Should not be here in find photosynthesis levels!'
+                WRITE(numout,*) 'ipts,ivm,il: ',ipts,ivm,il
+                WRITE(numout,*) 'max_height: ',max_height
+                WRITE(numout,*) 'min_height: ',min_height
+                WRITE(numout,*) 'upper_level_boundary: ',upper_level_boundary
+                WRITE(numout,*) 'lower_level_boundary: ',lower_level_boundary
+                CALL ipslerr_p (3,'calculate_z_level_photo', 'Unforeseen case in ps levels.','','')
+
+             ENDIF ! All the possible locations of the canopy with respect to
+                   ! the level boundaries.
+
+          ENDDO
+
+          IF(ld_laieff .AND. ivm == test_pft .AND. ipts == test_grid)THEN
+             WRITE(numout,*) 'Printing the level heights used by photosynthesis.'
+             WRITE(numout,*) 'ipts,ivm,max_height: ',ipts,ivm,max_height
+             DO il=1,nlevels_tot
+                WRITE(numout,*) 'il,z_level_photo(ipts,ivm,il): ',&
+                     il,z_level_photo(ipts,ivm,il)
+             ENDDO
+          ENDIF
+       ENDDO
+    ENDDO
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving calculate_z_level_photo'
+
+  END SUBROUTINE calculate_z_level_photo
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: combine_lai_levels
+!!
+!>\BRIEF        Collapses the LAI per photosynthesis level into an array
+!!              which only has the LAI per energy budget level.
+!!
+!! DESCRIPTION  : 
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::lai_per_level_temp
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART : None
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE combine_lai_levels(lai_per_level, lai_per_level_temp)
+
+  !! 0 Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+    
+    REAL(r_std),DIMENSION(:,:,:),INTENT(IN)        :: lai_per_level        !! The LAI per photosynthesis level
+                                                                           !! @tex $(m^{2} m^{-2})$
+
+
+    !! 0.2 Output variables
+    REAL(r_std),DIMENSION(:,:,:),INTENT(OUT)       :: lai_per_level_temp   !! The LAI per energy budget level
+                                                                           !! @tex $(m^{2} m^{-2})$
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER                                        :: il, ilevel           !! indices                        
+!_ ================================================================================================================================
+    
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering combine_lai_levels'
+
+    lai_per_level_temp(:,:,:)=zero
+
+    DO ilevel=1,nlevels_tot
+       il=CEILING(REAL(ilevel)/REAL(nlevels_photo))
+       lai_per_level_temp(:,:,il)=lai_per_level_temp(:,:,il)+lai_per_level(:,:,ilevel)
+    ENDDO
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving combine_lai_levels'
+
+  END SUBROUTINE combine_lai_levels
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: find_lai_per_level
+!!
+!>\BRIEF         Calculates the LAI per vertical level of the canopy.
+!!
+!! DESCRIPTION  :  Given a total biomass, number of individuals, size of individuals,
+!!                 and set of vertical layer boundaries, this routine calculates the
+!!                 the leaf area index (LAI) found between the layer boundaries.  It
+!!                 first makes a call to the stand structure in order to find out some
+!!                 canopy properties like height and canopy diameter, and then uses geometry
+!!                 to determine the amount of LAI present.
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::lai_per_level
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART : None
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE find_lai_per_level(npts, nlevels_loc, z_level_photo, &
+       biomass, circ_class_biomass, circ_class_n, lai_per_level)
+
+  !! 0 Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+    
+    INTEGER(i_std),INTENT(IN)                     :: npts               !! Domain size - number of pixels (unitless)
+    INTEGER(i_std),INTENT(IN)                     :: nlevels_loc        !! The number of levels we divide the LAI over (unitless)
+    REAL(r_std),DIMENSION(:,:,:),INTENT(IN)       :: z_level_photo      !! The height of the bottom of each of our levels @tex $(m)$ @endtex
+                                                                        !! Note that level 1 is closest to the ground
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(IN) :: circ_class_biomass !! Biomass of the componets of the model  
+                                                                        !! tree within a circumference
+                                                                        !! class @tex $(gC ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(IN)     :: circ_class_n       !! Number of trees within each circ class
+                                                                        !! class @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(IN)   :: biomass            !! Stand level biomass @tex $(gC m^{-2})$ @endtex
+
+    !! 0.2 Output variables
+    REAL(r_std), DIMENSION(:,:,:), INTENT(OUT)    :: lai_per_level      !! This is the LAI per vertical level
+                                                                        !! @tex $(m^{2} m^{-2})$ @endtex
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER                                            :: ipts, ivm, il, il_photo, &
+                                                          nlevels_loc_photo, icir !! indices
+    REAL(r_std)                                        :: max_height    !! The height of the tallest tree
+                                                                        !! @tex $(m)$ @endtex
+    REAL(r_std)                                        :: ind_loc       !! The number of individuals
+                                                                        !! @tex $(m^{-2})$ @endtex
+    REAL(r_std)                                        :: upper_boundary !! The top of the current level 
+                                                                         !! @tex $(m)$ @endtex
+    REAL(r_std)                                        :: lower_boundary !! The bottom of the current level 
+                                                                         !! @tex $(m)$ @endtex
+    REAL(r_std)                                        :: lai_temp      !! LAI of the current PFT/grid square
+                                                                        !! @tex $(m^{2} m^{-2})$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,ndist_types)  :: values        !! An array which holds various canopy parameters
+    REAL(r_std),DIMENSION(npts,nvm,nlevels_loc)        :: PartialCrownVolumeL !! The fraction of the crown volume found
+                                                                              !! in this level averaged over all circ classes
+                                                                              !! @tex $(m^{3})$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)  :: PartialCrownVolume_h  !! The fraction of the crown volume found
+                                                                                !! in this level for each circ class
+                                                                                !! @tex $(m^{3})$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm)                    :: CrownVolumeL  !! The average crown volume of the stand.
+                                                                        !! @tex $(m^3)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm)                    :: FAVD          !! Foliage area volume density
+                                                                        !! @tex $(m^2 (leaf) m^{-3})$ @endtex
+
+!_ ================================================================================================================================
+    
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering find_lai_per_level'
+
+    CALL derive_biomass_quantities(npts, nvm, ncirc, circ_class_n, &
+         circ_class_biomass, values)
+
+    PartialCrownVolumeL(:,:,:)=zero
+    PartialCrownVolume_h(:,:,:,:)=zero
+    CrownVolumeL(:,:)=zero
+    
+    DO ipts=1,npts
+       DO ivm=1,nvm
+
+          ! Skip all of this if we have no leaf biomass
+          IF(biomass(ipts,ivm,ileaf,icarbon) .LE. min_stomate)THEN
+             lai_per_level(ipts,ivm,:)=zero
+             CYCLE
+          ENDIF
+
+          ind_loc=SUM(circ_class_n(ipts,ivm,:))
+
+          IF(ind_loc .LT. min_stomate)THEN
+             WRITE(numout,*) 'How do we have biomass but no individuals?'
+             WRITE(numout,*) 'ipts,ivm: ',ipts,ivm
+             WRITE(numout,*) 'biomass(ipts,ivm,ileaf,icarbon),ind_loc: ',&
+                  biomass(ipts,ivm,ileaf,icarbon),ind_loc
+             CALL ipslerr_p (3,'find_lai_per_level', 'Biomass but no individuals.','','')
+          ENDIF
+
+          CALL calculate_favd(ipts,ivm, values(ipts,ivm,:,icnvol), circ_class_biomass, &
+               circ_class_n, biomass, favd)
+
+          ! Find the LAI of this PFT.
+          lai_temp = biomass_to_lai(biomass(ipts,ivm,ileaf,icarbon), ivm)
+         
+
+          ! This is done differently for forests and grass/crops, since grass
+          ! and crops will not have a canopy volume.  We just assume a solid
+          ! block of vegetation with a given height.
+
+          IF(is_tree(ivm))THEN
+
+             IF(ld_laieff .AND. test_pft == ivm .AND. ipts == test_grid)&
+                  WRITE(6,*) 'On tree ',ivm,lai_temp,favd(ipts,ivm)
+
+             max_height = MAXVAL(values(ipts,ivm,:,iheight))
+
+             ! We need to integrate over the height distribution. This is just a
+             ! simple rectangular integration, and it gives us the average crown
+             ! volume for the whole stand.
+             DO icir=1,ncirc
+                CrownVolumeL(ipts,ivm)=CrownVolumeL(ipts,ivm)+&
+                     values(ipts,ivm,icir,icnvol)*&
+                     circ_class_n(ipts,ivm,icir)/ind_loc
+                IF(test_pft == ivm .AND. ld_laieff .AND. ipts == test_grid)THEN
+                   WRITE(numout,*) 'Volume for icir: ',icir,values(ipts,ivm,icir,icnvol)
+                ENDIF
+             ENDDO
+
+             ! Now I need to find the average crown volume per layer.  This is not the
+             ! same thing as taking the average crown volume and dividing it up
+             ! over the layers, since the crowns are at different heights.
+
+             DO il=1,nlevels_loc
+                
+                IF(il .NE. nlevels_loc)THEN
+                   upper_boundary=z_level_photo(ipts,ivm,il+1)
+                ELSE
+                   ! This height is arbitrary.  It just has to include the whole canopy.
+                   upper_boundary=z_level_photo(ipts,ivm,nlevels_loc)+max_height
+                ENDIF
+                lower_boundary=z_level_photo(ipts,ivm,il)
+
+                ! For this level, how much of each canopy is here?  We will also
+                ! integrate this value over the whole height distribution, thus
+                ! finding the average canopy volume in this layer.
+                DO icir=1,ncirc
+
+                   PartialCrownVolume_h(ipts,ivm,icir,il)=&
+                        partial_spheroid_vol(upper_boundary, lower_boundary, &
+                        values(ipts,ivm,icir,icndiaver)/deux, &
+                        values(ipts,ivm,icir,icndiahor)/deux, &
+                        values(ipts,ivm,icir,iheight))
+                    IF(ld_laieff .AND. test_pft == ivm .AND. test_grid == ipts)THEN
+                       WRITE(numout,*) 'ipts,ivm,icir,il: ',ipts,ivm,icir,il
+                       WRITE(numout,*) 'PartialCrownVolume_h(ipts,ivm,icir,il): ',&
+                         PartialCrownVolume_h(ipts,ivm,icir,il)
+                       WRITE(numout,*) 'crown diameter: ', values(ipts,ivm,icir,icndiaver)
+                       WRITE(numout,*) 'tree height: ', values(ipts,ivm,icir,iheight)
+                       WRITE(numout,*) 'circ_class_n(ipts,ivm,icir)',circ_class_n(ipts,ivm,icir)
+                    ENDIF
+
+                    ! It's important to note here that the units of PartialCrownVolume_h
+                    ! are m**3/tree, since the canopy properties that we passed to
+                    ! partial_spheroid_vol are also per tree.  We need to get it in
+                    ! m**3/m**2 (land area).
+                   
+                    PartialCrownVolumeL(ipts,ivm,il)=PartialCrownVolumeL(ipts,ivm,il)+&
+                         PartialCrownVolume_h(ipts,ivm,icir,il)*&
+                         circ_class_n(ipts,ivm,icir)
+
+                END DO
+
+                ! Now I have the average crown volume per level.  I also have
+                ! the foliage area volume density.  The amount of LAI in this
+                ! level is just the combination of the two.
+                lai_per_level(ipts,ivm,il)=PartialCrownVolumeL(ipts,ivm,il)*&
+                     FAVD(ipts,ivm)
+
+             ENDDO
+
+              IF(ld_laieff .AND. ipts == test_grid .AND. ivm == test_pft)THEN
+                 WRITE(numout,*) 'CrownVolumeL: ',CrownVolumeL(ipts,ivm)
+              ENDIF
+
+          ELSE
+
+             ! For grasses and crops.
+
+             ! This is not ideal, since we already had to calculate lai_temp 
+             ! and max_height to find the FAVD.  If there is a speed problem,
+             ! we can change it.
+
+             ! What is the height of our grass/crop?
+       
+             ! This converts LAI to a height.  I took this from functional_allocation.
+             max_height = lai_temp * lai_to_height(ivm)
+
+
+             ! Find out how much of this vegetation cube is in this layer
+             ! These calculations here include some implict factors of 
+             ! m**2/m**2, so be aware of that when calculating the levels.
+             ! All heights are multiplied by 1x1 m to find a volume, but
+             ! that is not explictly shown.
+             DO il=1,nlevels_loc
+
+                IF(il .NE. nlevels_loc)THEN
+                   upper_boundary=z_level_photo(ipts,ivm,il+1)
+                ELSE
+                   ! This height is arbitrary.  It just has to include the whole canopy.
+                   upper_boundary=z_level_photo(ipts,ivm,nlevels_loc)+max_height
+                ENDIF
+                lower_boundary=z_level_photo(ipts,ivm,il)
+
+                IF(max_height .GE. upper_boundary)THEN
+                   ! This whole level is full of vegetation.
+                   lai_per_level(ipts,ivm,il)=&
+                        (upper_boundary-lower_boundary)*FAVD(ipts,ivm)
+
+                ELSEIF(max_height .LE. lower_boundary)THEN
+
+                   ! There is no vegetation in this level.
+                   lai_per_level(ipts,ivm,il)=zero
+
+                ELSE
+                   
+                   ! This level is partially full.
+                   lai_per_level(ipts,ivm,il)=&
+                        (max_height-lower_boundary)*FAVD(ipts,ivm)
+
+                ENDIF ! checking where max_height is
+
+             ENDDO
+
+          ENDIF
+
+          IF(test_pft == ivm .AND. test_grid == ipts .AND. ld_laieff)THEN
+             WRITE(numout,*) 'LAI per level: ',ipts,ivm
+             DO il=nlevels_loc,1,-1
+                WRITE(numout,*) 'il,lai_per_level(ipts,ivm,il): ',&
+                     il,lai_per_level(ipts,ivm,il)
+             ENDDO
+          ENDIF
+
+          ! Test to see if our LAI is equal to the sum over all the levels.
+          IF( ABS(lai_temp - SUM(lai_per_level(ipts,ivm,:))) &
+               .GT. 1e-5)THEN
+             WRITE(numout,*) '!*****************************************************'
+             WRITE(numout,*) 'Problem in LAI levels! '
+             WRITE(numout,*) 'ipts,ivm: ',ipts,ivm
+             WRITE(numout,*) 'lai_temp, SUM(lai_per_level(ipts,ivm,:)): ',&
+                  lai_temp,SUM(lai_per_level(ipts,ivm,:))
+             DO il=nlevels_loc,1,-1
+                WRITE(numout,*) 'il,lai_per_level(ipts,ivm,il): ',&
+                     il,lai_per_level(ipts,ivm,il)
+             ENDDO
+             ! There can be issues using the functions in the print statements.  If a print 
+             ! statement in a function is activated when the function call itself is in a print
+             ! statement, there is a crash.
+             WRITE(numout,*) 'Check whether canopy dimensions exceed the height '
+!             WRITE(numout,*) 'diameter, ', wood_to_dia(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)
+             WRITE(numout,*) 'diameter, ', values(ipts,ivm,:,idiameter)
+!             WRITE(numout,*) 'height: ', wood_to_height(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)  
+             WRITE(numout,*) 'height: ', values(ipts,ivm,:,iheight)
+!             WRITE(numout,*) 'crown area: ', wood_to_cn(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)
+             WRITE(numout,*) 'crown area: ', values(ipts,ivm,:,icnarea)
+!             WRITE(numout,*) 'crown diameter: ', (4./pi*wood_to_cn(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm))**(1./2.)
+             WRITE(numout,*) 'crown diameter - ver: ', values(ipts,ivm,:,icndiaver)
+             WRITE(numout,*) 'crown diameter - hor: ', values(ipts,ivm,:,icndiahor)
+             WRITE(numout,*) 'crown volume: ', values(ipts,ivm,:,icnvol)
+             WRITE(numout,*) 'crown diameter used in this routine: ', (6./pi*values(ipts,ivm,:,icnvol))**(1./3.) 
+             WRITE(numout,*) '!*****************************************************'
+             CALL ipslerr_p (3,'find_lai_per_level', 'Inconsistency with LAI in levels.','','')
+          ENDIF ! check to see if the LAI per level is consistent with the total LAI
+
+
+       ENDDO ! loop over PFTs
+    ENDDO ! loop over points
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving find_lai_per_level'
+
+  END SUBROUTINE find_lai_per_level
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: fitting_laieff
+!!
+!>\BRIEF          Fits the effective LAI as a function of the solar angle    
+!!
+!! DESCRIPTION  :  Calculation of the effective LAI is a very expensive part of the
+!!                 model, due to the loops over points, PFTs, circ classes, and levels,
+!!                 in addition to using trig functions.  We need this value at
+!!                 every time step (up to 48 times a day).  Thankfully, the function
+!!                 doesn't change a lot, in particular when the sun is high in the sky.
+!!                 Therefore, we will calculate a few points exactly, and then fit
+!!                 a function to these points to predict the value of the LAIeff at any
+!!                 solar angle.  This method seems to work well for low solar zenith
+!!                 angles, which are the most important since they will have the most
+!!                 incoming solar radiation.
+!!
+!!    NOTE:
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::laieff_fit
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART : None
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE fitting_laieff(npts, nlevels_loc, z_level_photo, circ_class_biomass, &
+       circ_class_n, veget_max, biomass, lai_per_level, laieff_fit)
+
+  !! 0 Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+    
+    INTEGER(i_std),INTENT(IN)                            :: npts           !! Domain size - number of pixels (unitless)
+    INTEGER(i_std),INTENT(IN)                            :: nlevels_loc    !! The number of vertical levels
+    REAL(r_std),DIMENSION(:,:,:),INTENT(IN)              :: z_level_photo  !! the height of the bottom of each of our levels 
+                                                                           !! @tex $(m)$ @endtex
+                                                                           !! note that level 1 is closest to the ground
+    REAL(r_std), DIMENSION(:,:,:,:,:), &
+         INTENT(IN)                                      :: circ_class_biomass  !! Biomass of the componets of the model  
+                                                                                !! tree within a circumference class
+                                                                                !! @tex $(gC ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(IN)            :: circ_class_n   !! Number of trees within each circ class
+                                                                           !! @tex $(m^{-2})$ @endtex
+    REAL(r_std),DIMENSION(:,:),INTENT(IN)                :: veget_max      !! Maximum fraction of vegetation type including 
+                                                                           !! non-biological fraction (unitless)
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(IN)          :: biomass        !! Stand level biomass 
+                                                                           !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(IN)            :: lai_per_level  !! This is the LAI per vertical level
+                                                                           !! @tex $(m^{2} m^{-2})$
+    !! 0.2 Output variables
+    TYPE(laieff_type),DIMENSION (:,:,:),INTENT(OUT)      :: laieff_fit      !! Fitted parameters for the effective LAI
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    ! Idealy, the next two values would be externalised.
+    INTEGER,PARAMETER                                    :: nangles=8 ! the number of angles to fit the parameterization of
+                                                   ! the effective LAI. 
+!    REAL(r_std),DIMENSION(nangles),PARAMETER  :: param_angles = (/ 0.1, 30.0, 60.0, 89.9 /) ! the angles to
+    REAL(r_std),DIMENSION(nangles)  :: param_angles ! the angles to
+!    REAL(r_std),DIMENSION(nangles) :: param_angles 
+                                            ! parameterize for...EXTERNALIZE
+
+    REAL(r_std),DIMENSION(nlevels_tot,npts,nvm,nangles)  :: laieff       !! Leaf Area Index Effective converts 3D lai into 
+                                                                         !! 1D lai for two stream radiation transfer model
+                                                                         !! @tex $(m^{2} m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(npts)                         :: solar_angle  !! The solar zenith angle of every grid square 
+                                                                         !! @tex $(rad)$ @endtex 
+    INTEGER(i_std)                                       :: ilevel, ipts, icir, ivm, &
+                                                            iangle, jangle !! index (unitless)
+
+    INTEGER(i_std)                                       :: nzero        !! Counter to keep track of the number of
+                                                                         !! LAIeff with value zero
+    INTEGER(i_std)                                       :: temp_index   !! An index which allows us to fit only non-zero
+                                                                         !! values
+    REAL(r_std),DIMENSION(npts)                          :: test_angles  !! Converts the param_angles (degrees) into radians
+                                                                         !! @tex $(rad)$ @endtex 
+!_ ================================================================================================================================
+    
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering fitting_laieff'
+
+    ! We want to parameterize the effective LAI as a function of
+    ! the solar zenith angle for every level, grid square, and
+    ! PFT type.  Let's choose a series of angles to use.
+    ! There are somtimes numerical issues with using exactly
+    ! 90 degrees or exactly 0 degrees.
+
+!    param_angles = (/ 5.0, 15.0, 25.0, 35.0, 45.0, 55.0, 65.0, 75.0, 85.0 /)
+    ! Using high SZA (near the horizon) seems to cause problems
+    ! with the fitting, as strange behavior happens there.  Since there
+    ! is not a lot of light, let's use smaller values.
+    param_angles = (/ 5.0, 15.0, 25.0, 35.0, 45.0, 55.0, 65.0, 75.0 /)
+
+
+    ! Right now, I'm doing this the brute force way.  It will probably
+    ! need to be refined later.
+
+    DO iangle=1,nangles
+       test_angles(:)=COS(param_angles(iangle)/180.0*pi)
+       IF(ld_laieff)&
+            WRITE(numout,*) 'Calculating for test angle: ',param_angles(iangle)
+       CALL effective_lai(npts, nlevels_loc, z_level_photo,  circ_class_biomass, &
+            circ_class_n, veget_max, test_angles, biomass, lai_per_level,&
+            laieff(:,:,:,iangle))
+       IF(ld_laieff)THEN
+          DO ipts=1,npts
+             DO ivm=1,nvm
+                IF(ipts == test_grid .AND. ivm == test_pft)THEN
+                   WRITE(numout,*) 'LAIEFF for angle ',param_angles(iangle)
+                   DO ilevel=nlevels_tot,1,-1
+                      WRITE(numout,*) ilevel,laieff(ilevel,ipts,ivm,iangle)
+                   ENDDO
+                ENDIF
+             ENDDO
+          ENDDO
+       ENDIF
+    ENDDO
+
+    param_angles(:)=COS(param_angles(:)/180.0_r_std*pi)
+
+    ! Now we have all the data points, so we can fit the function.
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          DO ilevel=1,nlevels_loc
+
+             ! The 0.001 is completely arbitrary here.
+             IF(SUM(laieff(ilevel,ipts,ivm,:)) .GT. 0.001_r_std )THEN
+
+                ! We have a choice to make.  Sometimes the laieff for highest zenith angles
+                ! will be zero, even if the previous points were not.  This seems to happen
+                ! when no light gets through, which is normal for lower vegetation
+                ! levels as the sun gets closer to the horizon.  The pattern of points is
+                ! something like 1,1,1,1,1,1.9,4.0,0.0.  This causes a problem for
+                ! fitting, and we don't care too much about this largest angle.  If we
+                ! can fit the first points well, and the last point is greater than 4.0, 
+                ! we will probably be okay since there is not a lot of sunlight wen the
+                ! sun is near the horizon in any case.  So let's run a test.
+                IF(laieff(ilevel,ipts,ivm,nangles) .LT. min_stomate)THEN
+
+                   ! We know that the sum of all elements is greater than our cutoff
+                   ! above, so we need to find the final substantial element.
+                   ! Count backwards to see how many zero elements we have
+                   ! at the end.
+                   nzero=1
+                   DO iangle=nangles-1,1,-1
+                      IF(laieff(ilevel,ipts,ivm,iangle) .LT. min_stomate)THEN
+                         nzero=nzero+1
+                      ELSE
+                         EXIT
+                      ENDIF
+                   ENDDO
+                   
+                   IF(nzero .GE. nangles)THEN
+                      WRITE(numout,*) 'ERROR: Something went wrong in fitting the laieff!'
+                      WRITE(numout,*) 'ipts,ivm,ilevel: ',ipts,ivm,ilevel
+                      WRITE(numout,*) 'nzero,nangles: ',nzero,nangles
+                      WRITE(numout,*) 'laieff(ilevel,ipts,ivm,:): ',laieff(ilevel,ipts,ivm,:)
+                      CALL ipslerr_p (3,'fitting_laieff', 'All zero values in the fit.','','')
+                   ENDIF
+
+                   ! This three is also arbitrary.
+                   IF(nzero .GE. 3)THEN
+                      WRITE(numout,*) 'ERROR: A surprising number of zero values in laieff!'
+                      WRITE(numout,*) 'ipts,ivm,ilevel: ',ipts,ivm,ilevel
+                      WRITE(numout,*) 'nzero,nangles: ',nzero,nangles
+                      WRITE(numout,*) 'laieff(ilevel,ipts,ivm,:): ',laieff(ilevel,ipts,ivm,:)
+                      CALL ipslerr_p (3,'fitting_laieff', 'Too many zero values in the fit.','','')
+                   ENDIF
+
+                   ! Only use the first non-zero values for the fitting
+                   temp_index=nangles-nzero
+                   CALL fit_laieff_to_points(temp_index,param_angles(1:temp_index),&
+                        laieff(ilevel,ipts,ivm,1:temp_index), &
+                        laieff_fit(ipts,ivm,ilevel),ipts,ivm,ilevel)
+                ELSE
+                   CALL fit_laieff_to_points(nangles,param_angles,laieff(ilevel,ipts,ivm,:), &
+                        laieff_fit(ipts,ivm,ilevel),ipts,ivm,ilevel)
+                ENDIF
+
+             ELSE
+
+                ! Not enough vegetation to fit it.  Everything is zero.
+                laieff_fit(ipts,ivm,ilevel)%a=zero
+                laieff_fit(ipts,ivm,ilevel)%b=zero
+                laieff_fit(ipts,ivm,ilevel)%c=zero
+                laieff_fit(ipts,ivm,ilevel)%d=zero
+                laieff_fit(ipts,ivm,ilevel)%e=zero
+             ENDIF
+          END DO
+       ENDDO
+    ENDDO
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving fitting_laieff'
+
+  END SUBROUTINE fitting_laieff
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: fit_laieff_to_points
+!!
+!>\BRIEF        
+!!
+!! DESCRIPTION  : 
+!!
+!!    NOTE:
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::laieff_fit
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART : None
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE fit_laieff_to_points(nangles, test_angles, laieff, laieff_fit, ipts, ivm, ilevel)
+
+  !! 0 Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+    
+    INTEGER(i_std),INTENT(IN)                            :: nangles   !! The number of angles (data points)
+    INTEGER(i_std),INTENT(IN)                            :: ipts      !! The grid square
+    INTEGER(i_std),INTENT(IN)                            :: ivm       !! The PFT number
+    INTEGER(i_std),INTENT(IN)                            :: ilevel    !! The canopy level
+    REAL(r_std),DIMENSION(:),INTENT(IN)        :: test_angles         !! the cosine of the solar angles
+    REAL(r_std),DIMENSION(:),INTENT(IN)        :: laieff              !! the laieff at each of these angles
+
+    !! 0.2 Output variables
+    TYPE(laieff_type),INTENT(out)    :: laieff_fit      !! Fitted parameters for the effective LAI
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std)   :: x,y,one,x2,x3,x4,x5,x6,x7,x8,xy,x2y,x3y,x4y
+    INTEGER  :: iangle
+    REAL(r_std),DIMENSION(5) :: vector_b
+    REAL(r_std),DIMENSION(5,5) :: matrix_a
+    REAL(r_std) :: mean,sse,sst,r_corr, max_diff, diff
+
+!_ ================================================================================================================================
+    
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering fit_laieff_to_points'
+
+    ! We have a set of angles, test_angles.  We also have the
+    ! effective LAI for each of these angles.  The structure
+    ! laieff_fit gives the parameters and functional form.
+    ! If you wish to change the functional form, you need to 
+    ! change this routine, the lai_type, and the function
+    ! below which evaluates the LAIeff as a function of
+    ! the angle.
+    
+    ! We are going to use a least squares method to fit a parabola
+    ! of the form a+b*x+c*x**2+d*x**3+e*x**4.  This means we will need to solve
+    ! a system of linear equations, A x = b.
+    ! In this notation, y is the sum over all angles for the laieff,
+    ! x is the sum for the angles, x2 is the sum of the square of the
+    ! angles, etc.
+
+    y=zero
+    xy=zero
+    x2y=zero
+    x3y=zero
+    x4y=zero
+    one=zero
+    x=zero
+    x2=zero
+    x3=zero
+    x4=zero
+    x5=zero
+    x6=zero
+    x7=zero
+    x8=zero
+    DO iangle=1,nangles
+           y=y+laieff(iangle)
+           xy=xy+test_angles(iangle)*laieff(iangle)
+           x2y=x2y+test_angles(iangle)**2*laieff(iangle)
+           x3y=x3y+test_angles(iangle)**3*laieff(iangle)
+           x4y=x4y+test_angles(iangle)**4*laieff(iangle)
+           x=x+test_angles(iangle)
+           x2=x2+test_angles(iangle)**2
+           x3=x3+test_angles(iangle)**3
+           x4=x4+test_angles(iangle)**4
+           x5=x5+test_angles(iangle)**5
+           x6=x6+test_angles(iangle)**6
+           x7=x7+test_angles(iangle)**7
+           x8=x8+test_angles(iangle)**8
+    ENDDO
+    one=REAL(nangles)
+
+    ! Now we create our system of equations.
+    vector_b(1:5) = (/ y, xy, x2y, x3y, x4y /)
+    ! From what I see in the gauss_jordan routine, the format is
+    ! matrix(row, column), which matches standard notation. In this
+    ! case the matrix is symmetric, anyway.
+    matrix_a(1,1:5) = (/ one,  x, x2, x3, x4 /) 
+    matrix_a(2,1:5) = (/   x, x2, x3, x4, x5 /) 
+    matrix_a(3,1:5) = (/  x2, x3, x4, x5, x6 /)
+    matrix_a(4,1:5) = (/  x3, x4, x5, x6, x7 /)
+    matrix_a(5,1:5) = (/  x4, x5, x6, x7, x8 /)
+
+    ! TEST... should give -2, 3, 1...it does
+!    matrix_a(1,1:3) = (/  -3, 2, -6 /) 
+!    matrix_a(2,1:3) = (/  5, 7, -5 /) 
+!    matrix_a(3,1:3) = (/  1, 4, -2 /)
+!    vector_b(1:3) = (/ 6, 6, 8 /)
+
+    CALL gauss_jordan_method(SIZE(vector_b),matrix_a,vector_b)
+
+    ! These are our parameters.
+    laieff_fit%a=vector_b(1)
+    laieff_fit%b=vector_b(2)
+    laieff_fit%c=vector_b(3)
+    laieff_fit%d=vector_b(4)
+    laieff_fit%e=vector_b(5)
+
+    !++++++ CHECK ++++++++
+    !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+    ! These are some checks that we do to make sure our fitting
+    ! is decent.  I'm going to leave these on during parameterization,
+    ! but we might want to remove it during the real runs.  Things
+    ! should be tested well before then, and it will only be freak
+    ! chance that causes it to fail afterwards.  If this happens
+    ! on one day in one hundred years, we don't care so much.
+
+    ! Calculate a regression coefficienct
+    sst=zero
+    sse=zero
+    mean=zero
+    DO iangle=1,nangles
+       mean=mean+laieff(iangle)
+    ENDDO
+    mean=mean/REAL(nangles)
+    max_diff=zero
+    DO iangle=1,nangles
+       sst=sst+(laieff(iangle)-mean)**2
+       diff=laieff(iangle)-calculate_laieff_fit(test_angles(iangle),laieff_fit)
+       sse=sse+diff**2
+       IF(diff .GT. max_diff) max_diff=diff
+    ENDDO
+
+    IF(sse .GT. sst)THEN
+       r_corr = zero
+    ELSEIF(sst .EQ. zero)THEN
+       r_corr = zero
+    ELSE
+       r_corr=SQRT(un-sse/sst)
+    ENDIF
+    IF(ld_laieff .AND. (ipts == test_grid) .AND. (ivm == test_pft)) &
+         WRITE(numout,*) 'Regression coefficient: ',r_corr
+
+    IF(r_corr .LT. 0.95)THEN
+
+       ! Sometimes the correlation coefficient is not great, but the difference
+       ! in the values is really small.  We don't care so much if our values
+       ! are off by 0.001.
+       IF(ld_laieff .AND. (ipts == test_grid) .AND. (ivm == test_pft)) &
+            WRITE(numout,*) 'max_diff ',max_diff
+       IF(max_diff .GT. 0.01)THEN
+          WRITE(numout,*) 'Difference is too big for fitting!'
+          WRITE(numout,*) 'max_diff ',max_diff
+          WRITE(numout,*) 'r_corr ',r_corr
+          WRITE(numout,*) 'ipts,ivm,ilevel: ',ipts,ivm,ilevel
+          WRITE(numout,*) 'COS(angle)     Real value       Fitted value'
+          DO iangle=1,nangles
+             WRITE(1600,'(10F20.10)') test_angles(iangle),&
+                  laieff(iangle),calculate_laieff_fit(test_angles(iangle),laieff_fit)
+             WRITE(numout,'(10F20.10)') test_angles(iangle),&
+                  laieff(iangle),calculate_laieff_fit(test_angles(iangle),laieff_fit) 
+          ENDDO
+          CALL ipslerr_p (3,'fitting_laieff', 'Difference is too big for fitting.','','')
+       ENDIF
+    ENDIF
+    !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+    ! Some debugging information
+    IF(ld_laieff .AND. (ivm == test_pft) .AND. (ipts == test_grid))THEN
+       ! Let's see how closely they match
+       DO iangle=1,nangles
+          IF(SUM(laieff(:)) .GT. 0.1 )THEN
+             WRITE(numout,*) 'TESTING fitting LAIEFF ',ipts,ivm,ilevel
+             WRITE(numout,'(10F16.8)') test_angles(iangle),&
+                  laieff(iangle),calculate_laieff_fit(test_angles(iangle),laieff_fit)
+          ENDIF
+       ENDDO
+    ENDIF
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving fit_laieff_to_points'
+
+  END SUBROUTINE fit_laieff_to_points
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: effective_lai
+!!
+!>\BRIEF        Calculate effective lai for the 1-D two stream 
+!! radiative canopy transfer model
+!!
+!! DESCRIPTION  : The effective LAI is computed to be used with the two-stream
+!!    albedo model described by Pinty 2006, by using an equation in Pinty 2004
+!!    and the Pgap method of Haverd et al...code was taken from the latter group
+!!    and cleaned up and reformatted...these routines were valided against the original
+!!    code and gave identical results for Pgap (the original code was single precision, while
+!!    these results are double precision):
+!!
+!!    NOTE:
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::laieff, ::Pgap_out
+!!
+!! REFERENCE(S) : Pinty et al; Simplifying the interaction of land surfaces 
+!!   with radiation for relating remote sensing products to climate models
+!!   JOURNAL OF GEOPHYSICAL RESEARCH, VOL. 111, D02116, doi:10.1029/2005JD005952, 2006
+!!
+!!                Pinty et al; Synergy between 1-D and 3-D radiation transfer models
+!!   to retrieve vegetation canopy properties from remote sensing data
+!!   JOURNAL OF GEOPHYSICAL RESEARCH, VOL. 109, D21205, doi:10.1029/2004JD005214, 2004
+!!
+!!                Haverd et al; The Canopy Semi-analytic Pgap and radiative transfer 
+!!   (CanSPART) model: Formulation and application
+!!   AGRICULTURAL AND FOREST METEOROLOGY, VOL. 160, pp. 14-35, 2012
+!!
+!! FLOWCHART : None
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE effective_lai(npts, nlevels_loc, z_level_loc,  circ_class_biomass, &
+       circ_class_n, veget_max, sinang, biomass, lai_per_level, laieff, Pgap_out)
+
+  !! 0 Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+    
+    INTEGER(i_std),INTENT(IN)                      :: npts                  !! Domain size - number of pixels (unitless)
+    INTEGER(i_std),INTENT(IN)                      :: nlevels_loc           !! The number of physical levels over which we
+                                                                            !! we will calculate the gap probability.
+    REAL(r_std),DIMENSION(:,:,:),INTENT(IN)        :: z_level_loc           !! the height of the bottom of each of our levels @tex $(m)$ @endtex
+                                                                            !! note that level 1 is closest to the ground
+    REAL(r_std), DIMENSION(:,:,:,:,:), &
+         INTENT(IN)                                :: circ_class_biomass    !! Biomass of the componets of the model  
+                                                                            !! tree within a circumference
+                                                                            !! class @tex $(gC ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(IN)      :: circ_class_n          !! Number of trees within each circ class
+                                                                            !! class @tex $(m^{-2})$ @endtex
+    REAL(r_std),DIMENSION(:,:),INTENT(IN)          :: veget_max             !! Maximum fraction of vegetation type including 
+                                                                            !! non-biological fraction (unitless)
+    REAL(r_std), DIMENSION(:), INTENT(in)          :: sinang                !! the cosine of the view zenith angle
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(in)    :: biomass               !! Stand level biomass @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)      :: lai_per_level         !! This is the LAI per vertical level
+                                                                            !! @tex $(m^{2} m^{-2})$
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION(:,:,:),INTENT(OUT)       :: laieff                !! Leaf Area Index Effective converts 3D lai into 
+                                                                            !! 1D lai for two stream radiation transfer model
+                                                                            !! @tex $(m^{2} m^{-2})$ @endtex 
+    REAL(r_std),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL  &
+                                                   :: pgap_out              !! The transmission probabilility of light through 
+                                                                            !! the canopy.  This is per level, not cumulative.
+                                                                            !! (unitless, between 0 and 1) 
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    REAL(r_std), DIMENSION(npts)                   :: solar_angle           !! the view angle of every grid square (radians)
+    INTEGER(i_std)                                 :: ilevel, ipts, icir    !! index (unitless)
+    INTEGER(i_std)                                 :: ivm, jlevel           !! index (unitless)
+    INTEGER(i_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)   &
+                                                   :: upward_array          !! Flag to indicate if the view angle is pointing
+                                                                            !! upwards (1) or downwards (0). (unitless)
+ 
+    ! These next values need a bit of caution with the units.  Since they are derived
+    ! from circ_class_biomass, it seems they have units per land area, in
+    ! addition to the units given here.
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)      &
+                                                   :: ver_axis_array        !! The veritical diameter of the tree canopy.
+                                                                            !! @tex $(m)$ @endtex 
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)      &                
+                                                   :: hor_axis_array        !! The horizontal diameter of the tree canopy.
+                                                                            !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)      &                
+                                                   :: h_array               !! Height to the top of the tree canopy.
+                                                                            !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)      &                
+                                                   :: z_array               !! Height above soil of the Pgap points.
+                                                                            !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,nlevels_loc)            &                
+                                                   :: z_array2              !! Same as z_array, but one less dimension.
+                                                                            !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)      &
+                                                   :: crown_shadow_h        !! The projected shadow of an opaque crown.
+                                                                            !! @tex $(m^2)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)      &
+                                                   :: trunk_shadow_h        !! The projected shadow of the trunk.
+                                                                            !! @tex $(m^2)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)      &
+                                                   :: crown_area_h          !! The area of a horizontal plane cutting
+                                                                            !! through the crown.
+                                                                            !! @tex $(m^2)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)      &
+                                                   :: sbar_h                !! The mean free distance through the crown
+                                                                            !! along the path dictated by the view angle.
+                                                                            !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)      &
+                                                   :: ph_array              !! The height of the top of the canopy.
+                                                                            !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)      &
+                                                   :: FAVD_array            !! The foliage area volume density of
+                                                                            !! the canopy.
+                                                                            !! @tex $(LAI m^{-3})$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)      &
+                                                   :: DBH_array             !! Trunk diameter at breast height.
+                                                                            !! @tex $(m)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)      &
+                                                   :: G_array               !! The mean horizontal projection of
+                                                                            !! unit leaf area (leaf orientation function).
+                                                                            !! @tex $(m^{-2})$ @endtex
+    ! These next two values are not currently used since we set G=0.5
+!!$    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)      &
+!!$                                                   :: thetaL_mean_array
+!!$    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)      &
+!!$                                                   :: thetaL_sd_array
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,nlevels_loc)      &
+                                                   :: Pwc_h                 !! Crown porosity.
+                                                                            !! (unitless)
+    REAL(r_std),DIMENSION(npts,nvm,nlevels_loc)    :: TrunkShadowL          !! Trunk shadow, integrated over the population.
+                                                                            !! @tex $(m^2 m^{-2})$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,nlevels_loc)    :: CrownAreaL            !! The area of a horizontal plane cutting
+                                                                            !! through the crown, averaged over population.
+                                                                            !! @tex $(m^2 m^{-2})$ @endtex
+!    REAL(r_std),DIMENSION(npts,nvm,nlevels_loc)    :: Pbc_trunkL
+    REAL(r_std),DIMENSION(npts,nvm,nlevels_loc)    :: PorousCrownShadowL    !! The average shadow cast by a tree taking
+                                                                            !! into account porosity.
+                                                                            !! @tex $(m^2)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm,nlevels_loc)    :: PgapL                 !! The probability of finding a gap in the
+                                                                            !! in the canopy.
+                                                                            !! (unitless)
+    REAL(r_std),DIMENSION(npts,nvm,ncirc)          :: CrownVolume_h         !! The crown volume of a circ class.
+                                                                            !! @tex $(m^3)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm)                :: CrownVolumeL          !! The average crown volume of the stand.
+                                                                            !! @tex $(m^3)$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm)                :: FAVD                  !! The foliage area volume density of
+                                                                            !! the canopy.
+                                                                            !! @tex $(LAI m^{-3})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)               :: ind_loc               !! Density of individuals
+                                                                            !! @tex $(m^{-2})$ @endtex
+    ! The following two variables are ways to speed up the calculation
+    ! by not trying to calculate everything, based on if we have
+    ! biomass or individuals for this PFT on the grid square
+    LOGICAL, DIMENSION(npts,nvm)                   :: lcalculate_tree       !! For trees
+    LOGICAL, DIMENSION(npts,nvm)                   :: lcalculate_nontree    !! For non-trees
+
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,ndist_types)  :: values            !! An array that holds canopy properties.
+    REAL(r_std)                                    :: lai_sum               !! The total LAI in the canopy,
+                                                                            !! summed across all levels.
+                                                                            !! @tex $(m^{2} m^{-2})$
+    REAL(r_std),PARAMETER                          :: max_laieff=20.0       !! A numerical construct to cap
+                                                                            !! the effective LAI so as to
+                                                                            !! not cause numerical problems.
+    REAL(r_std)                                    :: min_pgap              !! The probability that light makes
+                                                                            !! it through a layer of max_laieff thickness.
+   
+!_ ================================================================================================================================
+    
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering effective_lai'
+
+    !! 1. Initialize
+
+    laieff(:,:,:) = zero
+    PGapL(:,:,:) = un
+
+    ! we need the total number of individuals
+    ind_loc(:,:)=SUM(circ_class_n(:,:,:),3)
+    ind_loc(:,1)=zero
+    
+
+    ! for each PFT and each grid square, let's determine if we actually need to run
+    ! the calculation
+    lcalculate_tree(:,:)=.FALSE.
+    lcalculate_nontree(:,:)=.FALSE.
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          IF(is_tree(ivm))THEN
+             IF(ind_loc(ipts,ivm) .GT. min_stomate .AND. ind_loc(ipts,ivm) .LT. val_exp*ncirc)THEN 
+                lcalculate_tree(ipts,ivm)=.TRUE.
+             ENDIF
+          ELSE
+             IF(veget_max(ipts,ivm) .GT. min_stomate) lcalculate_nontree(ipts,ivm)=.TRUE.
+
+          ENDIF
+       ENDDO
+    ENDDO
+
+    ! for some reason, sinang is really the cosine of the solar zenith
+    solar_angle(:)=ACOS(sinang(:)) 
+
+    ! We need to derive some diagnostic variables from the biomass of each
+    ! tree in the circ distribution, based on allometic relations. We need the
+    ! height of the vegetation, the crown projected surface area, and the trunk
+    ! diameter
+    CALL derive_biomass_quantities(npts, nvm, ncirc, circ_class_n, &
+         circ_class_biomass, values)
+
+!************************************
+! this is taken directly from Jenny and Vanessa's code
+! I've replaced nlayer in their code with nvm, since it seems to me they are 
+! referring to canopy layers and not strict height levels...I feel these are
+! represented by our PFTs, although this is probably better represented by
+! species.
+! I've also read a little about the WHERE and FORALL constructs, and it seems
+! that there is no real advantage to using them over traditional nested loops
+! since compilers have gotten really good at loop optimization...I find nested
+! loops to be a bit more readable and easier to debug, so I've used those, even
+! though the order of the array indices are not necessarily optimized.
+
+    DO ipts = 1,npts
+       DO ivm=1,nvm
+          IF (.NOT. lcalculate_tree(ipts,ivm)) CYCLE
+          DO icir=1,ncirc
+             ! we are doing spheres right now, so the horizontal and vertical
+             ! axes have the same distributions
+             ver_axis_array(ipts,ivm,icir,:) = values(ipts,ivm,icir,icndiaver)
+             hor_axis_array(ipts,ivm,icir,:) = values(ipts,ivm,icir,icndiahor)
+             ph_array(ipts,ivm,icir,:) = values(ipts,ivm,icir,iheight)
+             DBH_array(ipts,ivm,icir,:) = values(ipts,ivm,icir,idiameter)
+          ENDDO
+
+          ! these two values are taken from the spherical LAD description in
+          !  section 4.2 of the paper. Looks like they are in degrees.
+          ! We don't need them since we set G=0.5 below
+          !thetaL_mean_array(ipts,ivm,:,:) = 57.0_r_std
+          !thetaL_sd_array(ipts,ivm,:,:) = 20.0_r_std
+
+          ! put some input values into arrays that are used in Vanessa's code
+
+          DO icir = 1,ncirc
+             h_array(ipts,ivm,icir,:) = values(ipts,ivm,icir,iheight)
+          ENDDO
+       ENDDO ! loop over PFTS
+    ENDDO ! end loop over grid
+
+    z_array(:,:,:,:) = zero
+    z_array2(:,:,:) = zero
+    DO icir=1,ncirc
+! these are the z values that we're computing the gap probability for, 
+! i.e. the bottom of each level. Level 1 is the level next to the soil.
+          z_array(:,:,icir,:) = z_level_loc(:,:,:)
+    ENDDO
+    z_array2(:,:,:) = z_level_loc(:,:,:)
+
+    ! 0 means we are looking downward, which is what we need
+    ! for the albedo since that is the direction the light is heading
+    upward_array = 0 
+
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          IF (.NOT. lcalculate_tree(ipts,ivm)) CYCLE
+          DO icir=1,ncirc
+             DO ilevel=1,nlevels_loc
+                ! compute the shadow of the crown projected onto each height for
+                ! each view angle using Appendix A in the manuscript...careful,
+                ! there are typos in the manuscript, but these routines came
+                ! directly from Vanessa and Jenny and should be correct if
+                ! either of the elipsoid axes are zero, this routine will crash.
+                ! These limits are arbitrary.
+                IF(ver_axis_array(ipts,ivm,icir,ilevel) .GT. laieff_zero_cutoff .AND. &
+                     hor_axis_array(ipts,ivm,icir,ilevel) .GT. laieff_zero_cutoff)THEN
+                   crown_shadow_h(ipts,ivm,icir,ilevel) = spheroid_shadow(solar_angle(ipts),&
+                        upward_array(ipts,ivm,icir,ilevel),&
+                        ver_axis_array(ipts,ivm,icir,ilevel),&
+                        hor_axis_array(ipts,ivm,icir,ilevel),&
+                        h_array(ipts,ivm,icir,ilevel),&
+                        z_array(ipts,ivm,icir,ilevel))
+
+
+                   ! this computes Eq. 10 in the manuscript, the mean path through
+                   ! each crown
+                   sbar_h(ipts,ivm,icir,ilevel) = sbar(h_array(ipts,ivm,icir,ilevel),&
+                        ver_axis_array(ipts,ivm,icir,ilevel)/2.0_r_std,&
+                        hor_axis_array(ipts,ivm,icir,ilevel)/2.0_r_std,&
+                        z_array(ipts,ivm,icir,ilevel),&
+                        crown_shadow_h(ipts,ivm,icir,ilevel),&
+                        solar_angle(ipts), upward_array(ipts,ivm,icir,ilevel)) 
+                ELSE
+                   crown_shadow_h(ipts,ivm,icir,ilevel)=zero
+                   sbar_h(ipts,ivm,icir,ilevel) = zero
+                ENDIF ! checking for ver_axis_array(ipts,ivm,icir,ilevel)
+
+                ! Notice that this crown area is different than the crown area
+                ! we calculate above. This crown area is the area on a plane 
+                ! cutting through the crown, whereas that calculated above is
+                ! the crown area projected on the ground from an overhead sun
+
+                IF(ver_axis_array(ipts,ivm,icir,ilevel) .GT. laieff_zero_cutoff .AND. &
+                     hor_axis_array(ipts,ivm,icir,ilevel) .GT. laieff_zero_cutoff)THEN
+                   crown_area_h(ipts,ivm,icir,ilevel) = spheroid_area(solar_angle(ipts),&
+                        upward_array(ipts,ivm,icir,ilevel),&
+                        ver_axis_array(ipts,ivm,icir,ilevel),&
+                        hor_axis_array(ipts,ivm,icir,ilevel),&
+                        h_array(ipts,ivm,icir,ilevel),&
+                        z_array(ipts,ivm,icir,ilevel))
+                ELSE
+                   crown_area_h(ipts,ivm,icir,ilevel)=zero
+                ENDIF
+                
+                
+! This subroutine takes a lot of time, and we're not currently using the trunks
+! below.  So let's just comment it out for now.
+!!$                ! Now compute the shadow of the trunks. We need the same check
+!!$                ! as above in case the diameter is zero. No shadow for such a
+!!$                ! skinny tree   
+!!$                IF(DBH_array(ipts,ivm,icir,ilevel) .GT. laieff_zero_cutoff)THEN
+!!$                   trunk_shadow_h(ipts,ivm,icir,ilevel) = trunk_shadow(solar_angle(ipts),&
+!!$                        upward_array(ipts,ivm,icir,ilevel),&
+!!$                        DBH_array(ipts,ivm,icir,ilevel),&
+!!$                        h_array(ipts,ivm,icir,ilevel),&
+!!$                        z_array(ipts,ivm,icir,ilevel))
+!!$                ELSE
+!!$                   trunk_shadow_h(ipts,ivm,icir,ilevel)=zero
+!!$                ENDIF
+
+             ENDDO ! loop over levels
+          ENDDO ! loop over circ classes
+
+          ! reassign the crown volume calculated above to an array used in Vanessa's code
+          DO icir=1,ncirc
+             CrownVolume_h(ipts,ivm,icir) = values(ipts,ivm,icir,icnvol)
+          ENDDO
+
+          ! do some integrations over the height distribution to find average values
+          ! This is equivalent to taking a weighted average by the number of 
+          ! individuals in each circ class.
+
+          DO ilevel=1,nlevels_loc
+             !************************
+             ! find the average trunk shadow per square meter
+             ! this is Eq. 5 in the manuscript
+             !                CrownShadowL(ipts,ivm,ilevel)=zero
+             ! in the code, some properties of opaque crowns are calculated, but
+             ! those are not  used in the calculation of Pgap so I'm leaving
+             ! them out, like CrownShadowL
+             !***********************
+             TrunkShadowL(ipts,ivm,ilevel)=zero
+             CrownAreaL(ipts,ivm,ilevel)=zero
+             DO icir=1,ncirc
+                !++++ CHECK +++++
+                ! Right now we are not using trunks.
+!                TrunkShadowL(ipts,ivm,ilevel)=TrunkShadowL(ipts,ivm,ilevel)+&
+!                     trunk_shadow_h(ipts,ivm,icir,ilevel)*&
+!                     circ_class_n(ipts,ivm,icir)
+                !+++++++++++++++++
+                CrownAreaL(ipts,ivm,ilevel)=CrownAreaL(ipts,ivm,ilevel)+&
+                     crown_area_h(ipts,ivm,icir,ilevel)*&
+                     circ_class_n(ipts,ivm,icir)
+
+             ENDDO ! loop over circ classes
+             CrownAreaL(ipts,ivm,ilevel)=CrownAreaL(ipts,ivm,ilevel)&
+                  /ind_loc(ipts,ivm)
+
+             ! this is part of Eq. 3 in the manuscript
+             !++++ CHECK +++++
+             ! Right now we are not using trunks
+             !TrunkShadowL(ipts,ivm,ilevel)=TrunkShadowL(ipts,ivm,ilevel)*&
+             ! ind_loc(ipts,ivm)
+             !Pbc_trunkL(ipts,ivm,ilevel)=EXP(-TrunkShadowL(ipts,ivm,ilevel))
+             !+++++++++++++++
+
+          ENDDO! loop over levels
+
+          ! Compute the average foliage volume density across the height distribution.
+          ! Notice that we do not need the area of the grid square here because we have a
+          ! number density of trees instead of just the number of trees, so grid area
+          ! cancels out in the equation
+
+          ! We need to integrate over the height distribution. This is equivalent
+          ! to taking a weighted average by the number of individuals in each
+          ! circ class.
+          CrownVolumeL(ipts,ivm)=zero
+          DO icir=1,ncirc
+             CrownVolumeL(ipts,ivm)=CrownVolumeL(ipts,ivm)+&
+                  CrownVolume_h(ipts,ivm,icir)*&
+                  circ_class_n(ipts,ivm,icir)
+          ENDDO
+
+          CrownVolumeL(ipts,ivm)=CrownVolumeL(ipts,ivm)/ind_loc(ipts,ivm)
+          
+          CALL calculate_favd(ipts,ivm, values(ipts,ivm,:,icnvol), circ_class_biomass, &
+!!               circ_class_n, biomass, favd, lai=lai_forced)
+               circ_class_n, biomass, favd)
+
+          IF(ld_laieff .AND. ipts == test_grid .AND. ivm == test_pft)THEN
+             WRITE(numout,*) 'FAVD debugging: ',favd(ipts,ivm)
+             WRITE(numout,*) ' CrownVolumeL debugging: ',CrownVolumeL(ipts,ivm)
+             DO icir=1,ncirc
+                WRITE(numout,'(A,I5,F16.8)') 'Crown diameter: ',icir,values(ipts,ivm,icir,icndiaver)
+             ENDDO
+          ENDIF
+
+          ! generate a larger array of values
+          FAVD_array(ipts,ivm,:,:) = FAVD(ipts,ivm)
+    
+          ! now we calculate the crown porosity, since the crown is not opaque...Eq. 8
+          ! for this we need the projection of the leaf area in the direction of the beam,
+          ! which is done by the Nilson method (end of Section 4.2 in the manuscript)
+          ! the code also did this with the Ross G function, but we'll take Nilson's.
+          ! the leaf angle distributions (LAD) are currently assumed to be spherical, which
+          ! means the mean leaf inclination is 57Â° and the standard deviation is 20Â°,
+          ! described with a two parameter beta function...this should be explored in more
+          ! depth
+
+          DO icir=1,ncirc
+             DO ilevel=1,nlevels_loc
+!                G_array(ipts,ivm,icir,ilevel)=&
+!                     NilsonG(thetaL_mean_array(ipts,ivm,icir,ilevel),&
+!                     thetaL_sd_array(ipts,ivm,icir,ilevel),laieff_solar_angle)
+                ! this is done slightly differently from the original code, 
+                ! because in the two-stream stream albedo method some coefficients
+                ! are done under the assumption of Ross's G function and a
+                ! spherical leaf distribution, which Pinty et al says makes the 
+                ! G function constant and equal to 0.5. Using NilsonG and the
+                ! above parameters gives a value of 0.505, so it's not much
+                ! different but this is good for consistency
+                G_array(ipts,ivm,icir,ilevel)=0.5_r_std
+
+                ! I am adding a clumping factor here to account for needles 
+                ! clumping to shoots, which increases the porosity of the canopy
+                ! and lets more light through. Notice this is not in the 
+                ! original Pgap model.
+                Pwc_h(ipts,ivm,icir,ilevel)=EXP(-G_array(ipts,ivm,icir,ilevel)*&
+                     FAVD_array(ipts,ivm,icir,ilevel)*sbar_h(ipts,ivm,icir,ilevel)&
+                     *leaf_to_shoot_clumping(ivm))
+             ENDDO ! loop over levels
+          ENDDO ! loop over circ classes
+       ENDDO ! loop over PFTs
+    ENDDO ! loop over grid points
+
+    ! Calculate the porous crown shadow integrating over the height distribution.
+    ! This is equivalent
+    ! to taking a weighted average by the number of individuals in each
+    ! circ class.
+    ! Eq. 4, and then calculate Pgap
+    DO ipts=1,npts
+       DO ivm=1,nvm
+
+          ! Here we need to calculate the effective LAI for all land types, 
+          ! including grass, crops, and bare soil
+          IF (is_tree(ivm)) THEN
+
+             IF(.NOT. lcalculate_tree(ipts,ivm)) CYCLE
+
+             ! first for forests
+             DO ilevel=1,nlevels_loc
+                PorousCrownShadowL(ipts,ivm,ilevel)=zero
+                DO icir=1,ncirc
+                   PorousCrownShadowL(ipts,ivm,ilevel)=&
+                        PorousCrownShadowL(ipts,ivm,ilevel)+&
+                        crown_shadow_h(ipts,ivm,icir,ilevel)*&
+                        (1.0_r_std-Pwc_h(ipts,ivm,icir,ilevel))*&
+                        circ_class_n(ipts,ivm,icir)
+                ENDDO
+
+                ! These next lines are commented out, but I'm leaving them here
+                ! for clarity.  The first line normalises the integration done
+                ! in the previous step so that we have the average porous
+                ! crown shadow over the whole stand.  The second line multiplies
+                ! by the density to be used in the exponential of the Poisson
+                ! distribution.  It's clear from these two lines that
+                ! they cancel each other out.
+!!$                PorousCrownShadowL(ipts,ivm,ilevel)=&
+!!$                     PorousCrownShadowL(ipts,ivm,ilevel)/ind_loc(ipts,ivm)
+!!$                PorousCrownShadowL(ipts,ivm,ilevel)=&
+!!$                     PorousCrownShadowL(ipts,ivm,ilevel)*ind_loc(ipts,ivm)
+                
+                ! this seems to be Eq. 3 in the manuscript
+!                PGapL(ipts,ivm,ilevel)=Pbc_trunkL(ipts,ivm,ilevel)*&
+!                     EXP(-PorousCrownShadowL(ipts,ivm,ilevel))
+                ! This line doesn't include the effect of trunks. Since our 
+                ! trunks in the albedo calculation aren't distinguishable from
+                ! the leaves, and since we don't want trunks absorbing light, we
+                ! remove the influence of trunks for now.
+                PGapL(ipts,ivm,ilevel)=&
+                     EXP(-PorousCrownShadowL(ipts,ivm,ilevel))
+             ENDDO ! loop over levels
+
+          ELSEIF(ivm == ibare_sechiba)THEN
+
+             ! For bare soil the transmission probability is always one. The
+             ! only thing that matters to the albedo is the background reflectance
+             PGapL(ipts,ivm,:)=un
+
+          ELSE
+
+             IF(.NOT. lcalculate_nontree(ipts,ivm)) CYCLE
+
+             ! Now for grass and croplands. We treat these exactly the same 
+             ! right now, just a slab of vegetation filling space.  For this, we
+             ! need to know the amount of vegetation that is in each level, which
+             ! was calculated in the find_lai_per_level routine.  It assumes folliage
+             ! is distributed evenly from the ground to the height of the
+             ! grass/crops.  Since the LAI will not be correct for grasslands and
+             ! croplands due to the lack of management in ORCHIDEE, we are
+             ! introducing a tunable parameter to help recover the true albedo values.
+
+             DO ilevel=1,nlevels_loc
+                ! This Eq. 1 in the manuscript, assuming G(theta)=0.5 (spherical
+                ! distribution) and using the LAI value with the adjusted LAI 
+                ! mentioned above. 
+                ! Notice that this lai_temp value has to be cumulative, since that
+                ! of the forests is and we correct Pgap based on that assumption below.
+                ! This means that we need the total LAI through which light has passed
+                ! in order to get here, i.e. the sum of all levels higher than and
+                ! including this level.
+!!$                lai_sum = biomass_to_lai(biomass(ipts,ivm,ileaf,icarbon),&
+!!$                     ivm)
+                lai_sum=zero
+                DO jlevel=nlevels_loc,ilevel,-1
+                   lai_sum=lai_sum+lai_per_level(ipts,ivm,jlevel)
+                ENDDO
+
+                PGapL(ipts,ivm,ilevel)=EXP(-0.5_r_std*lai_sum*&
+                     lai_correction_factor(ivm)/COS(solar_angle(ipts)))
+                IF(ipts == test_grid .AND. ivm == test_pft .AND. ld_laieff)THEN
+                   WRITE(numout,*) 'PgapL: ',PGapL(ipts,ivm,ilevel)
+                   WRITE(numout,*) 'lai_sum,lai_correction_factor(ivm): ',lai_sum,lai_correction_factor(ivm)
+                   WRITE(numout,*) 'COS(solar_angle(ipts)),ilevel: ',COS(solar_angle(ipts)),ilevel
+                ENDIF
+             ENDDO
+             
+          ENDIF ! check for tree
+       ENDDO ! loop over PFTs
+    ENDDO ! loop over grid points
+
+    ! Find the pgap for each level seperately...this makes PGap a measure of
+    ! the chance to make it through just this level, as opposed to the 
+    ! chance to make it through this level and all the above levels.
+
+    ! I do not need to CYCLE if lcalculate is not equal to
+    ! true here because I initialize PgapL to be
+    ! equal to 1 on all levels above.  The calculation
+    ! of this loop is much less expensive than
+    ! the other loops.
+    DO ipts=1,npts
+       DO ivm=1,nvm
+
+          IF(ld_laieff)THEN
+             IF((ipts == test_grid) .AND. (ivm == test_pft))THEN
+                WRITE(numout,*) 'Cumulative Pgap'
+                DO ilevel=nlevels_loc,1,-1
+                   WRITE(numout,*) ilevel,PgapL(ipts,ivm,ilevel)
+                ENDDO
+             ENDIF
+          ENDIF
+
+          DO ilevel=1,nlevels_loc-1
+
+             ! include a check for numerical stability.
+             ! The minumum Pgap is a function of the maximum
+             ! effective LAI that we allow.  The higher the
+             ! effective LAI, the lower the amount of light
+             ! which will be allowed through the layer.  This
+             ! number cannot be so high as to cause numerical
+             ! problems, though.  The value of 20 here is
+             ! arbitrary, but doesn't seem to cause any problems.
+             min_pgap=exp(-max_laieff/2.0/cos(solar_angle(ipts)))
+
+             IF(PgapL(ipts,ivm,ilevel+1) .GT. min_pgap )THEN
+                PgapL(ipts,ivm,ilevel)= PgapL(ipts,ivm,ilevel)/ &
+                     PgapL(ipts,ivm,ilevel+1)
+             ELSE
+                ! This is a problem.  We can't really say anything about
+                ! the gap probability for this level.  However, if the
+                ! above level is so dark, no light will make it
+                ! to this level, anyway.  So let's just make this
+                ! level opaque.  This is equivalent to giving a maximum
+                ! effective LAI value.
+                PgapL(ipts,ivm,ilevel)=exp(-max_laieff/2.0/cos(solar_angle(ipts)))
+             ENDIF
+
+             ! Include a check.  PgapL should always be between zero and
+             ! one.  Due to numerical issues, it's possible that it won't 
+             ! be sometimes.  We don't check to see if it's less than
+             ! zero because that will be caught later, and it's a more
+             ! serious issue.
+             IF(PgapL(ipts,ivm,ilevel) .GT. un) PgapL(ipts,ivm,ilevel)=un
+
+          ENDDO ! loop over levels
+
+          ! compute the effective LAI, based on Eq. 25 in Pintys 2004 paper cited
+          ! in the references above
+
+          IF(test_pft == ivm .AND. test_grid == ipts .AND. ld_laieff)THEN
+             WRITE(numout,*) 'Effective lai'
+             WRITE(numout,*) 'ipts,ivm,nlevels_loc',ipts,ivm,nlevels_loc
+          ENDIF
+
+          DO ilevel=nlevels_loc,1,-1
+             ! include a check for numerical stability...min_stomate is arbitrary
+             IF(PgapL(ipts,ivm,ilevel) .GT. min_stomate)THEN
+                laieff(ilevel,ipts,ivm)=-2.0_r_std*COS(solar_angle(ipts))*&
+                     LOG(PgapL(ipts,ivm,ilevel))
+             ELSE
+                laieff(ilevel,ipts,ivm)=-2.0_r_std*COS(solar_angle(ipts))*&
+                     LOG(min_stomate)
+             ENDIF
+
+             ! If the value is small enough or negative, we set it equal to zero.
+             ! A negative value for the effective LAI does not make sense in the
+             ! context of Eq. 12 in Pinty 2006.  If the effective LAI is zero, the
+             ! uncollided transmission will be one.  If LAI is positive, the
+             ! uncollided transmission will be between zero and one, since light
+             ! is intercepted by the canopy elements.  A negative effective
+             ! LAI results in uncollided transmitted light being greater than one,
+             ! which means there is a light source in the canopy.
+             IF(laieff(ilevel,ipts,ivm) .LE. min_stomate)THEN
+                IF( laieff(ilevel,ipts,ivm) .LE. -min_stomate) THEN
+                   WRITE(numout,*) 'ilevel,ipts,ivm', ilevel,ipts,ivm
+                   WRITE(numout,*) 'laieff(ilevel,ipts,ivm)', laieff(ilevel,ipts,ivm)
+                   CALL ipslerr_p (3,'effective_lai', 'We should not have a negative effective LAI.','','')
+                ENDIF
+                laieff(ilevel,ipts,ivm) = zero
+             ENDIF
+
+
+          ENDDO ! loop over levels
+
+          IF(test_pft == ivm .AND. test_grid == ipts .AND. ld_laieff)THEN
+             WRITE(numout,*) 'ilevel, laieff, PgapL: '
+             DO ilevel=nlevels_loc,1,-1
+                WRITE(numout,'(I5,2E20.10)') ilevel,laieff(ilevel,ipts,ivm),PgapL(ipts,ivm,ilevel)
+             ENDDO
+          ENDIF
+
+       ENDDO ! loop over PFTs
+    ENDDO ! loop over grid points
+
+
+    IF(PRESENT(Pgap_out))THEN
+       Pgap_out(:,:,:)=PgapL(:,:,:)
+    ENDIF
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving effective_lai'
+
+  END SUBROUTINE effective_lai
+
+
+
+!! ================================================================================================================================
+!! FUNCTION 	: spheroid_shadow
+!!
+!>\BRIEF        Calculates the projected shadow of a tree canopy at different heights and
+!!              sun angles, assuming a spheriod canopy
+!!
+!! DESCRIPTION  : Taken with permission from V. HAVERD's code, based on the equations in Appendix A
+!!                of her paper
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::spheroid_shadow
+!!
+!! REFERENCE(S) : 
+!!                Haverd et al; The Canopy Semi-analytic Pgap and radiative transfer 
+!!      (CanSPART) model: Formulation and application, AGRICULTURAL AND FOREST METEOROLOGY
+!!      Vol. 160, pp. 14-35, 2012
+!!
+!! FLOWCHART : None
+!! \n
+!_ ================================================================================================================================
+  
+  REAL(r_std) FUNCTION spheroid_shadow(theta,upward,T,D,&
+       H,z)
+    
+    !! 0 Variable and parameter declaration 
+  
+    !! 0.1 Input variables
+    REAL(r_std), INTENT(IN)                      :: theta ! view angle (radians)
+    REAL(r_std), INTENT(IN)                      :: T ! vertical diameter of the spheroid (m) 
+    REAL(r_std), INTENT(IN)                      :: D ! horizontal diameter (m)
+    REAL(r_std), INTENT(IN)                      :: H ! tree height (top of crown)
+    REAL(r_std), INTENT(IN)                      :: z ! height above ground
+    INTEGER(i_std), INTENT(IN)                   :: upward ! ==1 for upward view, ==0 for downward view
+    
+    
+    !! 0.2 Output variables
+!    REAL(r_std)                                  :: spheroid_shadow
+    
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std)                                  :: thetapr, Ypr, Y1pr, Y1, X1, D1pr, D2pr, Y
+
+!_ ================================================================================================================================
+    
+    thetapr =  ATAN(T/D*TAN(theta)) ! zenith angle in spherical space
+    
+    
+! the conventions are described in Appendix A of this paper
+    IF (upward==1) THEN
+       Y = z-H+T/2 
+    ELSE
+       Y = H-T/2-z
+    ENDIF
+    Ypr  = Y*D/T
+    Y1pr = D/2.0*TAN(thetapr)/SQRT(1+TAN(thetapr)**2) 
+    Y1 = T/D*Y1pr 
+    IF (TAN(thetapr).NE.0.0) THEN
+       X1 = Y1pr/TAN(thetapr) 
+    ELSE
+       X1 = D/2 
+    END IF
+    
+    
+    
+    ! first calculate major axis (D1pr) of elliptic shadow
+    
+    IF (Y<=-T/2.0) THEN ! below crown bottom
+        D1pr = 0.0 
+    END IF
+    
+    IF (Y>-T/2 .AND. Y<=-Y1)  THEN !between crown bottom and lower tangent point
+       D1pr = D*SQRT(1.0-Ypr**2*4.0/D**2)  
+    END IF
+    
+    IF (Y>-Y1 .AND. Y <Y1) THEN !between lower and upper tangent points
+       D1pr = D/2.0*SQRT(1.0-MIN(Ypr**2*4.0/D**2,1.0)) +X1 - &
+            TAN(thetapr)*(-Y1pr-Ypr) 
+    END IF
+    
+    IF (Y > Y1) THEN !above upper tangent point
+       D1pr = D/COS(thetapr)     
+    END IF
+
+    ! second calculate minor axis (D2pr) of elliptic shadow 
+    ! (this is just the diameter of the circular cross-section at height z)
+    IF (Y <= -T/2) THEN
+       D2pr = 0.0                      !shadow breadth
+    END IF
+    
+    IF (Y<=0 .AND. Y >-T/2) THEN
+       D2pr = 2.0*SQRT((D/2.0)**2-Ypr**2)    !shadow breadth
+    END IF
+    
+    IF (Y>=0) THEN
+       D2pr = D    !shadow breadth
+    END IF
+    
+
+    ! shadow area
+    spheroid_shadow = pi/4.0*D2pr*D1pr 
+
+  END FUNCTION spheroid_shadow
+
+
+!! ================================================================================================================================
+!! FUNCTION     : trunk_shadow
+!!
+!>\BRIEF        ! Calculates the projected shadow of a tree trunk at different heights and
+!!              sun angles, assuming a cone shape
+!!
+!! DESCRIPTION : Taken with permission from V. HAVERD's code, based on the equations in Appendix E
+!!                of her paper
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : trunk_shadow
+!!
+!! REFERENCE(S) : Haverd et al; The Canopy Semi-analytic Pgap and radiative transfer 
+!!      (CanSPART) model: Formulation and application, AGRICULTURAL AND FOREST METEOROLOGY
+!!      Vol. 160, pp. 14-35, 2012
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  REAL(r_std) FUNCTION trunk_shadow(theta,upward,D,H,z)
+    !! 0 Variable and parameter declaration 
+  
+    !! 0.1 Input variables
+    REAL(r_std), INTENT(IN)                       :: theta ! view angle              @tex $(radians)$ @endtex
+    REAL(r_std), INTENT(IN)                       :: D ! trunk diameter              @tex $(m)$ @endtex
+    REAL(r_std), INTENT(IN)                       :: H ! tree height (top of crown)  @tex $(m)$ @endtex
+    REAL(r_std), INTENT(IN)                       :: z ! height above ground         @tex $(m)$ @endtex
+    INTEGER(i_std), INTENT(IN)                    :: upward ! ==1 for upward view, ==0 for downward view
+  
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std)                                  :: sinalpha, alpha 
+
+!_ ================================================================================================================================
+    
+    sinalpha = D/(2.*H*TAN(theta))
+    IF (ABS(sinalpha).LT.1.0.AND.D.GT.0.0) THEN
+       alpha = 2.*ASIN(sinalpha)
+
+       IF (upward==1) THEN
+          ! shadow is bounded by base-of-trunk circle; trunk cross-section at z
+          ! and tangents joining the two circles
+          IF (z<H) THEN
+             trunk_shadow = 1./4. * D**2*(1.-(1.-z/H)**2)/(TAN(alpha/2.)) + &
+                  1./8.*D**2*(pi+alpha) + 1./8.*D**2*(1-z/H)**2*(pi-alpha)
+          ELSE
+             trunk_shadow = 1./4. * D**2*1./(TAN(alpha/2.)) + 1./8.*D**2*(pi+alpha)
+          ENDIF
+          
+          trunk_shadow = trunk_shadow - pi * (D**2)/4.
+       ELSEIF (upward==0) THEN
+          
+          ! shadow is bounded by trunk cross-section at z and tangents joining two circles
+          IF (z<H) THEN
+             trunk_shadow = 1./4. * D**2*(1.-z/H)**2*1./(TAN(alpha/2.)) + &
+                  1./8.*D**2*(1.-z/H)**2*(pi+alpha)
+          ELSE
+             trunk_shadow = 0.
+          ENDIF
+          
+       ENDIF
+       
+    ELSE
+       trunk_shadow = 0.0
+    ENDIF
+    
+  END FUNCTION trunk_shadow
+
+
+!! ================================================================================================================================
+!! FUNCTION     : sbar
+!!
+!>\BRIEF        ! Calculates the mean free distance through the crown, Eq. 10 in Haverd et al.
+!!
+!! DESCRIPTION : Taken with permission from V. HAVERD's code
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : sbar
+!!
+!! REFERENCE(S) : Haverd et al; The Canopy Semi-analytic Pgap and radiative transfer 
+!!      (CanSPART) model: Formulation and application, AGRICULTURAL AND FOREST METEOROLOGY
+!!      Vol. 160, pp. 14-35, 2012
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  REAL(r_std) FUNCTION sbar(x, b, r, z, area,&
+       theta, upward )
+    !! 0 Variable and parameter declaration 
+  
+    !! 0.1 Input variables
+    REAL(r_std), INTENT(IN)         :: x             ! tree height              
+                                                     ! @tex $(m)$ @endtex
+    REAL(r_std), INTENT(IN)         :: b             ! vertical crown radius
+                                                     ! @tex $(m)$ @endtex
+    REAL(r_std), INTENT(IN)         :: r             ! horizontal crown radius
+                                                     ! @tex $(m)$ @endtex
+    REAL(r_std), INTENT(IN)         :: z             ! height above ground
+                                                     ! @tex $(m)$ @endtex
+    REAL(r_std), INTENT(IN)         :: theta         ! view angle
+                                                     ! @tex $(radians)$ @endtex
+    REAL(r_std), INTENT(IN)         :: area          ! shadow area of partial spheroid  
+                                                     ! @tex $(m^2)$ @endtex
+    INTEGER(i_std), INTENT(IN)      :: upward        ! ==1 for upward view, ==0 
+                                                     ! for downward view
+  
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std)                                  :: Hpr, Y, V_ps
+
+!_ ================================================================================================================================
+
+    Hpr = x-b ! Hpr is height at crown centre
+    IF (upward==1) THEN
+       Y = z-Hpr  ! Y=0 corresponds to crown centre
+    ELSE
+       Y = Hpr - z
+    ENDIF
+    
+    ! initialize the output variables, just in case there is a numerical reason 
+    ! none of the loops is hit
+    V_ps =zero
+    sbar =zero
+
+    IF (Y<b.AND.Y>-b) THEN
+
+       ! volume of partial spheroid below height z
+       V_ps = 4.0_r_std/3.0_r_std*pi*(r)**2*(b) - ((2.0_r_std* b)/3.0_r_std - Y &
+            + Y**3/(3.0_r_std* b**2)) *pi* r**2 
+
+       ! there are some numerical issues here occasionally that give a negative 
+       ! extremely small value, which in turn gives a negative sbar which causes
+       ! problems later
+       IF(ABS(V_ps) .LT. 0.0000001_r_std) V_ps= zero
+       sbar = V_ps/COS(theta)/area
+
+    ENDIF
+
+ !!!!!! had to add the check for area
+   IF (Y>=b .AND. area .NE. zero) THEN
+       V_ps = 4.0_r_std/3.0_r_std*pi*(r)**2*(b)  ; ! volume of whole spheroid
+       sbar= V_ps/COS(theta)/area
+    ENDIF
+
+
+  END FUNCTION sbar
+  
+!! ================================================================================================================================
+!! FUNCTION     : spheroid_area
+!!
+!>\BRIEF        ! Calculates the area of the cross section of a spheroid at a height of z
+!!
+!! DESCRIPTION : Taken with permission from V. HAVERD's code
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : spheroid_area
+!!
+!! REFERENCE(S) : Haverd et al; The Canopy Semi-analytic Pgap and radiative transfer 
+!!      (CanSPART) model: Formulation and application, AGRICULTURAL AND FOREST METEOROLOGY
+!!      Vol. 160, pp. 14-35, 2012
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  REAL(r_std) FUNCTION spheroid_area(theta,upward,T,D,H,z)
+
+    !! 0 Variable and parameter declaration 
+  
+    !! 0.1 Input variables
+    REAL(r_std), INTENT(IN)          :: theta ! view angle              
+                                              ! @tex $(radians)$ @endtex
+    REAL(r_std), INTENT(IN)          :: T ! vertical diameter           
+                                          ! @tex $(m)$ @endtex
+    REAL(r_std), INTENT(IN)          :: D ! horizontal diameter         
+                                          ! @tex $(m)$ @endtex
+    REAL(r_std), INTENT(IN)          :: H ! tree height (top of crown)  
+                                          ! @tex $(m)$ @endtex
+    REAL(r_std), INTENT(IN)          :: z ! height above ground         
+                                          ! @tex $(m)$ @endtex
+    INTEGER(i_std), INTENT(IN)       :: upward ! ==1 for upward view, 
+                                               ! ==0 for downward view
+
+  
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std)                      :: thetapr, Ypr, Y1pr, Y1, X1, D2pr, Y
+
+!_ ================================================================================================================================
+
+    thetapr =  ATAN(T/D*TAN(theta)) ! zenith angle in spherical space
+
+
+    IF (upward==1) THEN
+       Y = z-H+T/2 
+    ELSE
+       Y = H-T/2-z
+    ENDIF
+    Ypr  = Y*D/T
+    Y1pr = D/2.0*TAN(thetapr)/SQRT(1+TAN(thetapr)**2) 
+    Y1 = T/D*Y1pr 
+    IF (TAN(thetapr).NE.0.0) THEN
+       X1 = Y1pr/TAN(thetapr) 
+    ELSE
+       X1 = D/2 
+    END IF
+    
+
+    ! calculate minor axis (D2pr) of elliptic shadow 
+    ! (this is just the diameter of the circular cross-section at height z)
+    
+    
+    IF (Y<=T/2 .AND. Y >-T/2) THEN
+       D2pr = 2.0*SQRT((D/2.0)**2-Ypr**2)    !shadow breadth
+    ELSE
+       D2pr = 0    !shadow breadth
+    END IF
+    
+
+    ! shadow area
+    spheroid_area = pi/4.0*D2pr**2 
+
+  END FUNCTION spheroid_area
+
+!! ================================================================================================================================
+!! FUNCTION     : NilsonG
+!!
+!>\BRIEF        ! Calculates the projection of unit foliage area  G(theta) as described by
+!!              Wang et al, 2007, referenced in section 4.2 from V. Haverd's paper
+!!
+!! DESCRIPTION : Taken with permission from V. HAVERD's code
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : NilsonG
+!!
+!! REFERENCE(S) : Haverd et al; The Canopy Semi-analytic Pgap and radiative transfer 
+!!      (CanSPART) model: Formulation and application, AGRICULTURAL AND FOREST METEOROLOGY
+!!      Vol. 160, pp. 14-35, 2012
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  REAL(r_std) FUNCTION NilsonG(mean_thetaL,sd_thetaL,theta_deg)
+    !! 0 Variable and parameter declaration 
+  
+    !! 0.1 Input variables
+    REAL(r_std), INTENT(IN)          :: mean_thetaL ! the mean leaf angle inclination 
+                                                    ! @tex $(degrees)$ @endtex 
+    REAL(r_std), INTENT(IN)          :: sd_thetaL ! the standard deviation of the leaf angle inclination 
+                                                  ! @tex $(degrees)$ @endtex 
+    REAL(r_std), INTENT(IN)          :: theta_deg ! the solar zenith angle 
+                                                  ! @tex $(degrees)$ @endtex 
+  
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std)                      :: var_t, thl_bar, theta, thetaL, psi
+    REAL(r_std), ALLOCATABLE         :: A(:), f(:)
+    INTEGER(i_std)                   :: k, nthetaL
+!_ ================================================================================================================================
+
+    var_t = (sd_thetaL/90.0_r_std)**2
+    thl_bar = mean_thetaL*pi/180.0_r_std
+    theta = theta_deg*pi/180.0_r_std
+    nthetaL = 20
+    ALLOCATE (A(nthetaL))
+    ALLOCATE (f(nthetaL))
+    DO k=1,nthetaL
+       thetaL = 0.0_r_std + 89.0_r_std/nthetaL*(k)*pi/180.0_r_std
+       IF (ABS((1/TAN(theta))*(1/TAN(thetaL)))>1) THEN
+          A(k) = COS(theta)*COS(thetaL);
+       ELSE
+          psi = ACOS((1.0_r_std/TAN(theta))*(1.0_r_std/TAN(thetaL)));
+          A(k) = COS(theta)*COS(thetaL)*(1.0_r_std+2.0_r_std/pi*(TAN(psi)-psi));
+       ENDIF
+       f(k) = BETA_LAD(thl_bar,var_t, thetaL)
+    ENDDO
+    NilsonG = SUM(A(1:nthetaL)*f(1:nthetaL))/SUM(f(1:nthetaL))
+
+    DEALLOCATE(A)
+    DEALLOCATE(F)
+
+  END FUNCTION NilsonG
+
+!! ================================================================================================================================
+!! FUNCTION     : BETA_LAD
+!!
+!>\BRIEF        ! Calculates the beta leaf angle distribution as described by
+!!              Wang et al, 2007, referenced in section 4.2 from V. Haverd's paper
+!!
+!! DESCRIPTION : Taken with permission from V. HAVERD's code
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : BETA_LAD
+!!
+!! REFERENCE(S) : Haverd et al; The Canopy Semi-analytic Pgap and radiative transfer 
+!!      (CanSPART) model: Formulation and application, AGRICULTURAL AND FOREST METEOROLOGY
+!!      Vol. 160, pp. 14-35, 2012
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  REAL(r_std) FUNCTION BETA_LAD(thl_bar,var_t, theta)
+
+    !! 0 Variable and parameter declaration 
+  
+    !! 0.1 Input variables
+    REAL(r_std), INTENT(IN):: thl_bar,var_t, theta
+  
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std)                                  :: tbar, sig0_2, sigt_2, mu, nu, t, num
+!_ ================================================================================================================================
+
+    tbar = 2.0_r_std*thl_bar/(pi)
+    sig0_2 = tbar*(1.0_r_std-tbar)
+    sigt_2 = var_t
+    num = sig0_2/sigt_2 - 1.0_r_std
+    ! Test for negative num as this causes distribution to fail.
+    IF (num <= zero) THEN 
+       num = 0.01_r_std
+       !write(*,*)'WARNING: leaf angle SD too large'
+    ENDIF
+    
+    nu = tbar*num
+    mu = (1.0_r_std-tbar)*num
+    
+    t = 2.0_r_std*theta/pi
+    beta_lad = ((1.0_r_std-t)**(mu-1.0_r_std))*(t**(nu-1.0_r_std))/beta(mu,nu)   
+    
+  END FUNCTION BETA_LAD
+!********************************************************************************
+
+!! ================================================================================================================================
+!! FUNCTION     : beta
+!!
+!>\BRIEF        ! Calculates the beta leaf angle distribution as described by
+!!              Wang et al, 2007, referenced in section 4.2 from V. Haverd's paper
+!!
+!! DESCRIPTION : Taken with permission from V. HAVERD's code
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : BETA
+!!
+!! REFERENCE(S) : Haverd et al; The Canopy Semi-analytic Pgap and radiative transfer 
+!!      (CanSPART) model: Formulation and application, AGRICULTURAL AND FOREST METEOROLOGY
+!!      Vol. 160, pp. 14-35, 2012
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  REAL(r_std) FUNCTION beta(z,w)
+    !! 0 Variable and parameter declaration 
+  
+    !! 0.1 Input variables
+    REAL(r_std), INTENT(IN):: z,w
+  
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+!_ ================================================================================================================================
+
+    beta=EXP(gammln(z)+gammln(w)-gammln(z+w))
+
+  END FUNCTION beta
+!! ================================================================================================================================
+!! FUNCTION     : gammaln
+!!
+!>\BRIEF        ! Calculates the beta leaf angle distribution as described by
+!!              Wang et al, 2007, referenced in section 4.2 from V. Haverd's paper
+!!
+!! DESCRIPTION : Taken with permission from V. HAVERD's code
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : gammaln
+!!
+!! REFERENCE(S) : Haverd et al; The Canopy Semi-analytic Pgap and radiative transfer 
+!!      (CanSPART) model: Formulation and application, AGRICULTURAL AND FOREST METEOROLOGY
+!!      Vol. 160, pp. 14-35, 2012
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  REAL(r_std) FUNCTION gammln(xx)
+    !! 0 Variable and parameter declaration 
+  
+    !! 0.1 Input variables
+    REAL(r_std), INTENT(IN):: xx
+  
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std) :: tmp,x,stp,temp,first,increment
+    INTEGER(i_std) :: k,k2,n
+    INTEGER(i_std), PARAMETER :: NPAR_ARTH=16,NPAR2_ARTH=8
+    REAL(r_std),DIMENSION(6) :: coef,ARTH
+!_ ================================================================================================================================
+    
+    stp = 2.5066282746310005_r_std
+    coef = (/76.18009172947146_r_std,&
+         -86.50532032941677_r_std,24.01409824083091_r_std,&
+         -1.231739572450155_r_std,0.1208650973866179e-2_r_std,&
+         -0.5395239384953e-5_r_std/)
+    x=xx
+    tmp=x+5.5_r_std
+    tmp=(x+0.5_r_std)*LOG(tmp)-tmp
+    
+    n = SIZE(coef)
+    increment = 1.0_r_std
+    first = x+1.0_r_std
+    IF (n > 0) arth(1)=first
+    IF (n <= NPAR_ARTH) THEN
+       DO k=2,n
+          ARTH(k)=ARTH(k-1)+increment
+       END DO
+    ELSE
+       DO k=2,NPAR2_ARTH
+          ARTH(k)=ARTH(k-1)+increment
+       END DO
+       temp=increment*NPAR2_ARTH
+       k=NPAR2_ARTH
+       DO
+          IF (k >= n) EXIT
+          k2=k+k
+          arth(k+1:MIN(k2,n))=temp+arth(1:MIN(k,n-k))
+          temp=temp+temp
+          k=k2
+       END DO
+    END IF
+    
+    gammln=tmp+LOG(stp*(1.000000000190015_r_std+&
+         SUM(coef(:)/arth(:)))/x)
+  END FUNCTION gammln
+
+!! ================================================================================================================================
+!! FUNCTION     : partial_spheroid_vol
+!!
+!>\BRIEF        ! Calculates the beta leaf angle distribution as described by
+!!              Wang et al, 2007, referenced in section 4.2 from V. Haverd's paper
+!!
+!! DESCRIPTION : Taken with permission from V. HAVERD's code
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : partial_spheroid_vol
+!!
+!! REFERENCE(S) : Haverd et al; The Canopy Semi-analytic Pgap and radiative transfer 
+!!      (CanSPART) model: Formulation and application, AGRICULTURAL AND FOREST METEOROLOGY
+!!      Vol. 160, pp. 14-35, 2012
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  REAL(r_std) FUNCTION partial_spheroid_vol(Z_up, Z_down, b, r, h)
+    !! 0 Variable and parameter declaration 
+  
+    !! 0.1 Input variables
+    ! The units of all these variables can be anything, so long as they
+    ! are all the same.
+    !  I assume
+    REAL(r_std), INTENT(IN)         :: Z_up  ! The height of the top cutting plane
+    REAL(r_std), INTENT(IN)         :: Z_down ! The height of the lower cutting plane
+    REAL(r_std), INTENT(IN)         :: b     ! Distance from center to top of the spheroid
+    REAL(r_std), INTENT(IN)         :: r     ! Distance from center to outside on the XY plane
+    REAL(r_std), INTENT(IN)         :: h     ! Height of the top of the spheroid above the ground
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    REAL(r_std)                      :: Z1, Z2, center
+
+!_ ================================================================================================================================
+    
+    ! initialize the output variables
+    partial_spheroid_vol =zero
+
+    ! It's possible that none of this spheroid is in this level!
+    center = h-b
+
+    IF(Z_down - center .GE. b)RETURN
+    IF(Z_up - center .LE. -b)RETURN
+
+    ! Z1 and Z2 have to be within the limits of the spheroid
+    ! I also want the center at the origin.
+    Z2=MIN(Z_up-center,b)
+    Z1=MAX(Z_down-center,-b)
+
+    ! With a little calculus, I computed the following formula, which
+    ! gives the correct result in the case of the full spheroid,
+    ! i.e. Z2=b and Z1=-b, as well as for a full sphere (r=b)
+    partial_spheroid_vol = pi*r**2*(Z2-Z1-(Z2**3-Z1**3)/(3.0_r_std*b**2))
+
+    ! there are some numerical issues here occasionally that give a negative 
+    ! extremely small value, which in turn gives a negative partial_spheroid_vol which causes
+    ! problems later
+    IF(ABS(partial_spheroid_vol) .LT. min_stomate) partial_spheroid_vol= zero
+
+  END FUNCTION partial_spheroid_vol
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: calculate_favd
+!!
+!>\BRIEF       Calculates the foliage area volume density of a canopy.
+!!
+!! DESCRIPTION  : WARNING: This should only be used for trees.  Grasses
+!!                and crops have no canopy volume currently in the model.
+!!
+!!    NOTE:
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::favd
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART : None
+!! \n
+!_ ================================================================================================================================
+  
+  SUBROUTINE calculate_favd(ipts,ivm, cn_vol, circ_class_biomass, &
+       circ_class_n, biomass, favd)
+
+  !! 0 Variable and parameter declaration 
+    
+    !! 0.1 Input variables
+    
+    INTEGER(i_std),INTENT(IN)                            :: ipts         
+    INTEGER(i_std),INTENT(IN)                            :: ivm        
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(IN)        :: circ_class_biomass    !! Biomass of the components of the model  
+                                                                                  !! tree within a circumference class
+                                                                                  !! @tex $(gC ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(IN)            :: circ_class_n          !! Number of trees within each circ class
+                                                                                  !! @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:), INTENT(IN)                :: cn_vol                !! Canopy volume for each circ class
+                                                                                  !! @tex $(m^{-3} ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(in)          :: biomass               !! Stand level biomass 
+                                                                                  !! @tex $(gC m^{-2})$ @endtex
+
+    !! 0.2 Output variables
+    REAL(r_std), DIMENSION(:,:), INTENT(OUT)             :: favd                  !! The LAI per canopy volume density
+                                                                                  !! @tex $(m^{-3} m^{-2})$ @endtex
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+    INTEGER :: icir
+    REAL(r_std) :: total_bm
+    REAL(r_std) :: total_vol
+    REAL(r_std) :: total_la
+    REAL(r_std) :: max_height
+    REAL(r_std) :: lai_temp
+    REAL(r_std) :: ind_loc
+!_ ================================================================================================================================
+    
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering calculate_favd'
+
+    ind_loc = SUM(circ_class_n(ipts,ivm,:))
+
+    IF(is_tree(ivm))THEN
+       ! How much total leaf biomass do we have?
+       ! How much total canopy volume do we have?
+       total_bm=zero
+       total_vol=zero
+       ! Notice that we don't have to take the surface area of the stand
+       ! into account.  total_bm will be in units of gC / m**2, while
+       ! the canopy volume should be in units of m**3 / m**2.  The surface
+       ! area would cancel out when we take the ratio.
+       DO icir=1,ncirc
+          total_bm=total_bm+circ_class_biomass(ipts,ivm,icir,ileaf,icarbon)*&
+               !            circ_class_n(ipts,ivm,icir)*surface_area
+               circ_class_n(ipts,ivm,icir)
+          total_vol=total_vol+cn_vol(icir)*&
+               circ_class_n(ipts,ivm,icir)
+          !            circ_class_n(ipts,ivm,icir)*surface_area
+          IF(ipts == test_grid .AND. ivm == test_pft .AND. ld_laieff)THEN
+             WRITE(numout,'(A,I5,3F16.8)') 'icir,cn_vol,circ_class_biomass,circ_class_n: ',&
+                  icir,cn_vol(icir),circ_class_biomass(ipts,ivm,icir,ileaf,icarbon),circ_class_n(ipts,ivm,icir)
+          ENDIF
+       ENDDO
+
+       ! Right now, total_vol is in m**3/tree * tree/m**2
+
+       ! How much leaf area do we have on our grid square?
+       total_la=total_bm*sla(ivm)
+
+       ! Total_la is unitless. m**2 / m**2.
+
+       IF(ipts == test_grid .AND. ivm == test_pft .AND. ld_laieff)THEN
+          WRITE(numout,'(A,3F16.8)') &
+               'total_la,total_vol: ',total_la,total_vol,total_la/total_vol
+       ENDIF
+
+       ! What is the foliage area volume density?
+       IF (total_vol .GT. min_stomate) THEN
+          ! 1 / m**3 (canopy volume) / m**2 (land area)
+          FAVD(ipts,ivm)=total_la/total_vol
+       ELSE
+          FAVD(ipts,ivm)=zero
+       ENDIF
+       
+
+    ELSE
+
+       ! What is the height of our grass/crop?
+       
+       lai_temp = biomass_to_lai(biomass(ipts,ivm,ileaf,icarbon), ivm)
+
+       ! This converts LAI to a height.  I took this from functional_allocation.
+       max_height = lai_temp * lai_to_height(ivm)
+
+       ! The units here are per square meter, so the volume of the cube is
+       ! just the height*1*1.
+       IF (max_height .GT. min_stomate) THEN
+          FAVD(ipts,ivm)=lai_temp / max_height
+       ELSE
+          FAVD(ipts,ivm)=zero
+       ENDIF
+    ENDIF
+
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving calculate_favd'
+
+  END SUBROUTINE calculate_favd
+
+!! ================================================================================================================================
+!! FUNCTION     : calculate_laieff_fit
+!!
+!>\BRIEF        : 
+!!
+!! DESCRIPTION : 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! RETURN VALUE : calculate_laieff_fit
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  REAL(r_std) FUNCTION calculate_laieff_fit(test_angle, laieff_fit)
+    !! 0 Variable and parameter declaration 
+  
+    !! 0.1 Input variables
+    REAL(r_std),INTENT(IN)        :: test_angle        !! the cosine of the solar angle
+    TYPE(laieff_type),INTENT(in)    :: laieff_fit      !! Fitted parameters for the effective LAI
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+!_ ================================================================================================================================
+    
+    ! y = a + b*x + c*x**2 + d*x**3 + e*x**4
+    calculate_laieff_fit=laieff_fit%a + test_angle * laieff_fit%b + &
+         test_angle**2 * laieff_fit%c +  test_angle**3 * laieff_fit%d + &
+         test_angle**4 * laieff_fit%e
+
+
+
+  END FUNCTION calculate_laieff_fit
+
+END MODULE stomate_laieff
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_litter.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_litter.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_litter.f90	(revision 7236)
@@ -0,0 +1,1917 @@
+! =================================================================================================================================
+! MODULE       : stomate_litter
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Update litter and lignine content after litter fall and 
+!! calculating litter decomposition.      
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	: None
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE stomate_litter
+
+  ! modules used:
+
+  USE ioipsl_para
+  USE stomate_data
+  USE constantes
+  USE constantes_soil
+  USE pft_parameters
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC littercalc_diagnostic,littercalc_prognostic, littercalc_clear, deadleaf
+
+  LOGICAL, SAVE                        :: firstcall = .TRUE.       !! first call
+!$OMP THREADPRIVATE(firstcall)
+
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE   : littercalc_calc_prognostic
+!!
+!!\BRIEF        Set the flag ::firstcall to .TRUE. and as such activate section
+!! 1.1 of the subroutine littercalc (see below).
+!!
+!! DESCRIPTION  : None
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S) : None
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE littercalc_clear
+    firstcall =.TRUE.
+  END SUBROUTINE littercalc_clear
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : littercalc
+!!
+!!\BRIEF        Calculation of the litter decomposition and therefore of the 
+!! heterotrophic respiration from litter following Parton et al. (1987).
+!!
+!! DESCRIPTION  : The littercal routine splits the litter in 4 pools: 
+!! aboveground metaboblic, aboveground structural, belowground metabolic and 
+!! belowground structural. the fraction (F) of plant material going to metabolic 
+!! and structural is defined following Parton et al. (1987)
+!! \latexonly
+!! \input{littercalc1.tex}
+!! \endlatexonly
+!! \n
+!! where L is the lignin content of the plant carbon pools considered and CN 
+!! its CN ratio. L and CN are fixed parameters for each plant carbon pools,
+!! therefore it is the ratio between each plant carbon pool within a PFT, which
+!! controlled the part of the total litter, that will be considered as
+!! recalcitrant (i.e. structural litter) or labile (i.e. metabolic litter).\n  
+!! 
+!! The routine calculates the fraction of aboveground litter which is metabolic
+!! or structural (the litterpart variable) which is then used in lpj_fire.f90.\n 
+!! 
+!! In the section 2, the routine calculate the new plant material entering the
+!! litter pools by phenological death of plants organs (corresponding to the
+!! variable turnover) and by fire, herbivory and others non phenological causes
+!! (variable bm_to_litter). This calculation is first done for each PFT and then
+!! the values calculated for each PFT are added up. Following the same approach
+!! the lignin content of the total structural litter is calculated and will be
+!! then used as a factor control of the decomposition of the structural litter
+!! (lignin_struc) in the section 5.1.2. A test is performed to avoid that we add
+!! more lignin than structural litter. Finally, the variable litterpart is
+!! updated.\n
+!! 
+!! In the section 3 and 4 the temperature and the moisture controlling the
+!! decomposition are calculated for above and belowground. For aboveground
+!! litter, air temperature and litter moisture are calculated in sechiba and used 
+!! directly. For belowground, soil temperature and moisture are also calculated 
+!! in sechiba but are modulated as a function of the soil depth. The modulation 
+!! is a multiplying factor exponentially distributed between 0 (in depth) and 1
+!! in surface.\n  
+!! 
+!! Then, in the section 5, the routine calculates the structural litter decomposition 
+!! (C) following first order kinetics following Parton et al. (1987).
+!! \latexonly
+!! \input{littercalc2.tex}
+!! \endlatexonly
+!! \n
+!! with k the decomposition rate of the structural litter. 
+!! k corresponds to
+!! \latexonly
+!! \input{littercalc3.tex}
+!! \endlatexonly
+!! \n
+!! with littertau the turnover rate, T a function of the temperature and M a function of
+!! the moisture described below.\n
+!!  
+!! Then, the fraction of dead leaves (DL) composed by aboveground structural litter is
+!! calculated as following
+!! \latexonly
+!! \input{littercalc4.tex}
+!! \endlatexonly
+!! \n
+!! with k the decomposition rate of the structural litter previously
+!! described.\n
+!!
+!! In the section 5.1, the fraction of decomposed structural litter
+!! incorporated to the soil (Input) and its associated heterotrophic respiration are
+!! calculated. For structural litter, the C decomposed could go in the active
+!! soil carbon pool or in the slow carbon, as described in 
+!! stomate_soilcarbon.f90.\n
+!! \latexonly
+!! \input{littercalc5.tex}
+!! \endlatexonly
+!! \n
+!! with f a parameter describing the fraction of structural litter incorporated
+!! into the considered soil carbon pool, C the amount of litter decomposed and L 
+!! the amount of lignin in the litter. The litter decomposed which is not
+!! incorporated into the soil is respired.\n
+!!
+!! In the section 5.2, the fraction of decomposed metabolic litter
+!! incorporated to the soil and its associated heterotrophic respiration are
+!! calculated with the same approaches presented for 5.1 but no control factor
+!! depending on the lignin content are used.\n
+!! 
+!! In the section 6 the dead leaf cover is calculated through a call to the 
+!! deadleaf subroutine presented below.\n
+!!
+!! In the section 7, if the flag SPINUP_ANALYTIC is set to true, we fill MatrixA
+!! and VectorB following Lardy(2011).
+!!
+!! MAIN OUTPUT VARIABLES: ::deadleaf_cover, ::resp_hetero_litter, ::soilcarbon_input, 
+!! ::control_temp, ::control_moist
+!!
+!! REFERENCES:
+!! - Parton, WJ, Schimel, DS, Cole, CV, and Ojima, DS. 1987. Analysis
+!! of factors controlling soil organic matter levels in Great Plains
+!! grasslands. Soil Science Society of America journal (USA)
+!! (51):1173-1179.
+!! - Lardy, R, et al., A new method to determine soil organic carbon equilibrium,
+!! Environmental Modelling & Software (2011), doi:10.1016|j.envsoft.2011.05.016
+!!
+!! FLOWCHART    :
+!! \latexonly
+!! \includegraphics(scale=0.5){littercalcflow.jpg}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE littercalc_prognostic (npts, dt, turnover, bm_to_litter, &
+       veget_max, tsurf, tsoil, soilhum, &
+       litterhum, litterpart, litter, dead_leaves, &
+       lignin_struc, lignin_wood, deadleaf_cover, resp_hetero_litter, &
+       soilcarbon_input, control_temp, control_moist, MatrixA, &
+       VectorB)
+
+    !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                              :: npts               !! Domain size - number of grid pixels
+    REAL(r_std), INTENT(in)                                 :: dt                 !! Time step of the simulations for stomate
+                                                                                  !! @tex $(dtradia one\_day^{-1})$ @endtex  
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)              :: veget_max          !! PFT "Maximal" coverage fraction of a PFT 
+                                                                                  !! defined in the input vegetation map 
+                                                                                  !! @tex $(m^2 m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(npts), INTENT(in)                :: tsurf              !! Temperature (K) at the surface
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)           :: tsoil              !! Soil temperature (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)           :: soilhum            !! Daily soil humidity of each soil layer 
+                                                                                  !! (unitless)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                :: litterhum          !! Daily litter humidity (unitless)
+
+
+    !! 0.2 Output variables
+    
+    REAL(r_std), DIMENSION(npts), INTENT(out)               :: deadleaf_cover     !! Fraction of soil covered by dead leaves 
+                                                                                  !! over all PFTs (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)           :: resp_hetero_litter !! Litter heterotrophic respiration. The unit
+                                                                                  !! is given by m^2 of ground.  
+                                                                                  !! @tex $(gC dtradia one\_day^{-1}) m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(npts,ncarb,nvm), INTENT(out)     :: soilcarbon_input   !! Quantity of carbon going into carbon pools
+                                                                                  !! from litter decomposition. The unit is  
+                                                                                  !! given by m^2 of ground 
+                                                                                  !! @tex $(gC m^{-2} dt\_slow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nlevs), INTENT(out)         :: control_temp       !! Temperature control of heterotrophic 
+                                                                                  !! respiration, above and below (0-1, 
+                                                                                  !! unitless)
+    REAL(r_std), DIMENSION(npts,nlevs), INTENT(out)         :: control_moist      !! Moisture control of heterotrophic 
+                                                                                  !! respiration (0.25-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm,nbpools,nbpools), &
+                                                INTENT(out) :: MatrixA            !! Matrix containing the fluxes between the
+                                                                                  !! carbon pools per sechiba time step 
+                                                                                  !! @tex $(gC.m^2.day^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nbpools), INTENT(out)   :: VectorB            !! Vector containing the litter increase per
+                                                                                  !! sechiba time step
+                                                                                  !! @tex $(gC m^{-2})$ @endtex
+   
+    !! 0.3 Modified variables
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                            INTENT(inout)   :: bm_to_litter       !! Conversion of biomass to litter 
+                                                                                  !! @tex $(gC m^{-2} dt\_slow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                            INTENT(inout)   :: turnover           !! Turnover rates of plant biomass 
+                                                                                  !! @tex $(gC m^{-2} dt\_slow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(inout)   :: litterpart         !! Fraction of litter above the ground 
+                                                                                  !! belonging to the different PFTs (0-1, 
+                                                                                  !! unitless)
+    REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements), &
+                                            INTENT(inout)   :: litter             !! Metabolic and structural litter,above and
+                                                                                  !! below ground. The unit is given by m^2 of 
+                                                                                  !! ground @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(inout)   :: dead_leaves        !! Dead leaves per ground unit area, per PFT,
+                                                                                  !! metabolic and structural in 
+                                                                                  !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(inout)   :: lignin_struc       !! Ratio Lignin content in structural litter,
+                                                                                  !! above and below ground, (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(inout)   :: lignin_wood        !! Ratio Lignin/Carbon in woody litter, 
+                                                                                  !! above and below ground
+                                                                                  !! @tex $(gC m^{-2})$ @endtex   
+
+    !! 0.4 Local variables
+    
+    INTEGER(i_std)                                          :: i,j,k,l,m          !! Indices (unitless)
+    INTEGER(i_std)                                          :: ilitt, ilevs, ipar !! Indices (unitless)
+    INTEGER(i_std)                                          :: iele, imbc         !! Indices (unitless)
+    INTEGER(i_std)                                          :: ipts, ivm          !! Indices (unitless)
+    REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:,:,:)        :: litterfrac         !! The fraction of leaves, wood, etc. that 
+                                                                                  !! goes into metabolic and structural 
+                                                                                  !! litterpools (0-1, unitless)
+!$OMP THREADPRIVATE(litterfrac)
+    REAL(r_std), SAVE, DIMENSION(0:nbdl)                    :: z_soil             !! Soil levels (m)
+!$OMP THREADPRIVATE(z_soil)
+    REAL(r_std), DIMENSION(npts)                            :: rpc                !! Integration constant for vertical root 
+                                                                                  !! profiles (unitless)
+    REAL(r_std), SAVE, DIMENSION(nlitt)                     :: litter_tau         !! Turnover time in litter pools (days)
+!$OMP THREADPRIVATE(litter_tau)
+    REAL(r_std), SAVE, DIMENSION(nlitt,ncarb,nlevs)         :: frac_soil          !! Fraction of litter that goes into soil 
+                                                                                  !! (litter -> carbon, above and below). The
+                                                                                  !! remaining part goes to the atmosphere
+!$OMP THREADPRIVATE(frac_soil)
+    REAL(r_std), DIMENSION(npts)                            :: tsoil_decomp       !! Temperature used for decompostition in 
+                                                                                  !! soil (K)
+    REAL(r_std), DIMENSION(npts)                            :: soilhum_decomp     !! Humidity used for decompostition in soil
+                                                                                  !! (unitless)
+    REAL(r_std), DIMENSION(npts)                            :: fd                 !! Fraction of structural or metabolic litter
+                                                                                  !! decomposed (unitless)
+    REAL(r_std), DIMENSION(npts,nelements)                  :: qd                 !! Quantity of structural or metabolic litter
+                                                                                  !! decomposed @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlevs)                  :: old_struc          !! Old structural litter, above and below 
+                                                                                  !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlevs)                  :: old_woody          !! Old woody litter, above and below 
+                                                                                  !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlitt,nlevs,nelements)  :: litter_inc_PFT     !! Increase of litter, per PFT, metabolic and
+                                                                                  !! structural, above and below ground. The 
+                                                                                  !! unit is given by m^2 of ground.  
+                                                                                  !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements)  :: litter_inc         !! Increase of metabolic and structural 
+                                                                                  !! litter, above and below ground. The unit 
+                                                                                  !! is given by m^2 of ground. 
+                                                                                  !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlevs)                  :: lignin_struc_inc   !! Lignin increase in structural litter, 
+                                                                                  !! above and below ground. The unit is given 
+                                                                                  !! by m^2 of ground. 
+                                                                                  !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlevs)                  :: lignin_wood_inc    !! Lignin increase in woody litter, 
+                                                                                  !! above and below ground. The unit is given 
+                                                                                  !! by m^2 of ground. 
+                                                                                  !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlitt,nelements)        :: litter_pft         !! Metabolic and structural litter above the 
+                                                                                  !! ground per PFT
+    REAL(r_std), DIMENSION(npts)                            :: zdiff_min          !! Intermediate field for looking for minimum
+                                                                                  !! of what? this is not used in the code. 
+                                                                                  !! [??CHECK] could we delete it?
+    CHARACTER(LEN=10), DIMENSION(nlitt)                     :: litter_str         !! Messages to write output information about
+                                                                                  !! the litter
+    CHARACTER(LEN=22), DIMENSION(nparts)                    :: part_str           !! Messages to write output information about
+                                                                                  !! the plant
+    CHARACTER(LEN=7), DIMENSION(ncarb)                      :: carbon_str         !! Messages to write output information about
+                                                                                  !! the soil carbon
+    CHARACTER(LEN=5), DIMENSION(nlevs)                      :: level_str          !! Messages to write output information about
+                                                                                  !! the level (aboveground or belowground litter)
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements)      :: check_intern       !! Contains the components of the internal
+                                                                                  !! mass balance chech for this routine
+                                                                                  !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)              :: closure_intern     !! Check closure of internal mass balance
+                                                                                  !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)              :: pool_start         !! Start and end pool of this routine 
+                                                                                  !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)              :: pool_end           !! Start and end pool of this routine 
+                                                                                  !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex  
+ 
+!_ ================================================================================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering littercalc'
+
+ !! 1. Initialisations of the different fields during the first call of the routine 
+
+    IF ( firstcall ) THEN
+
+       !! 1.1 Litter fractions
+       IF ( .NOT. ALLOCATED(litterfrac) ) THEN
+          ALLOCATE(litterfrac(nvm,nparts,nlitt))
+       ENDIF
+
+       !! 1.1.1 litter fractions:
+       !!   what fraction of leaves, wood, etc. goes into metabolic and structural litterpools
+
+       ! PFT 1 needs to be initialised for when everything is printed below
+       litterfrac(1,:,:) = zero
+       
+       DO ipar = 1, nparts
+
+          DO j = 1,nvm
+
+             IF ( ((ipar == isapabove) .OR. (ipar == isapbelow) .OR. &
+                  (ipar == iheartabove) .OR. (ipar == iheartbelow)) &
+                  .AND. is_tree(j) ) THEN
+
+                litterfrac(j,ipar,iwoody) = un
+                litterfrac(j,ipar,imetabolic) = zero
+                litterfrac(j,ipar,istructural) = zero
+
+             ELSE 
+                
+                litterfrac(j,ipar,imetabolic) = metabolic_ref_frac - &
+                     metabolic_LN_ratio * LC(ipar) * CN(ipar)
+                litterfrac(j,ipar,istructural) = un - litterfrac(j,ipar,imetabolic)
+                litterfrac(j,ipar,iwoody) = zero
+
+             ENDIF
+             
+          END DO
+          
+       END DO
+
+       !! 1.1.2 residence times in litter pools (days)
+       ! .5 years, 3 years and ??30 years??(2.45)
+       litter_tau(imetabolic) = tau_metabolic * one_year      
+       litter_tau(istructural) = tau_struct * one_year        
+       litter_tau(iwoody) = tau_woody * one_year            
+
+       !! 1.1.3 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) = frac_soil_struct_aa
+       frac_soil(istructural,iactive,ibelow) = frac_soil_struct_ab
+       frac_soil(istructural,islow,iabove) = frac_soil_struct_sa
+       frac_soil(istructural,islow,ibelow) = frac_soil_struct_sb
+
+       ! metabolic litter: all goes into active pool + respiration.
+       !   Nothing into slow or passive pool.
+       frac_soil(imetabolic,iactive,iabove) = frac_soil_metab_aa
+       frac_soil(imetabolic,iactive,ibelow) = frac_soil_metab_ab
+
+       !! 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'
+       litter_str(iwoody) = 'woody'
+
+       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'
+       part_str(ilabile) = 'labile'
+
+       WRITE(numout,*) 'litter:'
+
+       WRITE(numout,*) '   > C/N ratios: '
+       DO ipar = 1, nparts
+          WRITE(numout,*) '       ', part_str(ipar), ': ',CN(ipar)
+       ENDDO
+
+       WRITE(numout,*) '   > Lignine/C ratios: '
+       DO ipar = 1, nparts
+          WRITE(numout,*) '       ', part_str(ipar), ': ',LC(ipar)
+       ENDDO
+
+       WRITE(numout,*) '   > fraction of compartment that goes into litter: '
+       DO ipar = 1, nparts
+          DO ilitt = 1, nlitt
+             WRITE(numout,*) '       ', part_str(ipar), '-> ',litter_str(ilitt), ':',litterfrac(:,ipar,ilitt)
+          ENDDO
+       ENDDO
+
+       WRITE(numout,*) '   > scaling depth for decomposition (m): ',z_decomp
+
+       WRITE(numout,*) '   > minimal carbon residence time in litter pools (d):'
+       DO ilitt = 1, nlitt
+          WRITE(numout,*) '       ',litter_str(ilitt),':',litter_tau(ilitt)
+       ENDDO
+
+       WRITE(numout,*) '   > litter decomposition flux fraction that really goes '
+       WRITE(numout,*) '     into carbon pools (rest into the atmosphere):'
+       DO ilitt = 1, nlitt
+          DO l = 1, nlevs
+             DO ipar = 1, ncarb
+                WRITE(numout,*) '       ',litter_str(ilitt),' ',level_str(l),' -> ',&
+                     carbon_str(ipar),':', frac_soil(ilitt,ipar,l)
+             ENDDO
+          ENDDO
+       ENDDO
+
+       firstcall = .FALSE.
+
+    ENDIF
+    
+    !! 1.4 set output to zero
+    deadleaf_cover(:) = zero
+    resp_hetero_litter(:,:) = zero
+    soilcarbon_input(:,:,:) = zero
+    pool_start(:,:,:) = zero
+
+    !! 1.5 Initialize check for mass balance closure
+    !  The mass balance is calculated at the end of this routine
+    !  in section 6. Initial biomass and harvest pool all other
+    !  relevant pools were just set to zero.
+    DO iele = 1,nelements
+
+       ! The litter pool
+       DO ilitt = 1,nlitt
+          DO ilevs = 1,nlevs
+             pool_start(:,:,icarbon) = pool_start(:,:,icarbon) + &
+                  (litter(:,ilitt,:,ilevs,iele) * veget_max(:,:))
+          ENDDO
+       ENDDO
+
+       ! Pools added to the litter
+       DO ipar = 1,nparts
+          pool_start(:,:,icarbon) = pool_start(:,:,icarbon) + &
+               (turnover(:,:,ipar,iele) + bm_to_litter(:,:,ipar,iele)) * &
+               veget_max(:,:)
+       ENDDO  
+
+    ENDDO
+    
+    !! 1.4 litter above the ground per PFT.
+    DO j = 1, nvm ! Loop over # PFTs
+
+       DO k = 1, nlitt !Loop over litter pool
+          litter_pft(:,j,k,icarbon) = litterpart(:,j,k) * litter(:,k,j,iabove,icarbon)
+       ENDDO
+
+    ENDDO
+
+    
+ !! 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 !Loop over litter levels (above and below ground)
+       DO m = 1,nvm !Loop over PFTs
+
+          old_struc(:,m,l) = litter(:,istructural,m,l,icarbon)
+          old_woody(:,m,l) = litter(:,iwoody,m,l,icarbon)
+
+       ENDDO
+    ENDDO
+
+    
+    !! 2.2 update litter, dead leaves, and lignin content in structural litter
+    litter_inc(:,:,:,:,:) = zero
+    lignin_struc_inc(:,:,:) = zero
+    lignin_wood_inc(:,:,:) = zero
+
+    DO j = 1,nvm !Loop over PFTs
+
+       !! 2.2.1 litter
+       DO ilitt = 1, nlitt    !Loop over litter pools (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,ilitt,iabove,icarbon) = &
+               litterfrac(j,ileaf,ilitt) * bm_to_litter(:,j,ileaf,icarbon) + &
+               litterfrac(j,isapabove,ilitt) * bm_to_litter(:,j,isapabove,icarbon) + &
+               litterfrac(j,iheartabove,ilitt) * bm_to_litter(:,j,iheartabove,icarbon) + &
+               litterfrac(j,ifruit,ilitt) * bm_to_litter(:,j,ifruit,icarbon) + &
+               litterfrac(j,icarbres,ilitt) * bm_to_litter(:,j,icarbres,icarbon) + &
+               litterfrac(j,ilabile,ilitt) * bm_to_litter(:,j,ilabile,icarbon) + &
+               litterfrac(j,ileaf,ilitt) * turnover(:,j,ileaf,icarbon) + &
+               litterfrac(j,isapabove,ilitt) * turnover(:,j,isapabove,icarbon) + &
+               litterfrac(j,iheartabove,ilitt) * turnover(:,j,iheartabove,icarbon) + &
+               litterfrac(j,ifruit,ilitt) * turnover(:,j,ifruit,icarbon) + &
+               litterfrac(j,icarbres,ilitt) * turnover(:,j,icarbres,icarbon) + &
+               litterfrac(j,ilabile,ilitt) * turnover(:,j,ilabile,icarbon)
+
+          litter_inc_PFT(:,j,ilitt,ibelow,icarbon) = &
+               litterfrac(j,isapbelow,ilitt) * bm_to_litter(:,j,isapbelow,icarbon) + &
+               litterfrac(j,iheartbelow,ilitt) * bm_to_litter(:,j,iheartbelow,icarbon) + &
+               litterfrac(j,iroot,ilitt) * bm_to_litter(:,j,iroot,icarbon) + &
+               litterfrac(j,isapbelow,ilitt) * turnover(:,j,isapbelow,icarbon) + &
+               litterfrac(j,iheartbelow,ilitt) * turnover(:,j,iheartbelow,icarbon) + &
+               litterfrac(j,iroot,ilitt) * turnover(:,j,iroot,icarbon)
+
+          ! litter increase, met/struct, above/below
+          litter_inc(:,ilitt,j,iabove,icarbon) = litter_inc(:,ilitt,j,iabove,icarbon) + &
+               litter_inc_PFT(:,j,ilitt,iabove,icarbon)
+          litter_inc(:,ilitt,j,ibelow,icarbon) = litter_inc(:,ilitt,j,ibelow,icarbon) + &
+               litter_inc_PFT(:,j,ilitt,ibelow,icarbon)
+
+          !! 2.2.3 dead leaves, for soil cover.
+          IF ( ilitt /= iwoody ) THEN
+
+             dead_leaves(:,j,ilitt) = &
+                  dead_leaves(:,j,ilitt) + &
+                  litterfrac(j,ileaf,ilitt) * ( bm_to_litter(:,j,ileaf,icarbon) + turnover(:,j,ileaf,icarbon) )
+
+          END IF
+
+          !! 2.2.4 lignin increase in structural litter
+          IF ( ilitt == istructural ) THEN
+
+             lignin_struc_inc(:,j,iabove) = &
+                  lignin_struc_inc(:,j,iabove) + &
+                  LC(ileaf) * bm_to_litter(:,j,ileaf,icarbon) + &
+                  LC(isapabove) * bm_to_litter(:,j,isapabove,icarbon) + &
+                  LC(iheartabove) * bm_to_litter(:,j,iheartabove,icarbon) + &
+                  LC(ifruit) * bm_to_litter(:,j,ifruit,icarbon) + &
+                  LC(icarbres) * bm_to_litter(:,j,icarbres,icarbon) + &
+                  LC(ilabile) * bm_to_litter(:,j,ilabile,icarbon) + &
+                  LC(ileaf) * turnover(:,j,ileaf,icarbon) + &
+                  LC(isapabove) * turnover(:,j,isapabove,icarbon) + &
+                  LC(iheartabove) * turnover(:,j,iheartabove,icarbon) + &
+                  LC(ifruit) * turnover(:,j,ifruit,icarbon) + &
+                  LC(icarbres) * turnover(:,j,icarbres,icarbon) + &
+                  LC(ilabile) * turnover(:,j,ilabile,icarbon)
+
+             lignin_struc_inc(:,j,ibelow) = &
+                  lignin_struc_inc(:,j,ibelow) + &
+                  LC(isapbelow) * bm_to_litter(:,j,isapbelow,icarbon) + &
+                  LC(iheartbelow) * bm_to_litter(:,j,iheartbelow,icarbon) + &
+                  LC(iroot) * bm_to_litter(:,j,iroot,icarbon) + &
+                  LC(isapbelow)*turnover(:,j,isapbelow,icarbon) + &
+                  LC(iheartbelow)*turnover(:,j,iheartbelow,icarbon) + &
+                  LC(iroot)*turnover(:,j,iroot,icarbon)
+
+          ELSEIF ( ilitt == iwoody ) THEN
+             
+             lignin_wood_inc(:,j,iabove) = &
+                  LC(isapabove) * bm_to_litter(:,j,isapabove,icarbon) + &
+                  LC(iheartabove) * bm_to_litter(:,j,iheartabove,icarbon) + &
+                  LC(isapabove) * turnover(:,j,isapabove,icarbon) + &
+                  LC(iheartabove) * turnover(:,j,iheartabove,icarbon) 
+             
+             lignin_wood_inc(:,j,ibelow) = &
+                  LC(isapbelow) * bm_to_litter(:,j,isapbelow,icarbon) + &
+                  LC(iheartbelow) * bm_to_litter(:,j,iheartbelow,icarbon) + &
+                  LC(isapbelow)*turnover(:,j,isapbelow,icarbon) + &
+                  LC(iheartbelow)*turnover(:,j,iheartbelow,icarbon) 
+
+          ENDIF
+
+       ENDDO ! #nlitt
+
+    ENDDO !#nvm
+
+    !! 2.2.5 add new litter (struct/met, above/below)
+    litter(:,:,:,:,:) = litter(:,:,:,:,:) + litter_inc(:,:,:,:,:)
+
+    !! 2.2.6 for security: can't add more lignin than structural litter (above/below)
+    DO l = 1, nlevs !Loop over litter levels (above and below ground)
+       DO m = 1,nvm !Lopp over PFTs
+
+          lignin_struc_inc(:,m,l) = &
+               MIN( lignin_struc_inc(:,m,l), litter_inc(:,istructural,m,l,icarbon) )
+
+          lignin_wood_inc(:,m,l) = &
+               MIN( lignin_wood_inc(:,m,l), litter_inc(:,iwoody,m,l,icarbon) )
+
+       ENDDO
+    ENDDO
+
+    !! 2.2.7 new lignin content: add old lignin and lignin increase, divide by 
+    !!       total structural litter (above/below)
+    DO l = 1, nlevs !Loop over litter levels (above and below ground)
+       
+       DO m = 1,nvm !Loop over PFTs
+       
+          WHERE( litter(:,istructural,m,l,icarbon) .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,icarbon)
+
+          ELSEWHERE
+
+             lignin_struc(:,m,l) = zero
+
+          ENDWHERE
+      
+       ENDDO
+   
+    ENDDO
+
+    WHERE ( litter(:,iwoody,:,:,icarbon) .GT. min_stomate )
+     
+       lignin_wood(:,:,:) =  &
+            ( lignin_wood(:,:,:)*old_woody(:,:,:) + lignin_wood_inc(:,:,:) ) / &
+            litter(:,iwoody,:,:,icarbon)
+   
+    ELSEWHERE
+    
+       lignin_wood(:,:,:) = zero
+    
+    ENDWHERE
+    
+    !! 2.3 new litter fraction per PFT (for structural and metabolic litter, above
+    !!       the ground).
+    DO j = 1,nvm !Loop over PFTs
+
+       WHERE ( litter(:,:,j,iabove,icarbon) .GT. min_stomate )
+
+          litterpart(:,j,:) = &
+               ( litter_pft(:,j,:,icarbon) + litter_inc_PFT(:,j,:,iabove,icarbon) ) / &
+               litter(:,:,j,iabove,icarbon)
+
+       ELSEWHERE
+
+          litterpart(:,j,:) = zero
+
+       ENDWHERE
+
+    ENDDO
+
+
+ !! 3. Temperature control on decay: Factor between 0 and 1
+
+    !! 3.1 above: surface temperature
+    control_temp(:,iabove) = control_temp_func (npts, tsurf)
+
+    
+    !! 3.2 below: convolution of temperature and decomposer profiles
+    !!            (exponential decomposer profile supposed)
+   
+    !! 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_decomp ) )
+
+    !! 3.2.2 integrate over the nbdl levels
+    tsoil_decomp(:) = zero
+
+    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)
+
+
+ !! 4. Moisture control. Factor between 0 and 1
+    
+    !! 4.1 above the ground: litter humidity
+    control_moist(:,iabove) = control_moist_func (npts, litterhum)
+
+    !
+    !! 4.2 below: convolution of humidity 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
+    soilhum_decomp(:) = zero
+
+    DO l = 1, nbdl !Loop over soil levels
+
+       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)
+
+
+ !! 5. fluxes from litter to carbon pools and respiration
+
+    DO l = 1, nlevs !Loop over litter levels (above and below ground)
+
+       DO m = 1,nvm !Loop over PFTs
+
+          !! 5.1 structural litter: goes into active and slow carbon pools + respiration
+
+          !! 5.1.1 total quantity of structural litter which is decomposed
+          fd(:) = dt/litter_tau(istructural) * &
+               control_temp(:,l) * control_moist(:,l) * exp( -litter_struct_coef * lignin_struc(:,m,l) )
+
+          DO iele = 1,nelements
+             
+             qd(:,iele) = litter(:,istructural,m,l,iele) * fd(:)
+
+          END DO
+ 
+          litter(:,istructural,m,l,:) = litter(:,istructural,m,l,:) - qd(:,:)
+
+          !! 5.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(:) )
+
+          !! 5.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(:,icarbon) * ( 1. - lignin_struc(:,m,l) ) / dt
+
+          !BE CAREFUL: Here resp_hetero_litter is divided by dt to have a value which corresponds to
+          ! the sechiba time step but then in stomate.f90 resp_hetero_litter is multiplied by dt.
+          ! Perhaps it could be simplified. Moreover, we must totally adapt the routines to the dtradia/one_day
+          ! time step and avoid some constructions that could create bug during future developments.
+          resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
+               ( 1. - frac_soil(istructural,iactive,l) ) * qd(:,icarbon) * &
+               ( 1. - lignin_struc(:,m,l) ) / dt
+
+          !! 5.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(:,icarbon) * lignin_struc(:,m,l) / dt
+
+          !BE CAREFUL: Here resp_hetero_litter is divided by dt to have a value which corresponds to
+          ! the sechiba time step but then in stomate.f90 resp_hetero_litter is multiplied by dt.
+          ! Perhaps it could be simplified. Moreover, we must totally adapt the routines to the dtradia/one_day
+          ! time step and avoid some constructions that could create bug during future developments.
+          resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
+               ( 1. - frac_soil(istructural,islow,l) ) * qd(:,icarbon) * lignin_struc(:,m,l) / dt
+
+          !! 5.2 metabolic litter goes into active carbon pool + respiration
+         
+          !! 5.2.1 total quantity of metabolic litter that is decomposed
+          fd(:) = dt/litter_tau(imetabolic) * control_temp(:,l) * control_moist(:,l)
+
+          DO iele = 1,nelements
+          
+             qd(:,iele) = litter(:,imetabolic,m,l,iele) * fd(:)
+
+          END DO
+
+          litter(:,imetabolic,m,l,:) = litter(:,imetabolic,m,l,:) - qd(:,:)
+
+          !! 5.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(:) )
+
+
+          !! 5.2.3 put decomposed litter into carbon pool + respiration
+          soilcarbon_input(:,iactive,m) = soilcarbon_input(:,iactive,m) + &
+               frac_soil(imetabolic,iactive,l) * qd(:,icarbon) / dt
+
+          !BE CAREFUL: Here resp_hetero_litter is divided by dt to have a value which corresponds to
+          ! the sechiba time step but then in stomate.f90 resp_hetero_litter is multiplied by dt.
+          ! Perhaps it could be simplified. Moreover, we must totally adapt the routines to the dtradia/one_day
+          ! time step and avoid some constructions that could create bug during future developments.
+          resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
+               ( 1. - frac_soil(imetabolic,iactive,l) ) * qd(:,icarbon) / dt
+
+          !! 5.3 woody litter: goes into active and slow carbon pools + respiration
+          
+          !! 5.3.1 total quantity of woody litter which is decomposed
+    
+          fd(:) = dt/litter_tau(iwoody) * &
+               control_temp(:,l) * control_moist(:,l) * EXP( -3. * lignin_wood(:,m,l) )
+          
+          DO iele = 1,nelements 
+             
+             qd(:,iele) = litter(:,iwoody,m,l,iele) * fd(:)
+
+          END DO
+          
+          litter(:,iwoody,m,l,:) = litter(:,iwoody,m,l,:) - qd(:,:)
+
+          !! 5.3.2 non-lignin fraction of woody litter goes into
+          !!       active/structural carbon pool + respiration (per time unit)
+          
+          soilcarbon_input(:,iactive,m) = soilcarbon_input(:,iactive,m) + &
+               frac_soil(istructural,iactive,l) * qd(:,icarbon) * ( 1. - lignin_wood(:,m,l) ) / dt
+
+          resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
+               ( 1. - frac_soil(istructural,iactive,l) ) * qd(:,icarbon) * &
+               ( 1. - lignin_wood(:,m,l) ) / dt
+
+          !! 5.3.3 lignin fraction of woody litter goes into
+          !!       slow carbon pool + respiration (per time unit)
+          
+          soilcarbon_input(:,islow,m) = soilcarbon_input(:,islow,m) + &
+               frac_soil(istructural,islow,l) * qd(:,icarbon) * lignin_wood(:,m,l) / dt
+    
+          resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
+               ( 1. - frac_soil(istructural,islow,l) ) * qd(:,icarbon) * lignin_wood(:,m,l) / dt
+          
+       ENDDO
+    ENDDO
+
+
+ !! 6. Check mass balance closure
+    
+    !! 6.1 Calculate components of the mass balance
+    !  The carbon in turnover and bm_to_litter is moved to different pools but
+    !  ::turnover and ::bm_to_litter are never updated. They should either be
+    !  set to zero or not be included in the calculation of ::pool_end 
+    pool_end(:,:,:) = zero 
+    DO iele = 1,nelements
+
+       ! The litter pool
+       DO ilitt = 1,nlitt
+          DO ilevs = 1,nlevs
+             pool_end(:,:,iele) = pool_end(:,:,iele) + &
+                  (litter(:,ilitt,:,ilevs,iele) * veget_max(:,:))
+          ENDDO
+       ENDDO
+
+    ENDDO
+
+    !! 6.2 Calculate mass balance
+    check_intern(:,:,iatm2land,icarbon) = zero
+    check_intern(:,:,iland2atm,icarbon) = -un * resp_hetero_litter(:,:) * &
+         veget_max(:,:) * dt
+    check_intern(:,:,ilat2out,icarbon) = -un * SUM(soilcarbon_input(:,:,:),2) * &
+         veget_max(:,:) * dt 
+    check_intern(:,:,ilat2in,icarbon) = zero 
+    check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - &
+         pool_start(:,:,icarbon))
+    closure_intern = zero
+    DO imbc = 1,nmbcomp
+       closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + &
+            check_intern(:,:,imbc,icarbon)
+    ENDDO
+
+    !! 6.3 Write the verdict
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          IF(ABS(closure_intern(ipts,ivm,icarbon)) .LE. min_stomate)THEN
+             IF (ld_massbal) WRITE(numout,*) 'Mass balance closure in stomate_soilcarbon.f90'
+          ELSE
+             WRITE(numout,*) 'Error: mass balance is not closed in stomate_litter.f90'
+             WRITE(numout,*) '   ipts,ivm; ', ipts,ivm
+             WRITE(numout,*) '   Difference is, ', closure_intern(ipts,ivm,icarbon)
+             WRITE(numout,*) '   pool_end,pool_start: ', pool_end(ipts,ivm,icarbon), pool_start(ipts,ivm,icarbon)
+             WRITE(numout,*) '   resp_hetero_litter,veget_max: ', resp_hetero_litter(ipts,ivm),veget_max(ipts,ivm) 
+             WRITE(numout,*) '   SUM(soilcarbon_input): ', SUM(soilcarbon_input(ipts,:,ivm))
+             WRITE(numout,*) '   soilcarbon_input: ', soilcarbon_input(ipts,:,ivm)
+             IF(ld_stop)THEN
+                CALL ipslerr_p (3,'littercalc_prognostic', 'Mass balance error.','','')
+             ENDIF
+          ENDIF
+       ENDDO
+    ENDDO
+
+ !! 7. calculate fraction of total soil covered by dead leaves
+
+    CALL deadleaf (npts, veget_max, dead_leaves, deadleaf_cover)
+
+
+ !! 8. (Quasi-)Analytical Spin-up : Start filling MatrixA
+
+    IF (spinup_analytic) THEN
+
+       MatrixA(:,:,:,:) = zero
+       VectorB(:,:,:) = zero
+       
+       DO m = 1,nvm
+
+          !- MatrixA : carbon fluxes leaving the litter
+          
+          MatrixA(:,m,istructural_above,istructural_above)= - dt/litter_tau(istructural) * &
+               control_temp(:,iabove) * control_moist(:,iabove) * exp( -litter_struct_coef * lignin_struc(:,m,iabove) )
+          MatrixA(:,m,istructural_below,istructural_below) = - dt/litter_tau(istructural) * &
+               control_temp(:,ibelow) * control_moist(:,ibelow) * exp( -litter_struct_coef * lignin_struc(:,m,ibelow) )
+          
+          MatrixA(:,m,imetabolic_above,imetabolic_above) = - dt/litter_tau(imetabolic) * & 
+               control_temp(:,iabove) * control_moist(:,iabove)
+          
+          MatrixA(:,m,imetabolic_below,imetabolic_below) = - dt/litter_tau(imetabolic) * & 
+               control_temp(:,ibelow) * control_moist(:,ibelow)
+
+          ! Flux leaving the woody above litter pool :
+          MatrixA(:, m, iwoody_above, iwoody_above) = - dt /litter_tau(iwoody) * control_temp(:,iabove) * &
+               control_moist(:,iabove) * exp( -3. * lignin_wood(:,m,iabove) )
+
+          ! Flux leaving the woody below litter pool :
+          MatrixA(:, m, iwoody_below, iwoody_below) = - dt /litter_tau(iwoody) * control_temp(:,ibelow) * &
+               control_moist(:,ibelow) * exp( -3. * lignin_wood(:,m,ibelow))
+
+          ! Flux received by the carbon active from the woody above litter pool :
+          MatrixA(:, m, iactive, iwoody_above) = frac_soil(istructural, iactive, iabove) * & 
+               dt /litter_tau(iwoody) * & 
+               control_temp(:,iabove) * &
+               control_moist(:,iabove) *  &
+               exp( -3. * lignin_wood(:,m,iabove) ) * ( 1. -  lignin_wood(:,m,iabove) ) 
+
+          ! Flux received by the carbon active from the woody below litter pool :
+          MatrixA(:, m, iactive, iwoody_below) = frac_soil(istructural, iactive, ibelow) * & 
+               dt /litter_tau(iwoody) * &
+               control_temp(:,ibelow) * &
+               control_moist(:,ibelow) * &
+               exp( -3. * lignin_wood(:,m,ibelow) ) * ( 1. -  lignin_wood(:,m,ibelow) ) 
+
+          ! Flux received by the carbon slow from the woody above litter pool :
+          MatrixA(:, m, islow, iwoody_above) = frac_soil(istructural, islow, iabove) * &
+               dt /litter_tau(iwoody) * &
+               control_temp(:,iabove) * &
+               control_moist(:,iabove) * &
+               exp( -3. * lignin_wood(:,m,iabove) ) * lignin_wood(:,m,iabove)
+
+          ! Flux received by the carbon slow from the woody below litter pool :
+          MatrixA(:, m, islow, iwoody_below) =  frac_soil(istructural, islow, ibelow) * & 
+               dt /litter_tau(iwoody) * & 
+               control_temp(:,ibelow) * &
+               control_moist(:,ibelow) * &
+               exp( -3. * lignin_wood(:,m,ibelow) ) * lignin_wood(:,m,ibelow)
+
+          
+          !- MatrixA : carbon fluxes between the litter and the pools (the rest of the matrix is filled in stomate_soilcarbon.f90)
+          
+          MatrixA(:,m,iactive_pool,istructural_above) = frac_soil(istructural,iactive,iabove) * &
+               dt/litter_tau(istructural) * &                    
+               control_temp(:,iabove) * control_moist(:,iabove) * & 
+               exp( -litter_struct_coef * lignin_struc(:,m,iabove) ) * &
+               ( 1. - lignin_struc(:,m,iabove) )
+
+          MatrixA(:,m,iactive_pool,istructural_below) = frac_soil(istructural,iactive,ibelow) * &
+               dt/litter_tau(istructural) * &                     
+               control_temp(:,ibelow) * control_moist(:,ibelow) * & 
+               exp( -litter_struct_coef * lignin_struc(:,m,ibelow) ) * &
+               ( 1. - lignin_struc(:,m,ibelow) ) 
+          
+          
+          MatrixA(:,m,iactive_pool,imetabolic_above) =  frac_soil(imetabolic,iactive,iabove) * &
+               dt/litter_tau(imetabolic) * control_temp(:,iabove) * control_moist(:,iabove) 
+          
+          
+          MatrixA(:,m,iactive_pool,imetabolic_below) =  frac_soil(imetabolic,iactive,ibelow) * &
+               dt/litter_tau(imetabolic) * control_temp(:,ibelow) * control_moist(:,ibelow)
+          
+          MatrixA(:,m,islow_pool,istructural_above) = frac_soil(istructural,islow,iabove) * &
+               dt/litter_tau(istructural) * &                   
+               control_temp(:,iabove) * control_moist(:,iabove) * &
+               exp( -litter_struct_coef * lignin_struc(:,m,iabove) )* &
+               lignin_struc(:,m,iabove)
+          
+          MatrixA(:,m,islow_pool,istructural_below) = frac_soil(istructural,islow,ibelow) * &
+               dt/litter_tau(istructural) * &   
+               control_temp(:,ibelow) * control_moist(:,ibelow) *  &
+                  exp( -litter_struct_coef * lignin_struc(:,m,ibelow) )* &
+                  lignin_struc(:,m,ibelow) 
+          
+          
+          !- VectorB : carbon input -
+          
+          VectorB(:,m,istructural_above) = litter_inc_PFT(:,m,istructural,iabove,icarbon)
+          VectorB(:,m,istructural_below) = litter_inc_PFT(:,m,istructural,ibelow,icarbon)
+          VectorB(:,m,imetabolic_above) = litter_inc_PFT(:,m,imetabolic,iabove,icarbon)
+          VectorB(:,m,imetabolic_below) = litter_inc_PFT(:,m,imetabolic,ibelow,icarbon)
+          VectorB(:,m,iwoody_above) = litter_inc_PFT(:,m,iwoody,iabove,icarbon)
+          VectorB(:,m,iwoody_below) = litter_inc_PFT(:,m,iwoody,ibelow,icarbon)
+          
+          IF (bavard.GE.4) WRITE(numout,*) 'We filled MatrixA and VectorB' 
+          
+       ENDDO ! Loop over # PFTs
+
+    ENDIF ! spinup analytic 
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving littercalc'
+
+  END SUBROUTINE littercalc_prognostic
+
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : littercalc_diagnostic
+!!
+!!\BRIEF        Calculation of the litter decomposition and therefore of the 
+!! heterotrophic respiration from litter following Parton et al. (1987).
+!!
+!! DESCRIPTION  : The littercal routine splits the litter in 4 pools: 
+!! aboveground metaboblic, aboveground structural, belowground metabolic and 
+!! belowground structural. the fraction (F) of plant material going to metabolic 
+!! and structural is defined following Parton et al. (1987)
+!! \latexonly
+!! \input{littercalc1.tex}
+!! \endlatexonly
+!! \n
+!! where L is the lignin content of the plant carbon pools considered and CN 
+!! its CN ratio. L and CN are fixed parameters for each plant carbon pools,
+!! therefore it is the ratio between each plant carbon pool within a PFT, which
+!! controlled the part of the total litter, that will be considered as
+!! recalcitrant (i.e. structural litter) or labile (i.e. metabolic litter).\n  
+!! 
+!! The routine calculates the fraction of aboveground litter which is metabolic
+!! or structural (the litterpart variable) which is then used in lpj_fire.f90.\n 
+!! 
+!! In the section 2, the routine calculate the new plant material entering the
+!! litter pools by phenological death of plants organs (corresponding to the
+!! variable turnover) and by fire, herbivory and others non phenological causes
+!! (variable bm_to_litter). This calculation is first done for each PFT and then
+!! the values calculated for each PFT are added up. Following the same approach
+!! the lignin content of the total structural litter is calculated and will be
+!! then used as a factor control of the decomposition of the structural litter
+!! (lignin_struc) in the section 5.1.2. A test is performed to avoid that we add
+!! more lignin than structural litter. Finally, the variable litterpart is
+!! updated.\n
+!! 
+!! In the section 3 and 4 the temperature and the moisture controlling the
+!! decomposition are calculated for above and belowground. For aboveground
+!! litter, air temperature and litter moisture are calculated in sechiba and used 
+!! directly. For belowground, soil temperature and moisture are also calculated 
+!! in sechiba but are modulated as a function of the soil depth. The modulation 
+!! is a multiplying factor exponentially distributed between 0 (in depth) and 1
+!! in surface.\n  
+!! 
+!! Then, in the section 5, the routine calculates the structural litter decomposition 
+!! (C) following first order kinetics following Parton et al. (1987).
+!! \latexonly
+!! \input{littercalc2.tex}
+!! \endlatexonly
+!! \n
+!! with k the decomposition rate of the structural litter. 
+!! k corresponds to
+!! \latexonly
+!! \input{littercalc3.tex}
+!! \endlatexonly
+!! \n
+!! with littertau the turnover rate, T a function of the temperature and M a function of
+!! the moisture described below.\n
+!!  
+!! Then, the fraction of dead leaves (DL) composed by aboveground structural litter is
+!! calculated as following
+!! \latexonly
+!! \input{littercalc4.tex}
+!! \endlatexonly
+!! \n
+!! with k the decomposition rate of the structural litter previously
+!! described.\n
+!!
+!! In the section 5.1, the fraction of decomposed structural litter
+!! incorporated to the soil (Input) and its associated heterotrophic respiration are
+!! calculated. For structural litter, the C decomposed could go in the active
+!! soil carbon pool or in the slow carbon, as described in 
+!! stomate_soilcarbon.f90.\n
+!! \latexonly
+!! \input{littercalc5.tex}
+!! \endlatexonly
+!! \n
+!! with f a parameter describing the fraction of structural litter incorporated
+!! into the considered soil carbon pool, C the amount of litter decomposed and L 
+!! the amount of lignin in the litter. The litter decomposed which is not
+!! incorporated into the soil is respired.\n
+!!
+!! In the section 5.2, the fraction of decomposed metabolic litter
+!! incorporated to the soil and its associated heterotrophic respiration are
+!! calculated with the same approaches presented for 5.1 but no control factor
+!! depending on the lignin content are used.\n
+!! 
+!! In the section 6 the dead leaf cover is calculated through a call to the 
+!! deadleaf subroutine presented below.\n
+!!
+!! In the section 7, if the flag SPINUP_ANALYTIC is set to true, we fill MatrixA
+!! and VectorB following Lardy(2011).
+!!
+!! MAIN OUTPUT VARIABLES: ::deadleaf_cover, ::resp_hetero_litter, ::soilcarbon_input, 
+!! ::control_temp, ::control_moist
+!!
+!! REFERENCES:
+!! - Parton, WJ, Schimel, DS, Cole, CV, and Ojima, DS. 1987. Analysis
+!! of factors controlling soil organic matter levels in Great Plains
+!! grasslands. Soil Science Society of America journal (USA)
+!! (51):1173-1179.
+!! - Lardy, R, et al., A new method to determine soil organic carbon equilibrium,
+!! Environmental Modelling & Software (2011), doi:10.1016|j.envsoft.2011.05.016
+!!
+!! FLOWCHART    :
+!! \latexonly
+!! \includegraphics(scale=0.5){littercalcflow.jpg}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE littercalc_diagnostic (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, &
+       MatrixA, VectorB)
+
+    !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                                  :: npts               !! Domain size - number of grid pixels
+    REAL(r_std), INTENT(in)                                     :: dt                 !! Time step of the simulations for stomate
+                                                                                      !! @tex $(dtradia one\_day^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(in) :: turnover           !! Turnover rates of plant biomass 
+                                                                                      !! @tex $(gC m^{-2} dt\_slow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(in) :: bm_to_litter     !! Conversion of biomass to litter 
+                                                                                      !! @tex $(gC m^{-2} dt\_slow^{-1})$ @endtex 
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)                  :: veget_max          !! PFT "Maximal" coverage fraction of a PFT 
+                                                                                      !! defined in the input vegetation map 
+                                                                                      !! @tex $(m^2 m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: tsurf              !! Temperature (K) at the surface
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)               :: tsoil              !! Soil temperature (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)               :: soilhum            !! Daily soil humidity of each soil layer 
+                                                                                      !! (unitless)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: litterhum          !! Daily litter humidity (unitless)
+
+    !! 0.2 Output variables
+    
+    REAL(r_std), DIMENSION(npts), INTENT(out)                   :: deadleaf_cover     !! Fraction of soil covered by dead leaves 
+                                                                                      !! over all PFTs (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)               :: resp_hetero_litter !! Litter heterotrophic respiration. The unit
+                                                                                      !! is given by m^2 of ground.  
+                                                                                      !! @tex $(gC dtradia one\_day^{-1}) m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(npts,ncarb,nvm), INTENT(out)         :: soilcarbon_input   !! Quantity of carbon going into carbon pools
+                                                                                      !! from litter decomposition. The unit is  
+                                                                                      !! given by m^2 of ground 
+                                                                                      !! @tex $(gC m^{-2} dt\_slow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nlevs), INTENT(out)             :: control_temp       !! Temperature control of heterotrophic 
+                                                                                      !! respiration, above and below (0-1, 
+                                                                                      !! unitless)
+    REAL(r_std), DIMENSION(npts,nlevs), INTENT(out)             :: control_moist      !! Moisture control of heterotrophic 
+                                                                                      !! respiration (0.25-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm,nbpools,nbpools), INTENT(out) :: MatrixA          !! Matrix containing the fluxes between the
+                                                                                      !! carbon pools per sechiba time step 
+                                                                                      !! @tex $(gC.m^2.day^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nbpools), INTENT(out)         :: VectorB          !! Vector containing the litter increase per
+                                                                                      !! sechiba time step
+                                                                                      !! @tex $(gC m^{-2})$ @endtex
+   
+    !! 0.3 Modified variables
+    
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(inout)       :: litterpart         !! Fraction of litter above the ground 
+                                                                                      !! belonging to the different PFTs (0-1, 
+                                                                                      !! unitless)
+    REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements), INTENT(inout) :: litter   !! Metabolic and structural litter,above and
+                                                                                      !! below ground. The unit is given by m^2 of 
+                                                                                      !! ground @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(inout)       :: dead_leaves        !! Dead leaves per ground unit area, per PFT,
+                                                                                      !! metabolic and structural in 
+                                                                                      !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(inout)       :: lignin_struc       !! Ratio Lignin content in structural litter,
+                                                                                      !! above and below ground, (0-1, unitless)
+    
+    !! 0.4 Local variables
+ 
+    REAL(r_std), SAVE, DIMENSION(nparts,nlitt)                  :: litterfrac         !! The fraction of leaves, wood, etc. that 
+                                                                                      !! goes into metabolic and structural 
+                                                                                      !! litterpools (0-1, unitless)
+!$OMP THREADPRIVATE(litterfrac)
+    REAL(r_std), SAVE, DIMENSION(0:nbdl)                        :: z_soil             !! Soil levels (m)
+!$OMP THREADPRIVATE(z_soil)
+    REAL(r_std), DIMENSION(npts)                                :: rpc                !! Integration constant for vertical root 
+                                                                                      !! profiles (unitless)
+    REAL(r_std), SAVE, DIMENSION(nlitt)                         :: litter_tau         !! Turnover time in litter pools (days)
+!$OMP THREADPRIVATE(litter_tau)
+    REAL(r_std), SAVE, DIMENSION(nlitt,ncarb,nlevs)             :: frac_soil          !! Fraction of litter that goes into soil 
+                                                                                      !! (litter -> carbon, above and below). The
+                                                                                      !! remaining part goes to the atmosphere
+!$OMP THREADPRIVATE(frac_soil)
+    REAL(r_std), DIMENSION(npts)                                :: tsoil_decomp       !! Temperature used for decompostition in 
+                                                                                      !! soil (K)
+    REAL(r_std), DIMENSION(npts)                                :: soilhum_decomp     !! Humidity used for decompostition in soil
+                                                                                      !! (unitless)
+    REAL(r_std), DIMENSION(npts)                                :: fd                 !! Fraction of structural or metabolic litter
+                                                                                      !! decomposed (unitless)
+    REAL(r_std), DIMENSION(npts,nelements)                      :: qd                 !! Quantity of structural or metabolic litter
+                                                                                      !! decomposed @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlevs)                      :: old_struc          !! Old structural litter, above and below 
+                                                                                      !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlitt,nlevs,nelements)      :: litter_inc_PFT     !! Increase of litter, per PFT, metabolic and
+                                                                                      !! structural, above and below ground. The 
+                                                                                      !! unit is given by m^2 of ground.  
+                                                                                      !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs,nelements)      :: litter_inc         !! Increase of metabolic and structural 
+                                                                                      !! litter, above and below ground. The unit 
+                                                                                      !! is given by m^2 of ground. 
+                                                                                      !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlevs)                      :: lignin_struc_inc   !! Lignin increase in structural litter, 
+                                                                                      !! above and below ground. The unit is given 
+                                                                                      !! by m^2 of ground. 
+                                                                                      !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nlitt,nelements)            :: litter_pft         !! Metabolic and structural litter above the 
+                                                                                      !! ground per PFT
+    REAL(r_std), DIMENSION(npts)                                :: zdiff_min          !! Intermediate field for looking for minimum
+                                                                                      !! of what? this is not used in the code. 
+                                                                                      !! [??CHECK] could we delete it?
+    CHARACTER(LEN=10), DIMENSION(nlitt)                         :: litter_str         !! Messages to write output information about
+                                                                                      !! the litter
+    CHARACTER(LEN=22), DIMENSION(nparts)                        :: part_str           !! Messages to write output information about
+                                                                                      !! the plant
+    CHARACTER(LEN=7), DIMENSION(ncarb)                          :: carbon_str         !! Messages to write output information about
+                                                                                      !! the soil carbon
+    CHARACTER(LEN=5), DIMENSION(nlevs)                          :: level_str          !! Messages to write output information about
+                                                                                      !! the level (aboveground or belowground litter)
+    INTEGER(i_std)                                              :: i,j,k,l,m          !! Indices (unitless)
+!_ ================================================================================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering littercalc'
+
+  !! 1. Initialisations of the different fields during the first call of the routine 
+
+    IF ( firstcall ) THEN
+
+       !! 1.1.3 litter fractions:
+       !!   what fraction of leaves, wood, etc. goes into metabolic and structural litterpools
+       DO k = 1, nparts
+
+          litterfrac(k,imetabolic) = metabolic_ref_frac - metabolic_LN_ratio * LC(k) * CN(k)
+          litterfrac(k,istructural) = un - litterfrac(k,imetabolic)
+!!!!!!!!!!!!!!!!!!!!!!!! is this correct?
+          litterfrac(k,iwoody) = zero
+
+       ENDDO
+
+       !! 1.1.4 residence times in litter pools (days)
+       litter_tau(imetabolic) = tau_metabolic * one_year      ! .5 years
+       litter_tau(istructural) = tau_struct * one_year     ! 3 years
+       !!!!!! is this right?
+       litter_tau(iwoody) = tau_woody * 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) = frac_soil_struct_aa
+       frac_soil(istructural,iactive,ibelow) = frac_soil_struct_ab
+       frac_soil(istructural,islow,iabove) = frac_soil_struct_sa
+       frac_soil(istructural,islow,ibelow) = frac_soil_struct_sb
+
+       ! metabolic litter: all goes into active pool + respiration.
+       !   Nothing into slow or passive pool.
+       frac_soil(imetabolic,iactive,iabove) = frac_soil_metab_aa
+       frac_soil(imetabolic,iactive,ibelow) = frac_soil_metab_ab
+
+       
+       !! 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'
+       litter_str(iwoody) = 'woody'
+
+       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'
+       part_str(ilabile) = 'labile carbon'
+
+       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 ! Loop over # PFTs
+
+       DO k = 1, nlitt !Loop over litter pool
+          litter_pft(:,j,k,icarbon) = litterpart(:,j,k) * litter(:,k,j,iabove,icarbon)
+       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 !Loop over litter levels (above and below ground)
+       DO m = 1,nvm !Loop over PFTs
+
+          old_struc(:,m,l) = litter(:,istructural,m,l,icarbon)
+
+       ENDDO
+    ENDDO
+
+    
+    !! 2.2 update litter, dead leaves, and lignin content in structural litter
+    litter_inc(:,:,:,:,:) = zero
+    lignin_struc_inc(:,:,:) = zero
+
+    DO j = 1,nvm !Loop over PFTs
+
+       !! 2.2.1 litter
+       DO k = 1, nlitt    !Loop over litter pools (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,icarbon) = &
+               litterfrac(ileaf,k) * bm_to_litter(:,j,ileaf,icarbon) + &
+               litterfrac(isapabove,k) * bm_to_litter(:,j,isapabove,icarbon) + &
+               litterfrac(iheartabove,k) * bm_to_litter(:,j,iheartabove,icarbon) + &
+               litterfrac(ifruit,k) * bm_to_litter(:,j,ifruit,icarbon) + &
+               litterfrac(icarbres,k) * bm_to_litter(:,j,icarbres,icarbon) + &
+               litterfrac(ileaf,k) * turnover(:,j,ileaf,icarbon) + &
+               litterfrac(isapabove,k) * turnover(:,j,isapabove,icarbon) + &
+               litterfrac(iheartabove,k) * turnover(:,j,iheartabove,icarbon) + &
+               litterfrac(ifruit,k) * turnover(:,j,ifruit,icarbon) + &
+               litterfrac(icarbres,k) * turnover(:,j,icarbres,icarbon)
+
+          litter_inc_PFT(:,j,k,ibelow,icarbon) = &
+               litterfrac(isapbelow,k) * bm_to_litter(:,j,isapbelow,icarbon) + &
+               litterfrac(iheartbelow,k) * bm_to_litter(:,j,iheartbelow,icarbon) + &
+               litterfrac(iroot,k) * bm_to_litter(:,j,iroot,icarbon) + &
+               litterfrac(isapbelow,k) * turnover(:,j,isapbelow,icarbon) + &
+               litterfrac(iheartbelow,k) * turnover(:,j,iheartbelow,icarbon) + &
+               litterfrac(iroot,k) * turnover(:,j,iroot,icarbon)
+
+          ! litter increase, met/struct, above/below
+          litter_inc(:,k,j,iabove,icarbon) = litter_inc(:,k,j,iabove,icarbon) + litter_inc_PFT(:,j,k,iabove,icarbon)
+          litter_inc(:,k,j,ibelow,icarbon) = litter_inc(:,k,j,ibelow,icarbon) + litter_inc_PFT(:,j,k,ibelow,icarbon)
+
+          !! 2.2.3 dead leaves, for soil cover.
+          dead_leaves(:,j,k) = &
+               dead_leaves(:,j,k) + &
+               litterfrac(ileaf,k) * ( bm_to_litter(:,j,ileaf,icarbon) + turnover(:,j,ileaf,icarbon) )
+
+          !! 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,icarbon) + &
+                  LC(isapabove) * bm_to_litter(:,j,isapabove,icarbon) + &
+                  LC(iheartabove) * bm_to_litter(:,j,iheartabove,icarbon) + &
+                  LC(ifruit) * bm_to_litter(:,j,ifruit,icarbon) + &
+                  LC(icarbres) * bm_to_litter(:,j,icarbres,icarbon) + &
+                  LC(ileaf) * turnover(:,j,ileaf,icarbon) + &
+                  LC(isapabove) * turnover(:,j,isapabove,icarbon) + &
+                  LC(iheartabove) * turnover(:,j,iheartabove,icarbon) + &
+                  LC(ifruit) * turnover(:,j,ifruit,icarbon) + &
+                  LC(icarbres) * turnover(:,j,icarbres,icarbon)
+
+             lignin_struc_inc(:,j,ibelow) = &
+                  lignin_struc_inc(:,j,ibelow) + &
+                  LC(isapbelow) * bm_to_litter(:,j,isapbelow,icarbon) + &
+                  LC(iheartbelow) * bm_to_litter(:,j,iheartbelow,icarbon) + &
+                  LC(iroot) * bm_to_litter(:,j,iroot,icarbon) + &
+                  LC(isapbelow)*turnover(:,j,isapbelow,icarbon) + &
+                  LC(iheartbelow)*turnover(:,j,iheartbelow,icarbon) + &
+                  LC(iroot)*turnover(:,j,iroot,icarbon)
+
+          ENDIF
+
+       ENDDO
+    ENDDO
+
+    !! 2.2.5 add new litter (struct/met, above/below)
+    litter(:,:,:,:,:) = litter(:,:,:,:,:) + litter_inc(:,:,:,:,:)
+
+    !! 2.2.6 for security: can't add more lignin than structural litter (above/below)
+    DO l = 1, nlevs !Loop over litter levels (above and below ground)
+       DO m = 1,nvm !Lopp over PFTs
+
+          lignin_struc_inc(:,m,l) = &
+               MIN( lignin_struc_inc(:,m,l), litter_inc(:,istructural,m,l,icarbon) )
+
+       ENDDO
+    ENDDO
+
+    !! 2.2.7 new lignin content: add old lignin and lignin increase, divide by 
+    !!       total structural litter (above/below)
+    DO l = 1, nlevs !Loop over litter levels (above and below ground)
+       DO m = 1,nvm !Loop over PFTs
+          WHERE( litter(:,istructural,m,l,icarbon) .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,icarbon)
+          ELSEWHERE
+             lignin_struc(:,m,l) = zero
+          ENDWHERE
+       ENDDO
+    ENDDO
+
+    
+    !! 2.3 new litter fraction per PFT (for structural and metabolic litter, above
+    !!       the ground).
+    DO j = 1,nvm !Loop over PFTs
+
+       WHERE ( litter(:,:,j,iabove,icarbon) .GT. min_stomate )
+
+          litterpart(:,j,:) = &
+               ( litter_pft(:,j,:,icarbon) + litter_inc_PFT(:,j,:,iabove,icarbon) ) / litter(:,:,j,iabove,icarbon)
+
+       ELSEWHERE
+
+          litterpart(:,j,:) = zero
+
+       ENDWHERE
+
+    ENDDO
+
+    
+  !! 3. Temperature control on decay: Factor between 0 and 1
+
+    !! 3.1 above: surface temperature
+    control_temp(:,iabove) = control_temp_func (npts, tsurf)
+
+    
+    !! 3.2 below: convolution of temperature and decomposer profiles
+    !!            (exponential decomposer profile supposed)
+   
+    !! 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_decomp ) )
+
+    !! 3.2.2 integrate over the nbdl levels
+    tsoil_decomp(:) = zero
+
+    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)
+
+  !! 4. Moisture control. Factor between 0 and 1
+    
+    !! 4.1 above the ground: litter humidity
+    control_moist(:,iabove) = control_moist_func (npts, litterhum)
+
+    !
+    !! 4.2 below: convolution of humidity 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
+    soilhum_decomp(:) = zero
+
+    DO l = 1, nbdl !Loop over soil levels
+
+       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)
+
+  !! 5. fluxes from litter to carbon pools and respiration
+
+    DO l = 1, nlevs !Loop over litter levels (above and below ground)
+       DO m = 1,nvm !Loop over PFTs
+
+          !! 5.1 structural litter: goes into active and slow carbon pools + respiration
+
+          !! 5.1.1 total quantity of structural litter which is decomposed
+          fd(:) = dt/litter_tau(istructural) * &
+               control_temp(:,l) * control_moist(:,l) * exp( -litter_struct_coef * lignin_struc(:,m,l) )
+
+          DO k = 1,nelements
+             
+             qd(:,k) = litter(:,istructural,m,l,k) * fd(:)
+
+          END DO
+
+          litter(:,istructural,m,l,:) = litter(:,istructural,m,l,:) - qd(:,:)
+
+          !! 5.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(:) )
+
+          !! 5.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(:,icarbon) * ( 1. - lignin_struc(:,m,l) ) / dt
+
+          !BE CAREFUL: Here resp_hetero_litter is divided by dt to have a value which corresponds to
+          ! the sechiba time step but then in stomate.f90 resp_hetero_litter is multiplied by dt.
+          ! Perhaps it could be simplified. Moreover, we must totally adapt the routines to the dtradia/one_day
+          ! time step and avoid some constructions that could create bug during future developments.
+          resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
+               ( 1. - frac_soil(istructural,iactive,l) ) * qd(:,icarbon) * &
+               ( 1. - lignin_struc(:,m,l) ) / dt
+
+          !! 5.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(:,icarbon) * lignin_struc(:,m,l) / dt
+
+          !BE CAREFUL: Here resp_hetero_litter is divided by dt to have a value which corresponds to
+          ! the sechiba time step but then in stomate.f90 resp_hetero_litter is multiplied by dt.
+          ! Perhaps it could be simplified. Moreover, we must totally adapt the routines to the dtradia/one_day
+          ! time step and avoid some constructions that could create bug during future developments.
+          resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
+               ( 1. - frac_soil(istructural,islow,l) ) * qd(:,icarbon) * lignin_struc(:,m,l) / dt
+
+          
+          !! 5.2 metabolic litter goes into active carbon pool + respiration
+         
+          !! 5.2.1 total quantity of metabolic litter that is decomposed
+          fd(:) = dt/litter_tau(imetabolic) * control_temp(:,l) * control_moist(:,l)
+
+          DO k = 1,nelements
+          
+             qd(:,k) = litter(:,imetabolic,m,l,k) * fd(:)
+
+          END DO
+
+          litter(:,imetabolic,m,l,:) = litter(:,imetabolic,m,l,:) - qd(:,:)
+
+          !! 5.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(:) )
+
+
+          !! 5.2.3 put decomposed litter into carbon pool + respiration
+          soilcarbon_input(:,iactive,m) = soilcarbon_input(:,iactive,m) + &
+               frac_soil(imetabolic,iactive,l) * qd(:,icarbon) / dt
+
+          !BE CAREFUL: Here resp_hetero_litter is divided by dt to have a value which corresponds to
+          ! the sechiba time step but then in stomate.f90 resp_hetero_litter is multiplied by dt.
+          ! Perhaps it could be simplified. Moreover, we must totally adapt the routines to the dtradia/one_day
+          ! time step and avoid some constructions that could create bug during future developments.
+          resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
+               ( 1. - frac_soil(imetabolic,iactive,l) ) * qd(:,icarbon) / dt
+
+       ENDDO
+    ENDDO
+
+    
+  !! 6. calculate fraction of total soil covered by dead leaves
+
+    CALL deadleaf (npts, veget_max, dead_leaves, deadleaf_cover)
+
+  !! 7. (Quasi-)Analytical Spin-up : Start filling MatrixA
+
+    IF (spinup_analytic) THEN
+
+       MatrixA(:,:,:,:) = zero
+       VectorB(:,:,:) = zero
+       
+       
+       DO m = 2,nvm
+
+          !- MatrixA : carbon fluxes leaving the litter
+          
+          MatrixA(:,m,istructural_above,istructural_above)= - dt/litter_tau(istructural) * &
+               control_temp(:,iabove) * control_moist(:,iabove) * exp( -litter_struct_coef * lignin_struc(:,m,iabove) )
+          
+          MatrixA(:,m,istructural_below,istructural_below) = - dt/litter_tau(istructural) * &
+               control_temp(:,ibelow) * control_moist(:,ibelow) * exp( -litter_struct_coef * lignin_struc(:,m,ibelow) )
+          
+          MatrixA(:,m,imetabolic_above,imetabolic_above) = - dt/litter_tau(imetabolic) * & 
+               control_temp(:,iabove) * control_moist(:,iabove)
+          
+          MatrixA(:,m,imetabolic_below,imetabolic_below) = - dt/litter_tau(imetabolic) * & 
+               control_temp(:,ibelow) * control_moist(:,ibelow)
+          
+          
+          !- MatrixA : carbon fluxes between the litter and the pools (the rest of the matrix is filled in stomate_soilcarbon.f90)
+          
+          MatrixA(:,m,iactive_pool,istructural_above) = frac_soil(istructural,iactive,iabove) * &
+               dt/litter_tau(istructural) * &                    
+               control_temp(:,iabove) * control_moist(:,iabove) * & 
+               exp( -litter_struct_coef * lignin_struc(:,m,iabove) ) * &
+               ( 1. - lignin_struc(:,m,iabove) ) 
+          
+
+          MatrixA(:,m,iactive_pool,istructural_below) = frac_soil(istructural,iactive,ibelow) * &
+               dt/litter_tau(istructural) * &                     
+               control_temp(:,ibelow) * control_moist(:,ibelow) * & 
+               exp( -litter_struct_coef * lignin_struc(:,m,ibelow) ) * &
+               ( 1. - lignin_struc(:,m,ibelow) ) 
+          
+          
+          MatrixA(:,m,iactive_pool,imetabolic_above) =  frac_soil(imetabolic,iactive,iabove) * &
+               dt/litter_tau(imetabolic) * control_temp(:,iabove) * control_moist(:,iabove) 
+          
+          
+          MatrixA(:,m,iactive_pool,imetabolic_below) =  frac_soil(imetabolic,iactive,ibelow) * &
+               dt/litter_tau(imetabolic) * control_temp(:,ibelow) * control_moist(:,ibelow)
+          
+          MatrixA(:,m,islow_pool,istructural_above) = frac_soil(istructural,islow,iabove) * &
+               dt/litter_tau(istructural) * &                   
+               control_temp(:,iabove) * control_moist(:,iabove) * &
+               exp( -litter_struct_coef * lignin_struc(:,m,iabove) )* &
+               lignin_struc(:,m,iabove)
+          
+          
+          MatrixA(:,m,islow_pool,istructural_below) = frac_soil(istructural,islow,ibelow) * &
+               dt/litter_tau(istructural) * &   
+               control_temp(:,ibelow) * control_moist(:,ibelow) *  &
+                  exp( -litter_struct_coef * lignin_struc(:,m,ibelow) )* &
+                  lignin_struc(:,m,ibelow) 
+          
+          
+          !- VectorB : carbon input -
+          
+          VectorB(:,m,istructural_above) = litter_inc_PFT(:,m,istructural,iabove,icarbon)
+          VectorB(:,m,istructural_below) = litter_inc_PFT(:,m,istructural,ibelow,icarbon)
+          VectorB(:,m,imetabolic_above) = litter_inc_PFT(:,m,imetabolic,iabove,icarbon)
+          VectorB(:,m,imetabolic_below) = litter_inc_PFT(:,m,imetabolic,ibelow,icarbon)
+          
+          IF (bavard.GE.4) WRITE(numout,*) 'We filled MatrixA and VectorB' 
+          
+       ENDDO ! Loop over # PFTs
+          
+    ENDIF ! spinup analytic 
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving littercalc'
+
+  END SUBROUTINE littercalc_diagnostic
+
+
+
+!! ==============================================================================================================================\n
+!! SUBROUTINE   : deadleaf
+!!
+!>\BRIEF        This routine calculates the deadleafcover. 
+!!
+!! DESCRIPTION  : It first calculates the lai corresponding to the dead leaves (LAI) using 
+!! the dead leaves carbon content (DL) the specific leaf area (sla) and the 
+!! maximal coverage fraction of a PFT (vegetmax) using the following equations:
+!! \latexonly
+!! \input{deadleaf1.tex}
+!! \endlatexonly
+!! \n
+!! Then, the dead leaf cover (DLC) is calculated as following:\n
+!! \latexonly
+!! \input{deadleaf2.tex}
+!! \endlatexonly
+!! \n
+!! 
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE: ::deadleaf_cover
+!! 
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE deadleaf (npts, veget_max, dead_leaves, deadleaf_cover)
+
+  !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                          :: npts           !! Domain size - number of grid pixels (unitless)
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(in)  :: dead_leaves    !! Dead leaves per ground unit area, per PFT, 
+                                                                          !! metabolic and structural  
+                                                                          !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)          :: veget_max      !! PFT "Maximal" coverage fraction of a PFT defined in 
+                                                                          !! the input vegetation map 
+                                                                          !! @tex $(m^2 m^{-2})$ @endtex 
+    
+    !! 0.2 Output variables
+    
+    REAL(r_std), DIMENSION(npts), INTENT(out)           :: deadleaf_cover !! Fraction of soil covered by dead leaves over all PFTs
+                                                                          !! (0-1, unitless)
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    REAL(r_std), DIMENSION(npts)                        :: dead_lai       !! LAI of dead leaves @tex $(m^2 m^{-2})$ @endtex
+    INTEGER(i_std)                                      :: j              !! Index (unitless)
+!_ ================================================================================================================================
+    
+  !! 1. LAI of dead leaves
+  
+    dead_lai(:) = zero
+
+    DO j = 1,nvm !Loop over PFTs
+       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(:) = un - exp( - 0.5 * dead_lai(:) )
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving deadleaf'
+
+  END SUBROUTINE deadleaf
+
+
+
+!! ================================================================================================================================
+!! FUNCTION     : control_moist_func
+!!
+!>\BRIEF        Calculate moisture control for litter and soild C decomposition
+!!
+!! DESCRIPTION  : Calculate moisture control factor applied
+!! to litter decomposition and to soil carbon decomposition in
+!! stomate_soilcarbon.f90 using the following equation: \n
+!! \latexonly
+!! \input{control_moist_func1.tex}
+!! \endlatexonly
+!! \n
+!! with M the moisture control factor and soilmoisutre, the soil moisture 
+!! calculated in sechiba.
+!! Then, the function is ranged between 0.25 and 1:\n
+!! \latexonly
+!! \input{control_moist_func2.tex}
+!! \endlatexonly
+!! \n
+!! RECENT CHANGE(S) : None
+!!
+!! RETURN VALUE : ::moistfunc_result
+!! 
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART : None
+!! \n
+!_ ================================================================================================================================
+  
+  FUNCTION control_moist_func (npts, moist_in) RESULT (moistfunc_result)
+
+  !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+          
+    INTEGER(i_std), INTENT(in)               :: npts                !! Domain size - number of grid pixel (unitless)
+    REAL(r_std), DIMENSION(npts), INTENT(in) :: moist_in            !! relative humidity (unitless)
+
+    !! 0.2 Output variables
+   
+    REAL(r_std), DIMENSION(npts)             :: moistfunc_result    !! Moisture control factor (0.25-1, unitless)
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+!_ ================================================================================================================================
+
+    moistfunc_result(:) = moist_coeff(1) * moist_in(:) * moist_in(:) + moist_coeff(2)* moist_in(:) + moist_coeff(3)
+    moistfunc_result(:) = MAX( moistcont_min, MIN( un, moistfunc_result(:) ) )
+
+  END FUNCTION control_moist_func
+
+
+
+!! ================================================================================================================================
+!! FUNCTION     : control_temp_func
+!!
+!>\BRIEF        Calculate temperature control for litter and soild C decomposition
+!!
+!! DESCRIPTION  : Calculate temperature control factor applied
+!! to litter decomposition and to soil carbon decomposition in
+!! stomate_soilcarbon.f90 using the following equation: \n
+!! \latexonly
+!! \input{control_temp_func1.tex}
+!! \endlatexonly
+!! \n
+!! with T the temperature control factor, temp the temperature in Kelvin of 
+!! the air (for aboveground litter) or of the soil (for belowground litter 
+!! and soil)
+!! Then, the function is limited in its maximal range to 1:\n
+!! \latexonly
+!! \input{control_temp_func2.tex}
+!! \endlatexonly
+!! \n
+!! RECENT CHANGE(S) : None
+!!
+!! RETURN VALUE: ::tempfunc_result
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART : None
+!! \n
+!_ ================================================================================================================================
+
+  FUNCTION control_temp_func (npts, temp_in) RESULT (tempfunc_result)
+
+  !! 0. Variable and parameter declaration
+    
+    !! 0.1 Input variables
+    INTEGER(i_std), INTENT(in)                 :: npts            !! Domain size - number of land pixels (unitless)
+    REAL(r_std), DIMENSION(npts), INTENT(in)   :: temp_in         !! Temperature (K)
+
+    !! 0.2 Output variables
+    REAL(r_std), DIMENSION(npts)               :: tempfunc_result !! Temperature control factor (0-1, unitless)
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+!_ ================================================================================================================================
+
+    tempfunc_result(:) = exp( soil_Q10 * ( temp_in(:) - (ZeroCelsius+tsoil_ref)) / Q10 )
+    tempfunc_result(:) = MIN( un, tempfunc_result(:) )
+
+  END FUNCTION control_temp_func
+
+END MODULE stomate_litter
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_lpj.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_lpj.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_lpj.f90	(revision 7236)
@@ -0,0 +1,3408 @@
+! ================================================================================================================================
+! MODULE       : stomate_lpj
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Main entry point for daily processes in STOMATE and LPJ (phenology, 
+!! allocation, npp_calc, kill, turn, light, establish, crown, cover, lcchange)
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S) : None
+!!
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_stomate/stomate_lpj.f90 $
+!! $Date: 2015-02-22 16:18:16 +0100 (Sun, 22 Feb 2015) $
+!! $Revision: 2555 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE stomate_lpj
+
+  ! modules used:
+
+  USE function_library,   ONLY : check_biomass_sync, wood_to_qmdia, wood_to_qmheight, &
+                                 biomass_to_lai
+  USE ioipsl_para
+  USE xios_orchidee
+  USE grid
+  USE stomate_data
+  USE constantes
+  USE constantes_soil
+  USE pft_parameters
+  USE structures
+  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_kill
+  USE stomate_mark_kill
+  USE stomate_prescribe
+  USE stomate_phenology
+  USE stomate_growth_fun_all
+  USE stomate_growth_res_lim
+  USE stomate_stand_structure
+  USE stomate_turnover
+  USE stomate_litter
+  USE stomate_laieff, ONLY : find_lai_per_level, calculate_z_level_photo,&
+                             combine_lai_levels, fitting_laieff
+  USE stomate_soilcarbon
+  USE stomate_vmax
+  USE sapiens_lcchange
+  USE sapiens_forestry
+  USE sapiens_kill
+  USE sapiens_agriculture
+  USE sapiens_product_use
+  USE stomate_recruitment
+
+!  USE Orch_Write_field_p
+
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC StomateLpj,StomateLpj_clear
+
+  !+++CHECK+++
+  ! firstcall is not used in stomate_lpj -> redundant?
+  LOGICAL, SAVE                         :: firstcall = .TRUE.             !! first call
+ !$OMP THREADPRIVATE(firstcall)
+  !+++++++++++
+
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE   : StomateLpj_clear
+!!
+!>\BRIEF        Re-initialisation of variable
+!!
+!! DESCRIPTION  : This subroutine reinitializes variables. To be used if we want to relaunch 
+!! ORCHIDEE but the routine is not used in current version.
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): None
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE StomateLpj_clear
+
+    CALL prescribe_clear
+    CALL phenology_clear
+    CALL growth_res_lim_clear
+    CALL growth_fun_all_clear
+    CALL turnover_clear
+    CALL soilcarbon_clear
+    CALL constraints_clear
+    CALL establish_clear
+    CALL fire_clear
+    CALL gap_clear
+    CALL light_clear
+    CALL pftinout_clear
+
+  END SUBROUTINE StomateLpj_clear
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : StomateLPJ
+!!
+!>\BRIEF        Main entry point for daily processes in STOMATE and LPJ, structures the call sequence 
+!!              to the different processes such as dispersion, establishment, competition and mortality of PFT's.
+!! 
+!! DESCRIPTION  : This routine is the main entry point to all processes calculated on a 
+!! daily time step. Is mainly devoted to call the different STOMATE and LPJ routines 
+!! depending of the ok_dgvm (is dynamic veg used) and lpj_constant_mortality (is background mortality used).
+!! It also prepares the cumulative 
+!! fluxes or pools (e.g TOTAL_M TOTAL_BM_LITTER etc...)
+!!
+!! This routine makes frequent use of "weekly", "monthly" and "long term" variables. Caution is needed because
+!! by default "weekly" denotes 7 days, by default "monthly" denotes 20 days and by default "Long term" denotes
+!! 3 years. dtslow refers to 24 hours (1 day).
+!!
+!!
+!! RECENT CHANGE(S) : None
+!! 
+!! MAIN OUTPUT VARIABLE(S): All variables related to stomate and required for LPJ dynamic vegetation mode.
+!!
+!! REFERENCE(S) : 
+!! - Krinner, G., N. Viovy, N. de Noblet-DucoudrÃ©, J. OgeÃ©, J. Polcher, P. Friedlingstein, P. Ciais, S. Sitch, 
+!! and I. C. Prentice. 2005. A dynamic global vegetation model for studies of the coupled atmosphere-biosphere 
+!! system. Global Biogeochemical Cycles 19:GB1015, doi:1010.1029/2003GB002199.
+!! - Sitch, S., B. Smith, I. C. Prentice, A. Arneth, A. Bondeau, W. Cramer, J. O. Kaplan, S. Levis, W. Lucht, 
+!! M. T. Sykes, K. Thonicke, and S. Venevsky. 2003. Evaluation of ecosystem dynamics, plant geography and 
+!! terrestrial carbon cycling in the LPJ dynamic global vegetation model. Global Change Biology 9:161-185.
+!!
+!! FLOWCHART    : Update with existing flowchart from N Viovy (Jan 19, 2012)
+!! \n
+!_ ================================================================================================================================
+ 
+  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, &
+       moiavail_growingseason, tlong_ref, t2m_longterm, t2m_month, t2m_week, tsoil_month, &
+       soilhum_month, gdd_m5_dormance, gdd_from_growthinit, gdd_midwinter, ncd_dormance, &
+       ngd_minus5, turnover_longterm, gpp_daily, gpp_week, time_lowgpp, &
+       time_hum_min, maxfpc_lastyear, resp_maint_part, PFTpresent, age, &
+       fireindex, firelitter, leaf_age, leaf_frac, biomass, &
+       ind, adapted, regenerate, senescence,  senescence_days, &
+       when_growthinit, litterpart, litter, dead_leaves, carbon, &
+       black_carbon, lignin_struc, lignin_wood, veget_max, veget, npp_longterm, &
+       lm_lastyearmax, veget_lastlight, everywhere, need_adjacent, RIP_time, &
+       rprof, npp_daily, turnover_daily, turnover_time, control_moist, &
+       control_temp, soilcarbon_input, co2_to_bm, co2_fire, resp_hetero, &
+       resp_maint, resp_growth, deadleaf_cover, vcmax, &
+       bm_to_litter, prod_s, &
+       prod_m, prod_l, flux_s, flux_m, flux_l, &
+       veget_max_new, cflux_prod_s, cflux_prod_m, cflux_prod_l, carb_mass_total, & 
+       fpc_max, age_stand, rotation_n, last_cut, forest_managed, &
+       forest_managed_lastyear, MatrixA, rue_longterm, lab_fac, circ_class_n, &
+       circ_class_biomass, KF, circ_class_dist, harvest_pool_bound, harvest_pool, &
+       harvest_type, harvest_cut, harvest_area, mai, pai, &
+       previous_wood_volume, mai_count, bm_sync, coppice_dens, lai_per_level, &
+       laieff_fit, orphan_flux, vir_moiavail_growingseason, litter_demand, wstress_season, &
+       wstress_month, vir_wstress_fac, tau_eff_leaf, &
+       tau_eff_sap, tau_eff_root, MatrixV, VectorB, VectorU, &
+       c_buried, st_dist, k_latosa_adapt, species_change_map,lpft_replant,stem_plc,psi_stem,counter_psi,counter_2,counter_0,resp_hetero_litter,resp_hetero_soil, moiavail_daily, humrel_ddd, psi_leaf, psi_root)
+    
+  !! 0. Variable and parameter declaration
+
+    !! 0.1 input
+
+    INTEGER(i_std), INTENT(in)                       :: npts                    !! Domain size (unitless)
+    REAL(r_std), INTENT(in)                          :: dt_days                 !! Time step of Stomate (days)
+    INTEGER(i_std), DIMENSION(:,:), INTENT(in)       :: neighbours              !! 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]
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: resolution              !! Resolution at each grid point (m)  
+                                                                                !! [1=E-W, 2=N-S] 
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: clay                    !! Clay fraction (0 to 1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: herbivores              !! Time constant of probability of a leaf to 
+                                                                                !! be eaten by a herbivore (days) 
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: tsurf_daily             !! Daily surface temperatures (K)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: tsoil_daily             !! Daily soil temperatures (K)
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: t2m_daily               !! Daily 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: t2m_min_daily           !! Daily minimum 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: litterhum_daily         !! Daily litter humidity (0 to 1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: soilhum_daily           !! Daily soil humidity (0 to 1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: maxmoiavail_lastyear    !! Last year's maximum moisture availability 
+                                                                                !! (0 to 1, unitless) 
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: minmoiavail_lastyear    !! Last year's minimum moisture availability 
+                                                                                !! (0 to 1, unitless)
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: gdd0_lastyear           !! Last year's GDD0 (K)
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: precip_lastyear         !! Lastyear's precipitation 
+                                                                                !! @tex $(mm year^{-1})$ @endtex
+                                                                                !! to determine if establishment possible
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: tlong_ref               !! "Long term" 2 meter reference 
+                                                                                !! temperatures (K)
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: t2m_longterm            !! "longterm" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: t2m_month               !! "Monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: t2m_week                !! "Weekly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: tsoil_month             !! "Monthly" soil temperatures (K)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: soilhum_month           !! "Monthly" soil humidity
+                                                                                !! (0 to 1, unitless) 
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(in)      :: turnover_longterm       !! "Long term" turnover rate  
+                                                                                !! @tex $(gC m^{-2} year^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: time_lowgpp             !! Duration of dormance period with low gpp
+                                                                                !! (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: maxfpc_lastyear         !! Last year's maximum foliage projected
+                                                                                !! coverage for each natural PFT,
+                                                                                !! @tex $(m^2 m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)        :: resp_maint_part         !! Maintenance respiration of different 
+                                                                                !! plant parts  
+                                                                                !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: fpc_max                 !! "Maximal" coverage fraction of a PFT
+                                                                                !! (LAI -> infinity) on ground  
+                                                                                !! @tex $(m^2 m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: tau_eff_root            !! Effective root turnover time that accounts
+                                                                                !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: tau_eff_sap             !! Effective sapwood turnover time that accounts
+                                                                                !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: tau_eff_leaf            !! Effective leaf turnover time that accounts
+                                                                                !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: vir_wstress_fac         !! Virtual water stress factor, based on hum_rel_daily
+                                                                                !! (unitless, 0-1)
+    LOGICAL, INTENT(in)                              :: EndOfYear               !! Flag set on the last day of the year used 
+                                                                                !! to update "yearly variables". This 
+                                                                                !! variable must be .TRUE. once a year
+    LOGICAL, INTENT(in)                              :: EndOfMonth              !! Flag set at end of each month to update 
+                                                                                !! monthly variable 
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: circ_class_dist         !! The probability distribution of trees 
+                                                                                !! in a circ class in case of a 
+                                                                                !! redistribution (unitless).
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: st_dist                 !! The probability distribution of trees 
+                                                                                !! removed from a circ class in case of  
+                                                                                !! self thinning (unitless).
+    REAL(r_std), DIMENSION(0:), INTENT(in)           :: harvest_pool_bound      !! The boundaries of the diameter classes
+                                                                                !! in the wood harvest pools
+                                                                                !! @tex $(m)$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: vir_moiavail_growingseason !! Virtual mean growingseason moisture 
+                                                                                !! availability (0 to 1, unitless)
+    REAL(r_std),DIMENSION(:,:), INTENT(in)           :: veget                   !! Fraction of vegetation type including 
+                                                                                !! non-biological fraction (unitless) 
+  INTEGER(i_std), DIMENSION(:,:), INTENT(in)         :: species_change_map      !! A map which gives the PFT number that each
+                                                                                !! PFT will be replanted as in case of a clearcut.
+                                                                                !! (1-nvm,unitless)
+
+  !! 0.2 Output variables
+    
+    REAL(r_std), DIMENSION(:,:), INTENT(out)         :: npp_daily               !! Net primary productivity 
+                                                                                !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(out)         :: co2_to_bm               !! CO2 taken up from atmosphere when 
+                                                                                !! introducing a new PFT (introduced for 
+                                                                                !! carbon balance closure) 
+                                                                                !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(out)         :: co2_fire                !! Carbon emitted into the atmosphere by 
+                                                                                !! fire (living and dead biomass)  
+                                                                                !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(out)         :: resp_maint              !! Maintenance respiration  
+                                                                                !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(out)         :: resp_growth             !! Growth respiration  
+                                                                                !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    TYPE(laieff_type),DIMENSION (:,:,:),INTENT(out)  :: laieff_fit              !! Fitted parameters for the effective LAI
+    REAL(r_std), DIMENSION(:,:), INTENT(out)         :: vcmax                   !! Maximum rate of carboxylation 
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(out)     :: bm_to_litter            !! Conversion of biomass to litter
+                                                                                !! trees whose circumference is smaller than 
+                                                                                !! sigma don't grow much)
+    REAL(r_std), DIMENSION(:,:), INTENT(out)         :: lab_fac                 !! Activity of labile pool factor (??units??)
+    REAL(r_std), DIMENSION(:,:,:), INTENT(out)       :: lai_per_level           !! This is the LAI per vertical level
+                                                                                !! @tex $(m^{2} m^{-2})$
+
+
+    !! 0.3 Modified variables
+    
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: turnover_daily          !! Turnover rates 
+                                                                                !! @tex $(gC m^{-2} year^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:), INTENT(inout)         :: deadleaf_cover          !! Fraction of soil covered by dead leaves 
+                                                                                !! (0 to 1, unitless) 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: resp_hetero             !! Heterotrophic respiration
+                                                                                !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: resp_hetero_litter
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: resp_hetero_soil 
+
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: gpp_daily               !! Daily gross primary productivity  
+                                                                                !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: gpp_week                !! Mean weekly gross primary productivity 
+                                                                                !! @tex $(gC m^{-2} day^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: time_hum_min            !! Time elapsed since strongest moisture 
+                                                                                !! availability (days) 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: gdd_midwinter           !! Growing degree days (K), since midwinter 
+                                                                                !! (for phenology) - this is written to the
+                                                                                !!  history files
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: gdd_m5_dormance         !! Growing degree days (K), threshold -5 deg 
+                                                                                !! C (for phenology) 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: gdd_from_growthinit     !! growing degree days, since growthinit 
+                                                                                !! for crops
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: ncd_dormance            !! Number of chilling days (days), since 
+                                                                                !! leaves were lost (for phenology)    
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: control_moist           !! Moisture control of heterotrophic 
+                                                                                !! respiration (0 to 1, unitless) 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: control_temp            !! Temperature control of heterotrophic 
+                                                                                !! respiration, above and below 
+                                                                                !! (0 to 1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: rue_longterm            !! Longterm radiation use efficiency 
+                                                                                !! (??units??) 
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: soilcarbon_input        !! Quantity of carbon going into carbon 
+                                                                                !! pools from litter decomposition  
+                                                                                !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: rprof                   !! Prescribed root depth (m) 
+    LOGICAL, DIMENSION(:,:), INTENT(inout)           :: PFTpresent              !! Tab indicating which PFTs are present in 
+                                                                                !! each pixel 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: age                     !! Age (years)    
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: fireindex               !! Probability of fire (0 to 1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: firelitter              !! Longer term litter above the ground that 
+                                                                                !! can be burned, @tex $(gC m^{-2})$ @endtex
+
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: leaf_age                !! Leaf age (days)
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: leaf_frac               !! Fraction of leaves in leaf age class, 
+                                                                                !! (0 to 1, unitless)
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: biomass                 !! Stand level biomass @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: ind                     !! Density of individuals 
+                                                                                !! @tex $(m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: adapted                 !! Adaptation of PFT (killed if too cold) 
+                                                                                !! (0 to 1, unitless) 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: regenerate              !! "Fitness": Winter sufficiently cold for 
+                                                                                !! PFT regeneration ? (0 to 1, unitless) 
+    LOGICAL, DIMENSION(:,:), INTENT(inout)           :: senescence              !! Flag for setting senescence stage (only 
+                                                                                !! for deciduous trees)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: senescence_days         !! days since the beginning of senescence
+                                                                                !! (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: when_growthinit         !! How many days ago was the beginning of 
+                                                                                !! the growing season (days)
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: litterpart              !! Fraction of litter above the ground 
+                                                                                !! belonging to different PFTs
+                                                                                !! (0 to 1, unitless)
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: litter                  !! Metabolic and structural litter, above 
+                                                                                !! and below ground 
+                                                                                !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: dead_leaves             !! Dead leaves on ground, per PFT, metabolic 
+                                                                                !! and structural,  
+                                                                                !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: carbon                  !! Carbon pool: active, slow, or passive, 
+                                                                                !! @tex $(gC m^{-2})$ @endtex  
+    REAL(r_std), DIMENSION(:), INTENT(inout)         :: black_carbon            !! Black carbon on the ground 
+                                                                                !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: lignin_struc            !! Ratio of Lignin/Carbon in structural 
+                                                                                !! litter, above and below ground,  
+                                                                                !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: lignin_wood             !! Ratio of Lignin/Carbon in woody 
+                                                                                !! litter, above and below ground,  
+                                                                                !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: veget_max               !! "Maximal" coverage fraction of a PFT (LAI 
+                                                                                !! -> infinity) on ground. Includes
+                                                                                !! the nobio fraction, so may sum to
+                                                                                !! less than unity.
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: npp_longterm            !! "Long term" mean yearly primary 
+                                                                                !! productivity 
+                                                                                !! @tex $(gC m^{-2} year^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: lm_lastyearmax          !! Last year's maximum leaf mass, for each 
+                                                                                !! PFT @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: veget_lastlight         !! Vegetation fractions (on ground) after 
+                                                                                !! last light competition  
+                                                                                !! @tex $(m^2 m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: everywhere              !! Is the PFT everywhere in the grid box or 
+                                                                                !! very localized (after its introduction) 
+                                                                                !! (unitless) 
+    LOGICAL, DIMENSION(:,:), INTENT(inout)           :: need_adjacent           !! In order for this PFT to be introduced, 
+                                                                                !! does it have to be present in an 
+                                                                                !! adjacent grid box? 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: RIP_time                !! How much time ago was the PFT eliminated 
+                                                                                !! for the last time (y) 
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: turnover_time           !! Turnover_time of leaves for grasses 
+                                                                                !! (days)
+    REAL(r_std), DIMENSION(:,:),INTENT(inout)        :: veget_max_new           !! New "maximal" coverage fraction of a PFT 
+                                                                                !! (LAI -> infinity)  Includes
+                                                                                !! the nobio fraction, so may sum to
+                                                                                !! less than unity. (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: ngd_minus5              !! Number of growing days (days), threshold 
+                                                                                !! -5 deg C (for phenology)    
+    REAL(r_std), DIMENSION(:), INTENT(inout)         :: cflux_prod_s            !! C-released during first years (short term) 
+                                                                                !! following land cover change 
+                                                                                !! @tex ($gC year^{-1}$) @endtex 
+    REAL(r_std), DIMENSION(:), INTENT(inout)         :: cflux_prod_m            !! Total annual release from decomposition of 
+                                                                                !! the medium-lived product pool 
+                                                                                !! @tex ($gC year^{-1}$) @endtex
+    REAL(r_std), DIMENSION(:), INTENT(inout)         :: cflux_prod_l            !! Total annual release from decomposition of 
+                                                                                !! the long-lived product pool 
+                                                                                !! @tex ($gC year^{-1}$) @endtex
+    REAL(r_std), DIMENSION(:,0:), INTENT(inout)      :: prod_s                  !! Short-lived product pool after the annual 
+                                                                                !! release of each compartment (short + 1 : 
+                                                                                !! input from year of land cover change) 
+                                                                                !! @tex ($gC$) @endtex    
+    REAL(r_std), DIMENSION(:,0:), INTENT(inout)      :: prod_m                  !! Medium-lived product pool after the annual
+                                                                                !! release of each compartment (medium + 1 : 
+                                                                                !! input from year of land cover change) 
+                                                                                !! @tex ($gC$) @endtex 
+    REAL(r_std), DIMENSION(:,0:), INTENT(inout)      :: prod_l                  !! long-lived product pool after the annual 
+                                                                                !! release of each compartment (long + 1 : 
+                                                                                !! input from year of land cover change) 
+                                                                                !! @tex ($gC$) @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: flux_s                  !! Annual release from the short-lived product 
+                                                                                !! pool @tex ($gC) @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: flux_m                  !! Annual release from the medium-lived product  
+                                                                                !! pool compartments @tex ($gC) @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: flux_l                  !! Annual release from the long-lived product
+                                                                                !! pool @tex ($gC) @endtex 
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: circ_class_biomass      !! Biomass of the componets of the model  
+                                                                                !! tree within a circumference
+                                                                                !! class @tex $(gC ind^{-1})$ @endtex  
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: circ_class_n            !! Number of individuals in each circ class
+                                                                                !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:), INTENT(inout)         :: carb_mass_total         !! Carbon Mass total (soil, litter, veg) 
+                                                                                !! @tex $(gC m^{-2})$ @endtex  
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: MatrixA                 !! Matrix containing the fluxes  
+                                                                                !! between the carbon pools
+                                                                                !! per sechiba time step 
+                                                                                !! @tex $(gC.m^2.day^{-1})$ @endtex
+    INTEGER(i_std), DIMENSION(:,:), INTENT(inout)    :: age_stand               !! Age of stand (years)
+    INTEGER(i_std), DIMENSION(:,:), INTENT(inout)    :: rotation_n              !! Rotation number (number of rotation 
+                                                                                !! since pft is managed)
+    INTEGER(i_std), DIMENSION(:,:), INTENT(inout)    :: last_cut                !! Years since last thinning (years)
+    INTEGER(i_std), DIMENSION (:,:), INTENT(inout)   :: forest_managed          !! forest management flag (is the forest 
+                                                                                !! being managed?)
+    INTEGER(i_std), DIMENSION (:,:), INTENT(inout)   :: forest_managed_lastyear !! forest management flag for the 
+                                                                                !! previous year
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: KF                      !! Scaling factor to convert sapwood mass
+                                                                                !! into leaf mass (m)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: k_latosa_adapt          !! Leaf to sapwood area adapted for long 
+                                                                                !! term water stress (m)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: moiavail_month          !! "Monthly" moisture availability (0 to 1, 
+                                                                                !! unitless) 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: moiavail_week           !! "Weekly" moisture availability 
+                                                                                !! (0 to 1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: moiavail_growingseason  !! Mean growingseason moisture 
+                                                                                !! availability (0 to 1, unitless)
+    REAL(r_std),DIMENSION(:,:),INTENT(inout)         :: moiavail_daily
+
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: harvest_pool            !! The wood and biomass that have been
+                                                                                !! havested by humans @tex $(gC)$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: harvest_type            !! Type of management that resulted
+                                                                                !! in the harvest (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: harvest_cut             !! Type of cutting that was used for the harvest
+                                                                                !! (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: harvest_area            !! Harvested area (m^{2})
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: mai                     !! The mean annual increment
+                                                                                !! @tex $(m**3 / m**2 / year)$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: pai                     !! The period annual increment
+                                                                                !! @tex $(m**3 / m**2 / year)$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: previous_wood_volume    !! The volume of the tree trunks
+                                                                                !! in a stand for the previous year.
+                                                                                !! @tex $(m**3 / m**2 )$ @endtex
+    INTEGER(i_std), DIMENSION(:,:),INTENT(inout)     :: mai_count               !! The number of times we've
+                                                                                !! calculated the volume increment
+                                                                                !! for a stand
+    REAL(r_std), DIMENSION(:,:,:),INTENT(inout)      :: bm_sync                 !! The difference betweeen the
+                                                                                !! biomass in the circ_classes and
+                                                                                !! the total biomass 
+                                                                                !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:),INTENT(inout)        :: coppice_dens            !! The density of a coppice at the first
+                                                                                !! cutting @tex $( 1 / m**2 )$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: orphan_flux             !! Storage for fluxes of PFTs that no longer
+                                                                                !! exist. Following the total destruction of 
+                                                                                !! a PFT in LCC (veget_max_new = 0), a flux 
+                                                                                !! from before LCC needs a storage
+                                                                                !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: wstress_season          !! Water stress factor, based on hum_rel_daily
+                                                                                !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: wstress_month           !! Water stress factor, based on hum_rel_daily
+                                                                                !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,nvm,nbpools), &
+                                       INTENT(inout) :: VectorB                 !! Vector containing the litter increase per
+                                                                                !! sechiba time step
+                                                                                !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nbpools,nbpools), &
+                                       INTENT(inout) :: MatrixV                 !!
+    REAL(r_std), DIMENSION(npts,nvm,nbpools), &
+                                       INTENT(inout) :: VectorU                 !!
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: c_buried                !! Carbon buried during a land cover change to
+                                                                                !! a nobio land type (urban/ice).
+                                                                                !!  @tex (gC dt^{-1})$ @endtex
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)      :: lpft_replant            !! Set to true if a PFT has been clearcut
+                                                                                !! and needs to be replaced by another species
+
+    !! 0.4 Local variables
+
+    INTEGER                                          :: i,j,k,l,istep           !! Indices
+    INTEGER                                          :: idia,icut,ifm           !! Indices
+    INTEGER                                          :: ipar,iele,imbc,icir     !! Indices
+    INTEGER                                          :: ipts,ivm,ivm_young      !! Indices
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements):: bm_alloc                !! Biomass increase, i.e. NPP per plant part
+                                                                                !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm,nelements)       :: tot_bm_to_litter        !! Total conversion of biomass to litter 
+                                                                                !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm,nelements)       :: tot_live_biomass        !! Total living biomass  
+                                                                                !! @tex $(gC m{-2})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm,nelements)       :: tot_turnover            !! Total turnover rate  
+                                                                                !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm)                 :: tot_litter_soil_carb    !! Total soil and litter carbon  
+                                                                                !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm)                 :: tot_litter_carb         !! Total litter carbon 
+                                                                                !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm)                 :: tot_soil_carb           !! Total soil carbon  
+                                                                                !! @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(npts)                     :: carb_mass_variation     !! Carbon Mass variation  
+                                                                                !! @tex $(gC m^{-2} dtslow^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm)                 :: cn_ind                  !! Crown area of individuals 
+                                                                                !! @tex $(m^{2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nfm_types,ncut_times) &
+                                                     :: circ_class_kill         !! Number of trees within a circ class that needs
+                                                                                !! to be killed @tex $(ind m^{-2})$ @endtex
+                                                                                !! IMPORTANT: See the note in constantes.f90
+                                                                                !! regarding the indicies for this variable.
+    REAL(r_std), DIMENSION(npts,nvm)                 :: use_reserve             !! Mass taken from carbohydrate reserve 
+                                                                                !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                 :: woodmass_ind            !! Woodmass of individuals (gC) 
+    REAL(r_std), DIMENSION(npts,nvm,nparts)          :: f_alloc                 !! Fraction that goes into plant part 
+                                                                                !! (0 to 1, unitless) 
+    REAL(r_std), DIMENSION(npts)                     :: avail_tree              !! Space availability for trees 
+                                                                                !! (0 to 1, unitless) 
+    REAL(r_std), DIMENSION(npts)                     :: avail_grass             !! Space availability for grasses 
+                                                                                !! (0 to 1, unitless) 
+    REAL(r_std),DIMENSION(npts,nvm)                  :: veget_max_old           !! "Maximal" coverage fraction of a PFT  
+                                                                                !! (LAI-> infinity) on ground (unitless) 
+    REAL(r_std), DIMENSION(npts)                     :: vartmp                  !! Temporary 1-D variable used to add history
+    REAL(r_std), DIMENSION(npts,nvm)                 :: var_temp                !! Temporary 2-D variable used to add history
+    REAL(r_std), DIMENSION(npts,nvm)                 :: histvar                 !! History variables
+    REAL(r_std), DIMENSION(npts,nvm)                 :: gammas                  !! Slope for individual tree growth (m)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: sigma                   !! Threshold for indivudal tree growth (m) 
+    REAL(r_std), DIMENSION(npts,nvm)                 :: lrake_frac              !! TEMP
+    REAL(r_std), DIMENSION(npts,nvm)                 :: lai                     !! Leaf area index @tex $(m^2 m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm)                 :: qm_height               !! Quadratic mean height of vegetation (m)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: qm_dia                  !! Quadratic mean diameter of vegetation (m)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: rdi                     !! relative density index (ntrees/Nmax)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: rdi_target_upper        !! relative density index (ntrees/Nmax)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: rdi_target_lower        !! relative density index (ntrees/Nmax)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: woody_biomass_below     !! total woody biomass below ground 
+                                                                                !! (gC/(m**2)) 
+    REAL(r_std), DIMENSION(npts,nvm)                 :: woody_biomass_above     !! total woody biomass above ground
+                                                                                !! (gC/(m**2)) 
+    REAL(r_std), DIMENSION(npts,nvm)                 :: wood_loss_ab            !! Aboveground wood biomass loss to mortality 
+                                                                                !! and export (gC/(m**2)) 
+    REAL(r_std), DIMENSION(npts,nvm)                 :: wood_loss_be            !! Belowground wood biomass loss to mortality
+                                                                                !! and export (gC/(m**2)) 
+    REAL(r_std), DIMENSION(npts,nvm)                 :: var_real                !! Temporary variable for histwrite of 
+                                                                                !! integers
+    REAL(r_std), DIMENSION(npts,nvm)                 :: shoot_ratio             !! Root:shoot ratio
+    REAL(r_std), DIMENSION(npts)                     :: prod_s_total            !! Total products remaining in the short-lived  
+                                                                                !! pool after the annual decomposition 
+                                                                                !! @tex $(gC)$ @endtex 
+    REAL(r_std), DIMENSION(npts)                     :: prod_m_total            !! Total products remaining in the medium-lived
+                                                                                !! pool after the annual decomposition 
+                                                                                !! @tex $(gC)$ @endtex 
+    REAL(r_std), DIMENSION(npts)                     :: prod_l_total            !! Total products remaining in the long-lived
+                                                                                !! pool after the annual release 
+                                                                                !! @tex $(gC)$ @endtex 
+    REAL(r_std), DIMENSION(npts)                     :: cflux_prod_total        !! Total flux from decomposition of the short,
+                                                                                !! medium and long lived product pools 
+                                                                                !! @tex $(gC year^{-1})$ @endtex
+    CHARACTER(30)                                    :: var_name
+    CHARACTER(LEN=80)                                :: cut_name                !! To store variables names for I/O
+    CHARACTER(LEN=80)                                :: fm_name                 !! To store variables names for I/O
+    LOGICAL                                          :: lsync                   !! returns false if the biomass
+                                                                                !! is not synced... do we need this?  
+                                                                                !! We could equal just handle it in the 
+                                                                                !! check_biomass_sync
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements):: check_intern           !! Contains the components of the internal
+                                                                                !! mass balance chech for this routine
+                                                                                !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)       :: closure_intern          !! Check closure of internal mass balance
+                                                                                !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)       :: pool_start              !! Start and end pool of this routine 
+                                                                                !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)       :: pool_end                !! Start and end pool of this routine 
+                                                                                !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts)                     :: pixel_area              !! surface area of the pixel @tex ($m^{2}$)    
+    REAL(r_std), DIMENSION(npts,nvm,nlevels_tot)     :: z_level_photo           !! The height of the levels that we will
+                                                                                !! use to calculate the effective LAI for
+                                                                                !! the albedo routines and photosynthesis.
+                                                                                !! @tex $(m)$ @endtex   
+    REAL(r_std), DIMENSION(npts,nvm,nlevels)         :: lai_per_level_temp      !! This is the LAI per vertical level
+                                                                                !! @tex $(m^{2} m^{-2})$
+    REAL(r_std), DIMENSION(npts)                     :: laipix                  !! LAI at the pixel level for optimization
+    REAL(r_std), DIMENSION(npts)                     :: gpppix                  !! GPP at the pixel level for optimisation
+    LOGICAL, DIMENSION(npts,nvm)                     :: allow_initpheno         !! Are we allowed to declare the 
+                                                                                !! beginning of the growing season?
+                                                                                !!  and the end of senescence (true/false)
+    REAL(r_std), DIMENSION(npts)                     :: litter_demand           !! The amount of litter which will
+                                                                                !! be moved from forest to crop pools
+                                                                                !! at the end of the year.
+                                                                                !! @tex $( gC year^{-1} )$ @endtex
+    
+    REAL(r_std), DIMENSION(npts)                     :: mb_err_lcc              !! The mass balance error caused by LCC
+                                                                                !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                 :: veget_max_new_species   !! New "maximal" coverage fraction of a PFT 
+                                                                                !! (LAI -> infinity)  Includes
+                                                                                !! the nobio fraction, so may sum to
+                                                                                !! less than unity. (unitless)
+                                                                                !! This is used only for species change.
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)     :: stem_plc
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)     :: psi_stem 
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)     :: psi_leaf
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)     :: psi_root
+
+    REAL(r_std), DIMENSION(:,:),INTENT(in)      :: humrel_ddd
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)  :: counter_psi
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)  :: counter_2
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)  :: counter_0
+
+    REAL(r_std), DIMENSION(npts,nvm)  :: st_mortality
+    REAL(r_std), DIMENSION(npts,nvm)  :: d_mortality
+    REAL(r_std), DIMENSION(npts,nvm)  :: kill_st
+    REAL(r_std), DIMENSION(npts,nvm)  :: kill_d
+    REAL(r_std), DIMENSION(npts,nvm)  :: new_ind
+    REAL(r_std), DIMENSION(npts,nvm,ncirc)  :: circ_class_st
+    REAL(r_std), DIMENSION(npts,nvm,ncirc)   :: circ_class_mor
+    REAL(r_std), DIMENSION(npts,nvm,ncirc)   :: circ_class_litter
+   REAL(r_std), DIMENSION(npts,nvm,ncirc) :: circ_class_leaflitter
+   REAL(r_std), DIMENSION(npts,nvm,ncirc) :: circ_class_saplitter
+    REAL(r_std), DIMENSION(npts,nvm,ncirc) :: circ_class_heartlitter
+        ! 20210503yyt
+    REAL(r_std), DIMENSION(npts, nvm, ncirc)   :: circ_class_cwd
+    REAL(r_std), DIMENSION(npts, nvm, ncirc) :: circ_class_abg
+    REAL(r_std), DIMENSION(npts, nvm, ncirc) :: circ_class_gains
+    REAL(r_std), DIMENSION(npts, nvm, ncirc)   :: circ_class_leafcwd
+     REAL(r_std), DIMENSION(npts, nvm, ncirc)   :: circ_class_leafgains
+     REAL(r_std), DIMENSION(npts, nvm, ncirc)   :: circ_class_sapgains
+!_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering stomate_lpj',firstcall
+
+    !---TEMP---
+    CALL check_biomass_sync("stomate_lpj.f90: Start of LPJ", npts, biomass, &
+         circ_class_biomass, circ_class_n, ind, &
+         lsync, bm_sync) 
+
+
+    !! This is a whole new approach.  Basically, the functional allocation will
+    !! not work with the DGVM.  So instead of hvaing a lot of IF loops all over
+    !! this routine checking for that, we are just doing one IF loop.  If you
+    !! want the functional allocation, you cannot use the DGVM unless you're
+    !! willing to make some major changes.
+
+    IF(control%ok_functional_allocation)THEN
+
+ !! 1. Initializations
+
+       !! 1.1 Initialize variables to zero
+       co2_to_bm(:,:) = zero
+       co2_fire(:,:) = zero
+       npp_daily(:,:) = zero
+       resp_maint(:,:) = zero
+       resp_growth(:,:) = zero
+       bm_to_litter(:,:,:,:) = zero
+       cn_ind(:,:) = zero
+       woodmass_ind(:,:) = zero
+       use_reserve(:,:) = zero
+       turnover_daily(:,:,:,:) = zero
+       circ_class_kill(:,:,:,:,:) = zero
+       bm_alloc(:,:,:,:) = zero
+       rdi(:,:) = zero
+       rdi_target_upper(:,:) = zero
+       rdi_target_lower(:,:) = zero
+
+       !! 1.3  Initialize variables to veget_max
+       veget_max_old(:,:) = veget_max(:,:)
+
+       !! 1.4 Initialize check for mass balance closure
+       !  The mass balance is calculated at the end of this routine
+       !  in section 14. Initial biomass and harvest pool all other
+       !  relevant pools were just set to zero.
+       pool_start(:,:,:) = zero
+       DO ipar = 1,nparts
+          DO iele = 1,nelements
+             pool_start(:,:,iele) = pool_start(:,:,iele) + &
+                  (biomass(:,:,ipar,iele) * veget_max(:,:))
+          ENDDO
+       ENDDO
+  
+       !  Surface area (m2) of the pixel
+       pixel_area(:) = resolution(:,1) * resolution(:,2)
+
+       ! The biomass harvest pool shouldn't be multiplied by veget_max
+       ! its units are already in gC pixel-1. The total amount for the 
+       ! pixel was stored in harvest_pool. Account for the harvest and
+       ! wood product pools. There are no longer PFTs 
+       pool_start(:,1,icarbon) = pool_start(:,1,icarbon) + &
+            ( SUM(SUM(harvest_pool(:,:,:,icarbon),3),2) + &
+            SUM(prod_l(:,:),2) + SUM(prod_m(:,:),2) + &
+            SUM(prod_s(:,:),2) ) / pixel_area(:)
+
+       !! 1.3 Correct management status if waiting for clearcut (management only
+       !! changes after a clearcut, except if it's to become unmanaged)
+       !  When this code is used the model does not follow the fm_maps exactly
+       !  Over a 400 year long simulation th effect was rather large (missing 20%
+       !  of FM2). Part of this mismatch may have been because their was a bug in 
+       !  sapiens_lcchange. When a new age class had to created, FM was set to 1
+       !  rather than the FM of the oldest age class. It is not clear whether this
+       !  code or the bug in sapiens_lcchange was the most important cause of the
+       !  mismatch but there are only very few cases where the land manager has to 
+       !  wait for a clear cut or disturbance before the management can be changed
+       !  the only case I could think of was when having FM1 or FM2 and going to 
+       !  FM3. The general trend goes in the other direction.
+!!$       DO j = 2,nvm
+!!$
+!!$          DO i = 1,npts
+!!$
+!!$             IF ( (forest_managed(i,j) /= forest_managed_lastyear(i,j)) .AND. &
+!!$                  (forest_managed_lastyear(i,j) > 0) .AND. &
+!!$                  & (forest_managed(i,j) > 0) .AND.(age_stand(i,j) > 1) ) THEN
+!!$                forest_managed(i,j) = forest_managed_lastyear(i,j)
+!!$
+!!$             ENDIF
+!!$
+!!$          ENDDO
+!!$
+!!$       ENDDO
+
+       IF (EndOfYear) THEN
+          forest_managed_lastyear(:,:) = forest_managed(:,:)
+       ENDIF
+
+       !! 1.4 Update stand age
+       ! Here we increment the age of the stand, if it's the end of the year.
+       ! Notice that we need to do this before the forestry routines, since the 
+       ! forest has had a chance to grow since the last time
+       ! we called the routine.  Doing it this way may cause a small problem since
+       ! forestry is only done every year.  For example, let us say that a forest
+       ! die-off occurs due to natural reasons at the end of December.  The age of
+       ! that stand will be set to zero.  However, when the end of year happens
+       ! the age will be incremented by one here, even though the forest is only a 
+       ! a couple weeks old.  There doesn't seem to be a better
+       ! way to do this, though, so a forest age of x should be taken to mean that
+       ! the forest is between x-1 and x years old.  I see this only being an issue
+       ! in short rotation coppices, but those forests should never have
+       ! die off because they are harvested every couple years.
+       IF (EndOfYear) THEN
+          DO ipts=1,npts
+             DO ivm=1,nvm
+                IF(veget_max(ipts,ivm) .GT. min_stomate)THEN
+                   age_stand(ipts,ivm) = age_stand(ipts,ivm) + 1
+
+                   ! last_cut is similar to stand age, but it measures the time since
+                   ! any human intervention, either thinning or clearcutting.
+                   last_cut(ipts,ivm) = last_cut(ipts,ivm) + 1
+
+                ELSE
+                   age_stand(ipts,ivm) = 0
+                   last_cut(ipts,ivm) = 0
+                ENDIF
+             ENDDO
+          ENDDO
+       ENDIF
+       
+
+WRITE(numout,*) "GPP_daily, GPP_week", gpp_daily(1,2), gpp_week(1,2)
+ !! 2. Prescribe vegetation characteristics
+
+       !  At the first call this routine takes atmospheric CO2 and converts it
+       !  into carbon pools to basically avoid modelling seed germination.
+       ! At the first call atmospheric CO2 is converted into biomass pools but
+       ! the closed canopy assumption is relaxed by the parameter ::canopy_cover(j).
+       ! Given that the functional allocation scheme is constrainted by
+       ! allometric relationships, diameter (::dia), and stand density (::ind)
+       ! are prognostic variables in this scheme. The relationship between
+       ! diameter and stand density is controled by the self-thinning rule.
+       ! Height is a diagnostic variable and can be derived from diameter through
+       ! allometric relationships
+       CALL prescribe_prognostic (npts, veget_max, veget, dt_days, PFTpresent, &
+            everywhere, when_growthinit, biomass, leaf_frac, & 
+            ind, circ_class_n, circ_class_biomass, co2_to_bm, &
+            forest_managed, KF, &            
+            senescence, age, npp_longterm, lm_lastyearmax, &
+            tau_eff_leaf, tau_eff_sap, tau_eff_root, k_latosa_adapt, &
+            lpft_replant=lpft_replant)
+       !---TEMP---
+       CALL check_biomass_sync("stomate_lpj.f90: After prescribe", npts, biomass, &
+            circ_class_biomass, circ_class_n, ind, &
+            lsync, bm_sync)
+!!$       ! 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. Phenology
+
+       ! Forests and grasses or the so called natural vegetation in ORCHIDEE
+       ! undergo a real phenology based on climatology. This means that the
+       ! plants are planted the first day of the year and that they live from
+       ! their reserves until the day of bud burst. Crops are planted 
+       ! (and harvested) every year. We plant them the day of bud burst. The 
+       ! biggest difference is that crops do not need reserves to live
+       ! between January 1st and the day of bud burst.
+       CALL phenology_prognostic (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_hum_min, biomass, leaf_frac, &
+            leaf_age, when_growthinit, co2_to_bm, circ_class_n, &
+            circ_class_biomass, ind, KF, allow_initpheno, &
+            tau_eff_leaf, tau_eff_sap, tau_eff_root, age, &
+            everywhere, npp_longterm, lm_lastyearmax, k_latosa_adapt)
+
+       !---TEMP---
+       CALL check_biomass_sync("stomate_lpj.f90: After phenology", npts, biomass, &
+            circ_class_biomass, circ_class_n, ind, &
+            lsync, bm_sync)
+
+
+ !! 4. Respiration, npp, allocation and age class distribution
+
+      !! 4.1 Allometry based allocation (based on Sitch et al 2003, 
+      !  Zaehle et al 2010 and Deleuze 2004)
+       CALL growth_fun_all (npts, dt_days, veget_max, veget, PFTpresent, &
+            senescence, when_growthinit, t2m_week, &
+            gpp_daily, gpp_week, resp_maint_part, resp_maint, &
+            resp_growth, npp_daily, biomass, age, &
+            leaf_age, leaf_frac, use_reserve, &
+!!$            leaf_age, leaf_frac, use_reserve, t_photo_stress, &
+            lab_fac, ind, rue_longterm, circ_class_n, &
+            circ_class_biomass, KF, bm_sync, sigma, &
+            gammas, tau_eff_leaf, tau_eff_sap, tau_eff_root, &
+            k_latosa_adapt, forest_managed,moiavail_week,humrel_ddd, psi_leaf, psi_root,stem_plc, circ_class_gains, circ_class_leafgains, circ_class_sapgains)
+
+       !---TEMP---
+       CALL check_biomass_sync("stomate_lpj.f90: After growth", npts, biomass, &
+            circ_class_biomass, circ_class_n, ind, &
+            lsync, bm_sync)
+        DO icir=1,ncirc
+           WRITE (var_name,"('circ_class_gains_',i3.3)") icir 
+           CALL histwrite_p(hist_id_stomate, var_name,itime,circ_class_gains(:,:,icir),npts*nvm, horipft_index)
+        
+           WRITE (var_name,"('CC_leafgains_',i3.3)") icir
+           CALL histwrite_p(hist_id_stomate,var_name,itime,circ_class_leafgains(:,:,icir),npts*nvm, horipft_index)
+                
+          WRITE (var_name,"('CC_sapgains_',i3.3)") icir
+           CALL histwrite_p(hist_id_stomate, var_name,itime,circ_class_sapgains(:,:,icir),npts*nvm, horipft_index)
+        ENDDO
+
+
+
+        !! 4.2 Calculate mass balance
+       !  All C-fluxes except co2_to_bm are calculated before the code deals with
+       !  LCC. So in general it doesn't matter whether we use the fluxes from before
+       !  or the fluxes from after LCC as the should be exactely the same except for
+       !  the fact that they could have been moved from one PFT to another. There
+       !  are two important exceptions to this general rule and these exceptions are
+       !  the cause of the need of the variable ::orphan_flux: (1) PFTs that entirely
+       !  disappear and PFT's that are newly established (and will therefore take up
+       !  co2 from the atmosphere. The first exception results in orphan fluxes which
+       !  should be accounted for. The second results in the risk of double counting.
+       !  When land cover change occurs, PFTs may be entirely removed. When a PFT
+       !  is changed into another PFT, the fluxes i.e. GPP are averaged. However,
+       !  when a PFT is removed and becomes PFT1 these fluxes will be lost. We 
+       !  could store just these fluxes and apply a correction when needed or we 
+       !  can simply store all fluxes for the old veget_max values and use where
+       !  needed i.e. in the mass balance (note that additional bookkeeping tricks are
+       !  required for co2_to_bm). Also, these fluxes should be shown in 
+       !  the histwrite files but not in the restart files.
+       orphan_flux(:,:,ivegold,icarbon) = veget_max(:,:)
+       ! For ivegnew, this is just a placeholder.  It should be updated
+       ! in lcchange.  If it is not set here, though, it's uninitialised,
+       ! which causes a problem with some compilers.
+       orphan_flux(:,:,ivegnew,icarbon) = veget_max(:,:)
+       orphan_flux(:,:,igpp,icarbon) = gpp_daily(:,:)
+       orphan_flux(:,:,ico2bm,icarbon) = co2_to_bm(:,:)
+       orphan_flux(:,:,irmain,icarbon) = resp_maint(:,:)
+       orphan_flux(:,:,irgrow,icarbon) = resp_growth(:,:)
+       orphan_flux(:,:,inpp,icarbon) = npp_daily(:,:)
+       orphan_flux(:,:,irhet,icarbon) = resp_hetero(:,:)
+
+ !! 5. Land cover change and land management
+
+       ! We only want to do management at the end of the year. Whether LCC takes place 
+       ! before land management appears to be a matter of taste but given that LCC 
+       ! results in the (partial) destruction of the PFT it appears somehow logic to 
+       ! deal with LCC before FM. After all, it seems unlikely that a land owner will 
+       ! first carefully thin a forest and then cut it to turn it into a grassland or 
+       ! cropland. 
+       !TEMP++++++++++++++++
+       lrake_frac(:,:)=zero
+       !+++++++++++++++
+
+
+       IF ( EndOfYear) THEN
+
+          !! 5.1 Age class distribution
+          !  Following allocation, the trees have grown and it needs to be
+          !  checked whether they are still in the correct age class. If not,
+          !  redistribute the age classes in line with a prescribe diameter
+          !  threshold for each age class
+          CALL age_class_distr(npts, circ_class_n, biomass, circ_class_biomass, &
+               veget_max, ind, circ_class_dist, wstress_season, &
+               lm_lastyearmax, age, leaf_frac, co2_to_bm, &
+               everywhere, litter, carbon, lignin_struc, &
+               lignin_wood, bm_to_litter,PFTpresent, when_growthinit,&
+               forest_managed, KF, senescence, &
+               npp_longterm, gpp_daily, leaf_age, lab_fac, &
+               gdd_from_growthinit, gdd_midwinter, time_hum_min, gdd_m5_dormance, &
+               ncd_dormance, moiavail_month, moiavail_week, ngd_minus5, &
+               gpp_week, resp_maint, resp_growth, npp_daily, &
+               use_reserve, rue_longterm, mai, pai, &
+!!$               use_reserve, t_photo_stress, rue_longterm, mai, pai, &
+               mai_count, previous_wood_volume, moiavail_growingseason,&
+               MatrixA, MatrixV, VectorB, VectorU, age_stand, last_cut, &
+               k_latosa_adapt)
+
+          !---TEMP---
+          CALL check_biomass_sync("stomate_lpj.f90: After redistributing age classes", &
+               npts, biomass, circ_class_biomass, circ_class_n, ind, &
+               lsync, bm_sync) 
+
+
+  
+        !! 5.2 Land cover change
+          IF (control%ok_land_cover_change) THEN
+
+             !+++CHECK+++
+             ! NOTE: when this code was written, ::veget_cov_max_new was passed into 
+             ! stomate_lpj. This has now changed and only ::veget_max is passed so 
+             ! the checks on the vegetation cover in the code need to be checked.
+             CALL land_cover_change_main (npts, dt_days, veget_max, veget, harvest_pool, &
+                  harvest_type, harvest_cut, harvest_area, &
+                  litter, carbon, lignin_struc, lignin_wood, &
+                  biomass, PFTpresent, everywhere, when_growthinit, & 
+                  leaf_frac, ind, circ_class_n, circ_class_biomass, &
+                  co2_to_bm, forest_managed, &
+                  KF, wstress_season, wstress_month, senescence, npp_longterm, &
+                  age, lm_lastyearmax, harvest_pool_bound, resolution, &
+                  bm_to_litter, leaf_age, circ_class_dist, orphan_flux, &
+                  bm_sync, vir_wstress_fac, tau_eff_leaf, tau_eff_sap, &
+                  tau_eff_root, veget_max_new, age_stand, last_cut, &
+                  c_buried, mb_err_lcc, k_latosa_adapt)
+             !++++++++++
+
+             ! TEMP
+             CALL histwrite_p (hist_id_stomate, 'MB_ERR_LCC', itime, &
+                  mb_err_lcc(:), npts, hori_index)
+
+
+
+             !---TEMP---
+             CALL check_biomass_sync("stomate_lpj.f90: After land cover change", &
+                  npts, biomass, circ_class_biomass, circ_class_n, ind, &
+                  lsync, bm_sync) 
+
+
+          ENDIF
+
+          !! 5.3 Forest management
+          CALL forestry (npts, biomass, age_stand, last_cut, &
+               circ_class_n, circ_class_kill, forest_managed, rdi,&
+               circ_class_biomass, mai, pai, previous_wood_volume, &
+               mai_count, coppice_dens, veget_max, rdi_target_upper,&
+               rdi_target_lower, lpft_replant)
+
+          !---TEMP---
+          CALL check_biomass_sync("stomate_lpj.f90: After forest management", &
+               npts, biomass, circ_class_biomass, circ_class_n, ind, &
+               lsync, bm_sync)
+
+
+          !! 5.3 Crop harvest
+          !  According to the logic of this module crop harvest should 
+          !  take place here but it depends on :: turnover_daily and that
+          !  variable is not calculated until the call to turnover. Also
+          !  the implemented approach harvests biomass daily rather once
+          !  per year (as it should be).
+
+          !! 5.4 Grazing
+          !  This is an excellent place to account for grazing.
+
+          !! 5.5 Litter raking
+          !  In order to feed animals through the winter, as well as absorb
+          !  their manure to spread on the fields during the spring, farmers
+          !  in historical Europe would collect litter from forests and place
+          !  it in the stables during winter.  We will simulate this by
+          !  looking at the litter pools at the end of every year and moving
+          !  around a certain amount of litter from the forest to the crop PFTs.
+          !  We do this after the forest management under the assumption that
+          !  branches left on site after thinning operations would, historically,
+          !  have been collected for this purpose.  Of course, litter raking fell
+          !  out of fashion in the mid-19th century, around the same time that
+          !  scientific silvaculture became popular, so perhaps it doesn't matter.
+          !  If you are not doing historical runs, litter raking almost certainly
+          !  does not apply to you.
+          IF(use_litter_raking)THEN
+             CALL litter_raking(npts, veget_max, resolution, litter_demand, litter, lrake_frac)
+          ENDIF
+
+       ENDIF ! EndOfYear
+
+
+ !! 6. Kill PFT's
+
+       ! Kill slow growing PFTs in DGVM or STOMATE with dynamic or
+       ! constant mortality. If the leaf, root or reserve pool are zero 
+       ! kill the PFT, move the biomass to the litter pool and reinitialize 
+       ! some PFT variables
+ 
+       CALL kill_prognostic (npts, 'growth    ', lm_lastyearmax,  ind, &
+            PFTpresent, biomass, npp_longterm, circ_class_biomass, &
+            circ_class_n, circ_class_kill, rue_longterm, turnover_longterm, &
+            dt_days, veget_max, st_dist, forest_managed,lpft_replant,stem_plc, psi_stem,counter_psi,counter_2,counter_0,st_mortality,d_mortality,kill_st,kill_d, circ_class_st, circ_class_mor, circ_class_litter, circ_class_leaflitter, circ_class_saplitter, circ_class_heartlitter)
+       ! added by Yitong Yao 06 Jan 2020 16:07 add stem_plc in subroutine 
+       ! added by yitong yao 07 Jan 2020 10:50 add psi_stem in subroutine 
+      
+        DO icir=1,ncirc
+           WRITE (var_name,"('counter_psi_',i3.3)") icir
+           CALL histwrite_p(hist_id_stomate, var_name, itime,counter_psi(:,:,icir),npts*nvm, horipft_index)
+           
+           WRITE (var_name,"('counter_2_',i3.3)") icir
+           CALL histwrite_p(hist_id_stomate, var_name, itime,counter_2(:,:,icir),npts*nvm, horipft_index)
+           WRITE (var_name,"('counter_0_',i3.3)") icir
+           CALL histwrite_p(hist_id_stomate, var_name, itime,counter_0(:,:,icir),npts*nvm, horipft_index)
+   
+          WRITE (var_name,"('circ_class_thin_',i3.3)") icir
+           CALL histwrite_p(hist_id_stomate, var_name, itime,circ_class_st(:,:,icir),npts*nvm, horipft_index)
+
+           WRITE (var_name,"('circ_class_st_',i3.3)") icir
+           CALL histwrite_p(hist_id_stomate, var_name, itime,circ_class_litter(:,:,icir),npts*nvm, horipft_index)
+          
+         WRITE(var_name,"('CC_leaflitter_',i3.3)") icir
+         CALL histwrite_p(hist_id_stomate, var_name,itime,circ_class_leaflitter(:,:,icir),npts*nvm, horipft_index)
+        
+        WRITE(var_name,"('CC_saplitter_',i3.3)") icir
+         CALL histwrite_p(hist_id_stomate, var_name,itime,circ_class_saplitter(:,:,icir),npts*nvm, horipft_index)
+
+        WRITE(var_name,"('CC_heartlitter_',i3.3)") icir
+         CALL histwrite_p(hist_id_stomate, var_name,itime,circ_class_heartlitter(:,:,icir),npts*nvm, horipft_index)
+ 
+            WRITE (var_name,"('circ_class_mor_',i3.3)") icir
+           CALL histwrite_p(hist_id_stomate, var_name,itime,circ_class_mor(:,:,icir),npts*nvm, horipft_index)
+            !write(*,*) 'stemplc_lpj',icir, stem_plc(1,2,icir)
+          
+           ! WRITE (var_name,"('circ_class_litter_',i3.3)") icir
+           ! CALL histwrite_p(hist_id_stomate, var_name, itime,circ_class_litter(:,:,icir),npts*nvm, horipft_index)
+
+
+          ENDDO
+
+        CALL histwrite_p (hist_id_stomate, 'ST_MORTALITY', itime, &
+            st_mortality, npts*nvm, horipft_index)
+
+        CALL histwrite_p (hist_id_stomate, 'D_MORTALITY', itime, &
+            d_mortality, npts*nvm, horipft_index)
+        
+        CALL histwrite_p (hist_id_stomate, 'KILL_ST', itime, &
+            kill_st, npts*nvm, horipft_index)
+
+        CALL histwrite_p (hist_id_stomate, 'KILL_D', itime, &
+              kill_d, npts*nvm, horipft_index)
+ 
+        
+
+       !---TEMP---
+       CALL check_biomass_sync("stomate_lpj.f90: After kill", npts, biomass, &
+            circ_class_biomass, circ_class_n, ind, &
+            lsync, bm_sync)
+
+
+ !! 7. Fire
+ 
+      IF (.NOT. control%ok_constant_mortality) THEN
+
+          ! +++CHECK+++
+          ! The current call to fire does not synchronize ind and circ_class_n
+          ! and biomass and circ_class_biomass yet. This should be done first.
+          ! +++++++++++
+
+       ELSE
+
+          ! The PFTs do not burn when constant mortality is used 
+          ! outside the DGVM. Write the values of the flags to make 
+          ! sure this condition is satisfied
+          IF (firstcall) THEN
+
+!!$             WRITE(numout,*) 'PFTs are not killed and the vegatation updated because '
+!!$             WRITE(numout,*) 'constant mortality is used outside the DGVM'
+!!$             WRITE(numout,*) 'control%ok_functional_allocation, ', control%ok_functional_allocation
+!!$             WRITE(numout,*) 'control%ok_dgvm, ', control%ok_dgvm
+!!$             WRITE(numout,*) 'control%ok_constant_mortality, ', control%ok_constant_mortality
+!!$             WRITE(numout,*) 'disable_fire, ', disable_fire
+
+          ENDIF
+
+       ENDIF  ! constant mortality
+
+
+ !! 8. Tree mortality
+
+       ! Here is where the trees actually die and biomass is moved around.  
+       ! First, we kill all the trees that died because of human intervention.
+       CALL gap_prog_sapiens (npts, biomass, ind, &
+            bm_to_litter, circ_class_biomass, circ_class_kill, &
+            circ_class_n, harvest_pool_bound, harvest_pool, harvest_type, &
+            harvest_cut, harvest_area, resolution, &
+            veget_max, age_stand, last_cut, mai_count, circ_class_dist, &
+            coppice_dens)
+       !---TEMP---
+       CALL check_biomass_sync("stomate_lpj.f90: After gap_prog_sapiens", npts, biomass, &
+            circ_class_biomass, circ_class_n, ind, &
+            lsync, bm_sync)
+
+
+
+       ! Now we kill all the plants which died due to natural causes.  This comes
+       ! after the plant death due to human causes, since in theory a forest
+       ! that is thinned will not suffer from as high of natural mortality.
+       circ_class_cwd(:,:,:)=zero
+       circ_class_leafcwd(:,:,:)=zero
+        CALL gap_prognostic (npts, biomass, ind, bm_to_litter, &
+            circ_class_biomass, circ_class_kill, circ_class_n, &
+            veget_max, circ_class_cwd, circ_class_leafcwd)
+        
+
+
+       !---TEMP---
+       CALL check_biomass_sync("stomate_lpj.f90: After gap_prognostic", npts, biomass, &
+            circ_class_biomass, circ_class_n, ind, &
+            lsync, bm_sync)
+    !   write(*,*) 'CCNsum_after_gap_prog',sum(circ_class_n(1,2,:))
+    !   write(*,*) 'ind_after_gap_prog',ind(1,2) 
+    !   write(*,*) 'BIOMASS_after_gap_prog',sum(sum(biomass(1,2,1:8,:),dim=2),dim=1)
+    !   write(*,*) 'sync_after_gap_prog',sum(bm_sync(1,2,:))
+
+
+     ! Write it to the netcdf
+    DO icir=1,ncirc
+       WRITE (var_name,"('CCK_',i3.3)") icir
+       CALL histwrite_p(hist_id_stomate, var_name, itime, sum(sum(circ_class_kill(:,:,icir,:,:),dim=4),dim=3),npts*nvm, horipft_index)
+   ENDDO
+
+    
+    !DO icir=1,ncirc
+    !    write(*,*) 'circ_class_kill ',icir,' ',sum(sum(circ_class_kill(1,2,icir,:,:),dim=2),dim=1)
+    !ENDDO
+       ! Now we need to do some checking.  If there is no biomass on the site,
+       ! some variables have to be reset.  If some of the circumference classes
+       ! are empty, we need to redistribute the biomass among them.  Notice this
+       ! must be done after both the natural and human killing is done, because
+       ! circ_class_kill for the natural killing is calculated based on 
+       ! circ_class_biomass, and if we redistribute we change circ_class_biomass.
+       CALL gap_clean (npts, biomass, circ_class_biomass, &
+            circ_class_n, age, everywhere, leaf_age,&
+            leaf_frac, senescence, when_growthinit, circ_class_dist,&
+            age_stand, PFTpresent, last_cut, mai_count, &
+            veget_max, npp_longterm, KF, co2_to_bm, ind, &
+            wstress_season, lm_lastyearmax, lignin_struc, lignin_wood, &
+            carbon, litter,  vir_wstress_fac, veget, dt_days, &
+            forest_managed, bm_to_litter, lab_fac, gdd_from_growthinit,&
+            gdd_midwinter, time_hum_min, gdd_m5_dormance, ncd_dormance,&
+            moiavail_month, moiavail_week, gpp_week, gpp_daily, resp_maint,&
+            resp_growth, npp_daily, use_reserve, mai, pai, ngd_minus5,&
+            rue_longterm, previous_wood_volume,&
+!!$            t_photo_stress, rue_longterm, previous_wood_volume,&
+            tau_eff_leaf, tau_eff_sap, tau_eff_root, moiavail_growingseason,&
+            orphan_flux, k_latosa_adapt)
+
+       !---TEMP---
+       CALL check_biomass_sync("stomate_lpj.f90: After gap_clean", npts, biomass, &
+            circ_class_biomass, circ_class_n, ind, &
+            lsync, bm_sync)
+       !write(*,*) 'CCNsum_after_gap_clean',sum(circ_class_n(1,2,:))
+      ! write(*,*) 'ind_after_gap_clean',ind(1,2)
+      ! write(*,*) 'BIOMASS_after_gap_clean',sum(sum(biomass(1,2,1:8,:),dim=2),dim=1)
+      ! write(*,*) 'sync_after_gap_clean',sum(bm_sync(1,2,:))
+
+
+
+ !! 9. Calculate vcmax, vjmax and photosynthesis temperatures
+
+       CALL vmax_prognostic (npts, dt_days, leaf_age, leaf_frac, &
+            age_stand, vcmax, tau_eff_leaf)
+
+!!$       CALL assim_temp (npts, tlong_ref, t2m_month, t_photo_min, &
+!!$            t_photo_opt, t_photo_max)
+
+
+ !! 10. Leaf senescence, turnover and crop harvest
+
+       ! For trees and grasses there is a real turnover and senescence can
+       ! last days to weeks. For crops the end of the growing season is 
+       ! followed by a harvest and part of the crop biomass is added to the
+       ! harvest pool.
+       CALL turnover_prognostic (npts, dt_days, PFTpresent, herbivores, &
+            maxmoiavail_lastyear, minmoiavail_lastyear, moiavail_week,  moiavail_month, &
+            tlong_ref, t2m_longterm, t2m_month, t2m_week, veget_max, &
+            gdd_from_growthinit, leaf_age, leaf_frac, age, &
+            biomass, turnover_daily, senescence, turnover_time, &
+            circ_class_biomass, circ_class_n, ind, allow_initpheno, &
+            when_growthinit,tau_eff_leaf, tau_eff_sap, tau_eff_root, &
+            harvest_pool, harvest_type, harvest_cut, harvest_area, &
+            resolution, wstress_month)
+      
+
+       !---TEMP---
+       CALL check_biomass_sync("stomate_lpj.f90: After turnover", npts, biomass, &
+            circ_class_biomass, circ_class_n, ind, &
+            lsync, bm_sync)
+       !write(*,*) 'CCNsum_after_turnover',sum(circ_class_n(1,2,:))
+       !write(*,*) 'ind_after_turnover',ind(1,2) 
+       !write(*,*) 'BIOMASS_after_turnover',sum(sum(biomass(1,2,1:8,:),dim=2),dim=1)
+       !write(*,*) 'sync_after_turnover',sum(bm_sync(1,2,:))
+
+
+
+ !! 11. Product use
+ 
+       !  +++CHECK+++
+       !  Write the harvest pools to the history files here because they will
+       !  be reset when the subroutine basic_product_use is called. Note that
+       !  due to some peculiarities in the coding the units of the harvest 
+       !  pool differ for grasses, crops and forests. For forest, the 
+       !  harvest_pool is filled and emptied the last day of the year. Hence
+       !  all daily values are 0, except for the last day. When writing,
+       !  for example, monthly output files the mean monthly value will be 
+       !  written. To obtain the absolute harvest, the value in the history
+       !  file should be multiplied by 30 or 31 depending on whether a 360 or 
+       !  365 day calendre is used. For grasslands the harvest_pool is filled
+       !  daily with the turnover. So the mean value written to the history file
+       !  is the correct value. Crops are typically harvested before December
+       !  31st but the harvest_pool is only emptied on December 31st (just as
+       !  for grasses and forests). So between the harvest date and December
+       !  31st the same biomass remains in the harvest pools. If the harvest 
+       !  takes place before December 1st the same average value is written for
+       !  every day of December and therefore the last month contains the correct
+       !  value for harvest.
+       !  All of this would become straightforward if we would only write harvest_pool
+       !  the last day of the year. We tried using the operator once in histwrite but
+       !  were unhappy with the outcome. The IPSL team no longer maintains histwrite
+       !  as it should get replaced by the ioxserver.
+       var_temp = SUM(harvest_pool(:,:,:,icarbon),3)
+       CALL histwrite_p (hist_id_stomate, 'HARVEST_POOL_C', itime, &
+            var_temp, npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'HARVEST_TYPE', itime, &
+            harvest_type(:,:), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'HARVEST_CUT', itime, &
+            harvest_cut(:,:), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'HARVEST_AREA', itime, &
+            harvest_area(:,:), npts*nvm, horipft_index)
+       !+++++++++++
+
+       !  Agricultural harvest now goes into the short-lived product pool.
+       !  Hence, product use can only be estimated after crop_harvest which
+       !  in turn depends on the calculation of turnover. In previous version
+       !  product use was an integral part of LCC. Maintaining this approach 
+       !  would result in inconsistencies with harvest from forestry and 
+       !  agriculture. Note that there is still no real harvest from grasslands. 
+       !  Grasslands are thus wrongly considered natural PFTs without any human 
+       !  use. To partly overcome this issue the turnover in grasslands is moved 
+       !  into the harvest pool but this approach should be considered as a
+       !  patch rather than a permanent solution.
+       IF(EndofYear)THEN
+ 
+          IF (control%ok_dofoco) THEN
+
+             ! Wood harvest with small dimensions is being used as fire wood
+             ! the remaining wood goes into the short, medium and long product
+             ! pools. This implies that when the dimensions of the harvest 
+             ! change, the product pools will change as well
+             CALL dim_product_use(npts, dt_days, harvest_pool_bound, harvest_pool, &
+                  harvest_type, harvest_cut, harvest_area, &
+                  cflux_prod_s, cflux_prod_m, cflux_prod_l, prod_s, &
+                  prod_m, prod_l, prod_s_total, prod_m_total, &
+                  prod_l_total, cflux_prod_total, flux_s, flux_m, &
+                  flux_l, resolution) 
+
+          ELSE
+
+             ! The scheme does not account for the harvest dimensions. All
+             ! wood is distributed across the short, medium and long product
+             ! pools. This basically means that wood use in 1600, 1700, 1800,
+             ! 1900 and 2000 was identical.
+             CALL basic_product_use(npts, dt_days, harvest_pool_bound, harvest_pool, &
+                  harvest_type, harvest_cut, harvest_area, &
+                  cflux_prod_s, cflux_prod_m, cflux_prod_l, prod_s, &
+                  prod_m, prod_l, prod_s_total, prod_m_total, &
+                  prod_l_total, cflux_prod_total, flux_s, flux_m, &
+                  flux_l, resolution)
+
+          ENDIF ! control%ok_dofoco
+
+        ELSE
+    
+          ! These variables are all intent(out) so they should be initialized 
+          ! if it's not the end of the year
+          CALL basic_product_init(cflux_prod_s, cflux_prod_m, cflux_prod_l, &
+               prod_s_total, prod_m_total, prod_l_total, flux_s, &
+               flux_m, flux_l, cflux_prod_total)
+
+       ENDIF
+
+       !---TEMP---
+       CALL check_biomass_sync("stomate_lpj.f90: After basic_product_use", &
+            npts, biomass, &
+            circ_class_biomass, circ_class_n, ind, &
+            lsync, bm_sync)
+       !write(*,*) 'CCNsum_after_basic',sum(circ_class_n(1,2,:))
+       !write(*,*) 'ind_after_basic',ind(1,2) 
+       !write(*,*) 'BIOMASS_after_basic',sum(sum(biomass(1,2,1:8,:),dim=2),dim=1)
+       !write(*,*) 'sync_after_basic',sum(bm_sync(1,2,:))
+
+
+ !! 12. Establishment of saplings
+    WRITE(numout,*) "ok_recruitment = ", control%ok_recruitment
+    WRITE(numout,*) "ok_daily_recruitment = ", control%ok_daily_recruitment
+ 
+     IF(control%ok_dofoco)THEN
+        control%ok_recruitment = .FALSE.
+        CALL getin_p('RECRUITMENT', control%ok_recruitment)
+        control%ok_daily_recruitment = .FALSE.
+        CALL getin_p('DAILY_RECRUITMENT', control%ok_daily_recruitment)
+    ENDIF
+ 
+    WRITE(numout,*) "ok_recruitment = ", control%ok_recruitment
+    WRITE(numout,*) "ok_daily_recruitment = ", control%ok_daily_recruitment
+ 
+    IF(control%ok_recruitment)THEN
+        !! 12.1 Call recruitment subroutine
+        IF(EndofYear .AND. .NOT. control%ok_daily_recruitment)THEN
+            
+            ! Recruitment is based on the maximal number of stems and the fraction of light
+            ! reaching the floor. All the new saplings are stored in the first class and have a mean biomass
+            ! of about ...
+            CALL recruitment(npts, dt_days, veget_max, veget, tau_eff_root, tau_eff_sap, &
+                    tau_eff_leaf, ind, circ_class_n, biomass, circ_class_biomass, &
+                    co2_to_bm, leaf_frac, KF, senescence,new_ind)
+ 
+        ELSEIF(control%ok_daily_recruitment)THEN
+            ! Recruitment is based on the maximal number of stems and the fraction of light
+            ! reaching the floor. All the new saplings are stored in the first class and have a mean biomass
+            ! of about ...
+            CALL recruitment(npts, dt_days, veget_max, veget, tau_eff_root, tau_eff_sap, &
+                    tau_eff_leaf, ind, circ_class_n, biomass, circ_class_biomass, &
+                    co2_to_bm, leaf_frac, KF, senescence, new_ind)
+               
+        ENDIF
+            !! 12.2 Calculate mass balance
+            !  All C-fluxes except co2_to_bm are calculated before the code deals
+            !  with LCC. So in general it doesn't matter whether we use the fluxes
+            !  from before or the fluxes from after LCC as the should be exactely the same
+            !  except for the fact that they could have been moved from one PFT to another.
+            !  There are two important exceptions to this general rule and these
+            !  exceptions are the cause of the need of the variable ::orphan_flux: (1) PFTs that
+            !  entirely disappear and PFT's that are newly established (and will therefore
+            !  take up co2 from the atmosphere. The first exception results in orphan
+            !  fluxes which should be accounted for. The second results in the risk of double
+            !  counting. When land cover change occurs, PFTs may be entirely removed. When
+            !  a PFT is changed into another PFT, the fluxes i.e. GPP are averaged.
+            !  However, when a PFT is removed and becomes PFT1 these fluxes will be lost.
+            !  We could store just these fluxes and apply a correction when needed
+            !  or we can simply store all fluxes for the old veget_max values and use
+            !  where needed i.e. in the mass balance (note that additional bookkeeping
+            !  tricks are required for co2_to_bm). Also, these fluxes should be shown in 
+            !  the histwrite files but not in the restart files.
+               orphan_flux(:,:,ivegold,icarbon) = veget_max(:,:)
+               orphan_flux(:,:,igpp,icarbon) = gpp_daily(:,:)
+               orphan_flux(:,:,ico2bm,icarbon) = co2_to_bm(:,:)
+               orphan_flux(:,:,irmain,icarbon) = resp_maint(:,:)
+               orphan_flux(:,:,irgrow,icarbon) = resp_growth(:,:)
+               orphan_flux(:,:,inpp,icarbon) = npp_daily(:,:)
+               orphan_flux(:,:,irhet,icarbon) = resp_hetero(:,:)
+    ENDIF 
+
+!!$       IF (.NOT. control%ok_constant_mortality) THEN
+
+          ! Establish new plants based on the functional allocation
+          ! +++CHECK+++
+          ! How does this intefer with self-thinning it seems that this code tries 
+          ! to maintain a +/- high biomass by adding individuals when the fpc (foliage
+          ! projected cover decreases). This is exactely what we want to avoid as we
+          ! want to introduce gaps in the static approach. We could try to adjust the 
+          ! proposed aproach for unmanaged systems but I doubt whether the rule of 
+          ! Deleuze and Dhote could deal with such an extreme range of diameter sizes
+          ! Most unmanged forest are under a disturbance regime and may be aproximated 
+          ! by an 'even-age' evolution.
+
+          ! NOTE:  We have decided not to create this routine.  The reasoning is that
+          ! we really want gaps in the system and don't want to continually establish.
+          ! All of this should be taken care of in prescribe_prognostic at the end
+          ! of the year.  If someone wants to run with DGVM and the new allocation,
+          ! this will require some effort here.
+
+!!$       CALL establish_prognostic (npts, dt_days, PFTpresent, regenerate, &
+!!$            neighbours, resolution, need_adjacent, herbivores, &
+!!$            precip_lastyear, gdd0_lastyear, lm_lastyearmax, avail_tree, &
+!!$            avail_grass, npp_longterm, leaf_age, leaf_frac, &
+!!$            ind, biomass, age, everywhere, &
+!!$            co2_to_bm, veget_max, circ_class_biomass, circ_class_n)
+          ! ++++++++++++
+
+!!$       ELSE
+
+          ! Plant establishment does not occur when constant mortality 
+          ! is used outside the DGVM. Write the values of the flags to 
+          ! make sure this condition is satisfied
+!!$          IF (firstcall) THEN
+!!$
+!!$             WRITE(numout,*) 'Plant establishment does not occur because '
+!!$             WRITE(numout,*) 'constant mortality is used outside the DGVM'
+!!$             WRITE(numout,*) 'control%ok_functional_allocation, ', &
+!!$                  control%ok_functional_allocation
+!!$             WRITE(numout,*) 'control%ok_dgvm, ', control%ok_dgvm
+!!$             WRITE(numout,*) 'control%ok_constant_mortality, ', &
+!!$                  control%ok_constant_mortality
+
+!!$          ENDIF
+
+!!$       ENDIF  ! constant mortality 
+
+       !---TEMP---
+       CALL check_biomass_sync("stomate_lpj.f90: After establish", npts, biomass, &
+            circ_class_biomass, circ_class_n, ind, &
+            lsync, bm_sync)
+       
+       CALL histwrite_p (hist_id_stomate, 'NEW_IND', itime, &
+            new_ind, npts*nvm, horipft_index)
+
+ 
+       !write(*,*) 'CCNsum_after_establish',sum(circ_class_n(1,2,:))
+       !write(*,*) 'ind_after_establish',ind(1,2)
+       !write(*,*) 'BIOMASS_after_establish',sum(sum(biomass(1,2,1:8,:),dim=2),dim=1)
+       !write(*,*) 'sync_after_establish',sum(bm_sync(1,2,:))
+    DO icir=1,ncirc
+        circ_class_abg(:,:,icir)=(circ_class_biomass(:,:,icir,1,iele)+circ_class_biomass(:,:,icir,2,iele)+circ_class_biomass(:,:,icir,4,iele)+circ_class_biomass(:,:,icir,7,iele))*circ_class_n(:,:,icir)
+        WRITE (var_name,"('circ_class_abg_',i3.3)") icir
+           CALL histwrite_p(hist_id_stomate, var_name,itime,circ_class_abg(:,:,icir),npts*nvm, horipft_index)
+    ENDDO
+
+       !! 13. Replant PFTs with a different species.
+
+       IF(EndOfYear)THEN
+
+          IF(lchange_species)THEN
+
+             ! This is an ad-hoc method to change the species after they die.
+             ! It is only meant to change species through human intervention.
+             ! In theory, this is a function that should be done in a DGVM, which
+             ! is why this code is considered only temporary.
+!!$             CALL species_change (npts, dt_days, veget_max, veget, harvest_pool, &
+!!$                  harvest_type, harvest_cut, harvest_area, &
+!!$                  litter, carbon, lignin_struc, lignin_wood, &
+!!$                  biomass, PFTpresent, everywhere, when_growthinit, & 
+!!$                  leaf_frac, ind, circ_class_n, circ_class_biomass, &
+!!$                  co2_to_bm, forest_managed, &
+!!$                  KF, wstress_season, wstress_month, senescence, npp_longterm, &
+!!$                  age, lm_lastyearmax, harvest_pool_bound, resolution, &
+!!$                  bm_to_litter, leaf_age, circ_class_dist, orphan_flux, &
+!!$                  bm_sync, vir_wstress_fac, tau_eff_leaf, tau_eff_sap, &
+!!$                  tau_eff_root, age_stand, last_cut, &
+!!$                  c_buried, mb_err_lcc, k_latosa_adapt, lpft_replant,&
+!!$                  species_change_map)
+
+             ! I am going to try something.  Instead of changing the LCC code, I'm
+             ! going to try to just change the inputs to mimic species change.  This
+             ! should be possible by simply changing the veget_max_new fractions
+             ! and then going through all the same LCC code.
+             veget_max_new_species(:,:)=zero
+             DO ipts = 1,npts
+                
+                DO ivm=1,nvm
+                   
+                   ! Did this PFT die this year?
+                   IF(lpft_replant(ipts,ivm))THEN
+                      
+                      ! Remove the old veget_max and add it to the new.
+                      veget_max_new_species(ipts,ivm)=zero
+                      ! Find out which PFT is the youngest member of the group that
+                      ! we want to regrow.
+                      ivm_young=0
+                      DO
+                         ivm_young=ivm_young+1
+                         IF(ivm_young .GT. nvm)THEN
+                            WRITE(numout,*) "ERROR: Can not find young PFT for this age class."
+                            WRITE(numout,*) "ipts: ",ipts
+                            WRITE(numout,*) "species_change_map(ipts,:): ",species_change_map(ipts,:)
+                            CALL ipslerr_p (3,'stomatelpj', 'Could not find the youngest PFT in this age class.',&
+                                 'This probably means that something is wrong with the species_change_map.',&
+                                 'Check the out_orchidee file for details.')
+
+                         ENDIF
+                         IF(agec_group(ivm_young) == species_change_map(ipts,ivm))THEN
+                            EXIT
+                         ENDIF
+
+                      ENDDO
+                      veget_max_new_species(ipts,ivm_young)=veget_max_new_species(ipts,ivm_young)+veget_max(ipts,ivm)
+                   ELSE
+                      ! veget_max_new will be the same as the old_veget_max.
+                      ! We add it here just in case another PFT was added to this one
+                      ! above.
+                      veget_max_new_species(ipts,ivm)=veget_max_new_species(ipts,ivm)+veget_max(ipts,ivm)
+                      
+                   ENDIF
+                   
+                ENDDO
+             ENDDO
+             
+
+             CALL land_cover_change_main (npts, dt_days, veget_max, veget, harvest_pool, &
+                  harvest_type, harvest_cut, harvest_area, &
+                  litter, carbon, lignin_struc, lignin_wood, &
+                  biomass, PFTpresent, everywhere, when_growthinit, & 
+                  leaf_frac, ind, circ_class_n, circ_class_biomass, &
+                  co2_to_bm, forest_managed, &
+                  KF, wstress_season, wstress_month, senescence, npp_longterm, &
+                  age, lm_lastyearmax, harvest_pool_bound, resolution, &
+                  bm_to_litter, leaf_age, circ_class_dist, orphan_flux, &
+                  bm_sync, vir_wstress_fac, tau_eff_leaf, tau_eff_sap, &
+                  tau_eff_root, veget_max_new_species, age_stand, last_cut, &
+                  c_buried, mb_err_lcc, k_latosa_adapt)
+             
+             
+          ENDIF ! checking for species change
+
+          ! reset this variable
+          lpft_replant(:,:)=.FALSE.
+
+       ENDIF ! checking for the end of the year
+
+  !! 14. Compute the effective leaf area index. 
+  
+       ! This is a function of the solar angle, and needed for the albedo
+       ! and the photosynthesis.  It was very expensive to compute, so instead
+       ! of computing it at every timestep we compute it at a couple points
+       ! throughout the day and fit a function to it.  We do this now because
+       ! the canopy as it appears now will be used for the next day.
+
+       ! I also need to put in a function here to compute the height of the photosynthesis
+       ! levels given the height of the energy levels and the vegetation on the grid 
+       ! square.  The hightest levels will be a function of the height of the vegetation
+       ! so that we don't waste computational time on empty levels.
+       CALL calculate_z_level_photo(npts, &
+            circ_class_biomass, &
+            circ_class_n, biomass, z_level_photo)
+       
+       ! Finding the true LAI per level is different from finding the
+       ! effective LAI per level, so we'll do that here.  This only
+       ! changes once every day so hopefully it is not too expensive.
+       ! It will eventually be needed by the energy budget.  It is
+       ! also needed by effective_lai for grasses and crops.
+       CALL find_lai_per_level(npts, nlevels_tot, z_level_photo, &
+            biomass, circ_class_biomass, &
+            circ_class_n, lai_per_level)
+       
+       ! Now we actually find the effective LAI and fit the function 
+       ! we'll use later on 
+       CALL fitting_laieff(npts, nlevels_tot, z_level_photo, circ_class_biomass, & 
+            circ_class_n, veget_max, biomass, lai_per_level, laieff_fit) 
+	 	 	 
+
+  !! 14. Check mass balance closure
+       
+       !! 15.1 Calculate components of the mass balance
+       pool_end(:,:,:) = zero 
+       DO ipar = 1,nparts
+          DO iele = 1,nelements
+             pool_end(:,:,iele) = pool_end(:,:,iele) + &
+                  (biomass(:,:,ipar,iele) + bm_to_litter(:,:,ipar,iele) + &
+                  turnover_daily(:,:,ipar,iele)) * veget_max(:,:)
+          ENDDO
+       ENDDO
+       
+       pool_end(:,1,icarbon) = pool_end(:,1,icarbon) + &
+            ( SUM(SUM(harvest_pool(:,:,:,icarbon),3),2) + &
+            SUM(prod_l(:,:),2) + SUM(prod_m(:,:),2) + &
+            SUM(prod_s(:,:),2) ) / pixel_area(:)
+
+       !! 15.2 Calculate mass balance
+       !  iatm2land and iland2atm have already been calculated after growth in Â§4.2
+       ! For the orphan fluxes, ivegnew is just the veget_max as it currently is.
+       ! If the veget_max has not changed, the orphan_fluxes for ivegold and ivegnew
+       ! are exactly the same.
+       !+++ +CHECK ++++
+       ! We will probably need two orphan fluxes...one for gap_clean and one for
+       ! LCC.  So right now we should not trust stomate_lpj closure.  However,
+       ! all of the routines in stomate_lpj should be closed.
+       !++++++++++++++
+       orphan_flux(:,:,ivegnew,icarbon)=veget_max(:,:)
+
+       ! Use orphan fluxes here as well.  In the case of age classes, if an old
+       ! PFT dies, it will regrow as the youngest PFT, requiring the use of an 
+       ! orphan flux.  If this doesn't happen, the orphan fluxes are identical
+       ! to GPP, co2bm, and veget_max, so the equation collapses to the correct one.
+       check_intern(:,:,iatm2land,icarbon) = &
+            orphan_flux(:,:,igpp,icarbon) * orphan_flux(:,:,ivegold,icarbon) +  &
+            orphan_flux(:,:,ico2bm,icarbon) * orphan_flux(:,:,ivegnew,icarbon)
+       check_intern(:,:,iland2atm,icarbon) = -un * (orphan_flux(:,:,irmain,icarbon) + &
+                  orphan_flux(:,:,irgrow,icarbon)) * orphan_flux(:,:,ivegold,icarbon)
+       check_intern(:,1,iland2atm,icarbon) = -un * ( SUM(flux_s(:,:),2) + SUM(flux_m(:,:),2) + & 
+            SUM(flux_l(:,:),2) ) / pixel_area(:)
+       check_intern(:,:,ilat2out,icarbon) = zero
+       check_intern(:,:,ilat2in,icarbon) = -un * zero
+       check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - pool_start(:,:,icarbon))
+       closure_intern = zero
+       DO imbc = 1,nmbcomp
+          closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + check_intern(:,:,imbc,icarbon)
+       ENDDO
+
+       !! 15.3 Write outcome of the check
+       !  Sum over ivm because of LCC
+       DO ipts=1,npts
+          IF(ABS(SUM(closure_intern(ipts,:,icarbon))) .LE. min_stomate)THEN
+             IF (ld_massbal) WRITE(numout,*) 'Mass balance closure in stomate_lpj.f90'
+          ELSE
+             WRITE(numout,*) 'Error: mass balance is not closed in stomate_lpj.f90'
+             WRITE(numout,*) 'Total difference: ',SUM(closure_intern(ipts,:,icarbon))
+             DO ivm=1,nvm
+                WRITE(numout,*) '   ipts, ivm: ', ipts,ivm
+                WRITE(numout,*) '   Difference is, ', closure_intern(ipts,ivm,icarbon)
+                WRITE(numout,*) '   pool_end,pool_start: ', pool_end(ipts,ivm,icarbon), pool_start(ipts,ivm,icarbon)
+                WRITE(numout,*) '   orphan_fluxes: ', orphan_flux(ipts,ivm,irmain,icarbon),&
+                     orphan_flux(ipts,ivm,irgrow,icarbon),orphan_flux(ipts,ivm,ivegold,icarbon)
+             !   IF (control%ok_land_cover_change .AND. EndOfYear) THEN
+                    WRITE(numout,*) '   orphan_fluxes LCC (total): ',check_intern(ipts,ivm,iatm2land,icarbon)
+                    WRITE(numout,*) '   orphan_fluxes LCC: ',&
+                        orphan_flux(ipts,ivm,igpp,icarbon), orphan_flux(ipts,ivm,ivegold,icarbon),  &
+                        orphan_flux(ipts,ivm,ico2bm,icarbon), orphan_flux(ipts,ivm,ivegnew,icarbon)
+             !   ELSE
+                    WRITE(numout,*) '   atm2land (total): ',check_intern(ipts,ivm,iatm2land,icarbon)
+                    WRITE(numout,*) '   gpp,co2_to_bm,veget_max: ',gpp_daily(ipts,ivm), co2_to_bm(ipts,ivm), &
+                        veget_max(ipts,ivm)
+             !   ENDIF
+            ENDDO
+             WRITE(numout,*) '   flux_s: ', flux_s(ipts,:)
+             WRITE(numout,*) '   flux_m: ', flux_m(ipts,:)
+             WRITE(numout,*) '   flux_l: ', flux_l(ipts,:)
+             WRITE(numout,*) '   pixel_area: ', pixel_area(ipts)
+             IF(ld_stop)THEN
+                CALL ipslerr_p (3,'stomatelpg', 'Mass balance error.','','')
+             ENDIF
+          ENDIF
+       ENDDO
+
+ !! 15. Write history
+
+       !! 16.1 Write Esiting variables ioserver
+       CALL xios_orchidee_send_field("RESOLUTION_X",resolution(:,1))
+       CALL xios_orchidee_send_field("RESOLUTION_Y",resolution(:,2))
+       CALL xios_orchidee_send_field("CONTFRAC_STOMATE",contfrac(:))
+       CALL xios_orchidee_send_field("T2M_MONTH",t2m_month)
+       CALL xios_orchidee_send_field("T2M_WEEK",t2m_week)
+       CALL xios_orchidee_send_field("HET_RESP",resp_hetero(:,:))
+       CALL xios_orchidee_send_field("CO2_FIRE",co2_fire)
+       CALL xios_orchidee_send_field("CO2_TAKEN",co2_to_bm)
+       CALL xios_orchidee_send_field("VEGET_MAX",veget_max)
+       CALL xios_orchidee_send_field("NPP_STOMATE",npp_daily)
+       CALL xios_orchidee_send_field("GPP",gpp_daily)
+       CALL xios_orchidee_send_field("IND",ind)
+       CALL xios_orchidee_send_field("CN_IND",cn_ind)
+       CALL xios_orchidee_send_field("WOODMASS_IND",woodmass_ind)
+       CALL xios_orchidee_send_field("MOISTRESS",moiavail_week)
+       CALL xios_orchidee_send_field("LEAF_M",biomass(:,:,ileaf,icarbon))
+       CALL xios_orchidee_send_field("SAP_M_AB",biomass(:,:,isapabove,icarbon))
+       CALL xios_orchidee_send_field("SAP_M_BE",biomass(:,:,isapbelow,icarbon))
+       CALL xios_orchidee_send_field("HEART_M_AB",biomass(:,:,iheartabove,icarbon))
+       CALL xios_orchidee_send_field("HEART_M_BE",biomass(:,:,iheartbelow,icarbon))
+       CALL xios_orchidee_send_field("ROOT_M",biomass(:,:,iroot,icarbon))
+       CALL xios_orchidee_send_field("FRUIT_M",biomass(:,:,ifruit,icarbon))
+       CALL xios_orchidee_send_field("RESERVE_M",biomass(:,:,icarbres,icarbon))
+       CALL xios_orchidee_send_field("LEAF_TURN",turnover_daily(:,:,ileaf,icarbon))
+       CALL xios_orchidee_send_field("MAINT_RESP",resp_maint)
+       CALL xios_orchidee_send_field("GROWTH_RESP",resp_growth)
+       CALL xios_orchidee_send_field("SAP_AB_TURN",turnover_daily(:,:,isapabove,icarbon))
+       CALL xios_orchidee_send_field("ROOT_TURN",turnover_daily(:,:,iroot,icarbon))
+       CALL xios_orchidee_send_field("FRUIT_TURN",turnover_daily(:,:,ifruit,icarbon))
+       CALL xios_orchidee_send_field("LEAF_BM_LITTER",bm_to_litter(:,:,ileaf,icarbon))
+       CALL xios_orchidee_send_field("SAP_AB_BM_LITTER",bm_to_litter(:,:,isapabove,icarbon))
+       CALL xios_orchidee_send_field("SAP_BE_BM_LITTER",bm_to_litter(:,:,isapbelow,icarbon))
+       CALL xios_orchidee_send_field("HEART_AB_BM_LITTER",bm_to_litter(:,:,iheartabove,icarbon))
+       CALL xios_orchidee_send_field("HEART_BE_BM_LITTER",bm_to_litter(:,:,iheartbelow,icarbon))
+       CALL xios_orchidee_send_field("ROOT_BM_LITTER",bm_to_litter(:,:,iroot,icarbon))
+       CALL xios_orchidee_send_field("FRUIT_BM_LITTER",bm_to_litter(:,:,ifruit,icarbon))
+       CALL xios_orchidee_send_field("RESERVE_BM_LITTER",bm_to_litter(:,:,icarbres,icarbon))
+       CALL xios_orchidee_send_field("LITTER_STR_AB",litter(:,istructural,:,iabove,icarbon))
+       CALL xios_orchidee_send_field("LITTER_MET_AB",litter(:,imetabolic,:,iabove,icarbon))
+       CALL xios_orchidee_send_field("LITTER_STR_BE",litter(:,istructural,:,ibelow,icarbon))
+       CALL xios_orchidee_send_field("LITTER_MET_BE",litter(:,imetabolic,:,ibelow,icarbon))
+       CALL xios_orchidee_send_field("DEADLEAF_COVER",deadleaf_cover)
+       CALL xios_orchidee_send_field("CARBON_ACTIVE",carbon(:,iactive,:))
+       CALL xios_orchidee_send_field("CARBON_SLOW",carbon(:,islow,:))
+       CALL xios_orchidee_send_field("CARBON_PASSIVE",carbon(:,ipassive,:))
+       CALL xios_orchidee_send_field("LITTERHUM",litterhum_daily)
+       CALL xios_orchidee_send_field("TURNOVER_TIME",turnover_time)
+       ! Some of these are commented out because they are the result of
+       ! a merge from the trunk, but we don't have those variables anymore.
+       !    CALL xios_orchidee_send_field("PROD10",prod10)
+       !    CALL xios_orchidee_send_field("FLUX10",flux10)
+       !    CALL xios_orchidee_send_field("PROD100",prod100)
+       !    CALL xios_orchidee_send_field("FLUX100",flux100)
+       !    CALL xios_orchidee_send_field("CONVFLUX",convflux)
+       !    CALL xios_orchidee_send_field("CFLUX_PROD10",cflux_prod10)
+       !    CALL xios_orchidee_send_field("CFLUX_PROD100",cflux_prod100)
+       !    CALL xios_orchidee_send_field("HARVEST_ABOVE",harvest_above)
+       CALL xios_orchidee_send_field("VCMAX",vcmax)
+       CALL xios_orchidee_send_field("AGE",age)
+       !    CALL xios_orchidee_send_field("HEIGHT",height)
+       CALL xios_orchidee_send_field("BLACK_CARBON",black_carbon)
+       CALL xios_orchidee_send_field("FIREINDEX",fireindex(:,:))
+       ! ipcc history
+       !     CALL xios_orchidee_send_field("cProduct",(prod10_total + prod100_total)/1e3)
+       CALL xios_orchidee_send_field("gpp_ipcc",SUM(gpp_daily*veget_max,dim=2)/1e3/one_day*contfrac)
+       CALL xios_orchidee_send_field("ra",SUM((resp_maint+resp_growth)*veget_max,dim=2)/1e3/one_day*contfrac)
+       CALL xios_orchidee_send_field("npp_ipcc",SUM(npp_daily*veget_max,dim=2)/1e3/one_day*contfrac)
+       CALL xios_orchidee_send_field("rh",SUM(resp_hetero*veget_max,dim=2)/1e3/one_day*contfrac)
+       CALL xios_orchidee_send_field("fFire",SUM(co2_fire*veget_max,dim=2)/1e3/one_day*contfrac)
+       !     CALL xios_orchidee_send_field("fHarvest",harvest_above/1e3/one_day*contfrac)
+       CALL xios_orchidee_send_field("fLuc",cflux_prod_total/1e3/one_day*contfrac)
+       !     CALL xios_orchidee_send_field("nbp",(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 xios_orchidee_send_field("fLitterSoil",SUM(SUM(soilcarbon_input,dim=2)*veget_max,dim=2)/1e3/one_day*contfrac)
+       CALL xios_orchidee_send_field("cLeaf",SUM(biomass(:,:,ileaf,icarbon)*veget_max,dim=2)/1e3*contfrac)
+       CALL xios_orchidee_send_field("cWood",SUM((biomass(:,:,isapabove,icarbon)+biomass(:,:,iheartabove,icarbon))*&
+            veget_max,dim=2)/1e3*contfrac)
+       CALL xios_orchidee_send_field("cRoot",SUM(( biomass(:,:,iroot,icarbon) + biomass(:,:,isapbelow,icarbon) + &
+            biomass(:,:,iheartbelow,icarbon) )*veget_max,dim=2)/1e3*contfrac)
+       CALL xios_orchidee_send_field("cMisc",SUM(( biomass(:,:,icarbres,icarbon) + biomass(:,:,ifruit,icarbon))*&
+            veget_max,dim=2)/1e3*contfrac)
+       CALL xios_orchidee_send_field("cLitterAbove",SUM((litter(:,istructural,:,iabove,icarbon)+&
+            litter(:,imetabolic,:,iabove,icarbon))*veget_max,dim=2)/1e3*contfrac)
+       CALL xios_orchidee_send_field("cLitterBelow",SUM((litter(:,istructural,:,ibelow,icarbon)+&
+            litter(:,imetabolic,:,ibelow,icarbon))*veget_max,dim=2)/1e3*contfrac)
+       CALL xios_orchidee_send_field("cSoilFast",SUM(carbon(:,iactive,:)*veget_max,dim=2)/1e3*contfrac)
+       CALL xios_orchidee_send_field("cSoilMedium",SUM(carbon(:,islow,:)*veget_max,dim=2)/1e3*contfrac)
+       CALL xios_orchidee_send_field("cSoilSlow",SUM(carbon(:,ipassive,:)*veget_max,dim=2)/1e3*contfrac)
+       DO j=1,nvm
+          histvar(:,j)=veget_max(:,j)*contfrac(:)*100
+       ENDDO
+       CALL xios_orchidee_send_field("landCoverFrac",histvar)
+       vartmp(:)=zero
+       DO j = 2,nvm
+          IF (is_deciduous(j)) THEN
+             vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100
+          ENDIF
+       ENDDO
+       CALL xios_orchidee_send_field("treeFracPrimDec",vartmp)
+       vartmp(:)=zero
+       DO j = 2,nvm
+          IF (is_evergreen(j)) THEN
+             vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100
+          ENDIF
+       ENDDO
+       CALL xios_orchidee_send_field("treeFracPrimEver",vartmp)
+       vartmp(:)=zero
+       DO j = 2,nvm
+          IF ( .NOT.(is_c4(j)) ) THEN
+             vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100
+          ENDIF
+       ENDDO
+       CALL xios_orchidee_send_field("c3PftFrac",vartmp)
+       vartmp(:)=zero
+       DO j = 2,nvm
+          IF ( is_c4(j) ) THEN
+             vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100
+          ENDIF
+       ENDDO
+       CALL xios_orchidee_send_field("c4PftFrac",vartmp)
+       CALL xios_orchidee_send_field("rGrowth",SUM(resp_growth*veget_max,dim=2)/1e3/one_day*contfrac)
+       CALL xios_orchidee_send_field("rMaint",SUM(resp_maint*veget_max,dim=2)/1e3/one_day*contfrac)
+       CALL xios_orchidee_send_field("nppLeaf",SUM(bm_alloc(:,:,ileaf,icarbon)*veget_max,dim=2)/1e3/one_day*contfrac)
+       CALL xios_orchidee_send_field("nppWood",SUM(bm_alloc(:,:,isapabove,icarbon)*veget_max,dim=2)/1e3/one_day*contfrac)
+       CALL xios_orchidee_send_field("nppRoot",SUM(( bm_alloc(:,:,isapbelow,icarbon) + bm_alloc(:,:,iroot,icarbon) )*&
+            veget_max,dim=2)/1e3/one_day*contfrac)     
+
+       !++++++ TEMP +++++++
+      CALL histwrite_p (hist_id_stomate, 'LIGNIN_STRUC_AB', itime, &
+            lignin_struc(:,:,iabove), npts*nvm, horipft_index)
+      CALL histwrite_p (hist_id_stomate, 'LIGNIN_STRUC_BE', itime, &
+            lignin_struc(:,:,ibelow), npts*nvm, horipft_index)
+      CALL histwrite_p (hist_id_stomate, 'LIGNIN_WOOD_AB', itime, &
+            lignin_wood(:,:,iabove), npts*nvm, horipft_index)
+      CALL histwrite_p (hist_id_stomate, 'LIGNIN_WOOD_BE', itime, &
+            lignin_wood(:,:,ibelow), npts*nvm, horipft_index)
+      
+       !+++++++++++++++++++
+
+       CALL histwrite_p (hist_id_stomate, 'RESOLUTION_X', itime, &
+            resolution(:,1), npts, hori_index)
+       CALL histwrite_p (hist_id_stomate, 'RESOLUTION_Y', itime, &
+            resolution(:,2), npts, hori_index)
+       CALL histwrite_p (hist_id_stomate, 'CONTFRAC', itime, &
+            contfrac(:), npts, hori_index)
+       CALL histwrite_p (hist_id_stomate, 'LITTER_STR_AB', itime, &
+            litter(:,istructural,:,iabove,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'LITTER_MET_AB', itime, &
+            litter(:,imetabolic,:,iabove,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'LITTER_STR_BE', itime, &
+            litter(:,istructural,:,ibelow,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'LITTER_MET_BE', itime, &
+            litter(:,imetabolic,:,ibelow,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'LITTER_WOD_AB', itime, &
+            litter(:,iwoody,:,iabove,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'LITTER_WOD_BE', itime, &
+            litter(:,iwoody,:,ibelow,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'DEADLEAF_COVER', itime, &
+            deadleaf_cover, npts, hori_index)
+       CALL histwrite_p (hist_id_stomate, 'CARBON_ACTIVE', itime, &
+            carbon(:,iactive,:), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'CARBON_SLOW', itime, &
+            carbon(:,islow,:), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'CARBON_PASSIVE', itime, &
+            carbon(:,ipassive,:), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'T2M_MONTH', itime, &
+            t2m_month, npts, hori_index)
+       CALL histwrite_p (hist_id_stomate, 'T2M_WEEK', itime, &
+            t2m_week, npts, hori_index)
+       CALL histwrite_p (hist_id_stomate, 'HET_RESP', itime, &
+            resp_hetero(:,:), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'HET_RESP_SOIL', itime, &
+            resp_hetero_soil(:,:), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'HET_RESP_LITTER', itime, &
+            resp_hetero_litter(:,:), npts*nvm, horipft_index)
+
+       CALL histwrite_p (hist_id_stomate, 'BLACK_CARBON', itime, &
+            black_carbon, npts, hori_index)
+       CALL histwrite_p (hist_id_stomate, 'FIREINDEX', itime, &
+            fireindex(:,:), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'LITTERHUM', itime, &
+            litterhum_daily, npts, hori_index)
+       CALL histwrite_p (hist_id_stomate, 'CO2_FIRE', itime, &
+            co2_fire, npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'CO2_TAKEN', itime, &
+            co2_to_bm, npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'RDI', itime, &
+             rdi, npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'RDI_TARGET_UPPER', itime, &
+            rdi_target_upper, npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'RDI_TARGET_LOWER', itime, &
+         rdi_target_lower, npts*nvm, horipft_index)
+
+       ! Calculate lai so it can be written to the history files
+       DO ivm = 2,nvm
+          lai(:,ivm) = biomass(:,ivm,ileaf,icarbon) * sla(ivm)
+          DO ipts = 1,npts
+             qm_dia(ipts,ivm) = wood_to_qmdia(circ_class_biomass(ipts,ivm,:,:,icarbon), &
+                  circ_class_n(ipts,ivm,:), ivm)
+             qm_height(ipts,ivm) = wood_to_qmheight(circ_class_biomass(ipts,ivm,:,:,icarbon), &
+                  circ_class_n(ipts,ivm,:), ivm)
+          ENDDO
+       ENDDO
+       lai(:,1) = zero
+       qm_dia(:,1) = zero
+       qm_height(:,1) = zero
+
+       CALL xios_orchidee_send_field("LAI",lai)
+       CALL xios_orchidee_send_field("lai_ipcc",SUM(lai*veget_max,dim=2)*contfrac)
+       CALL histwrite_p (hist_id_stomate, 'LAI', itime, &
+            lai, npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'VEGET_MAX', itime, &
+            veget_max, npts*nvm, horipft_index)
+      
+       ! Calculate and write lai per pixel for optimization 
+       laipix(:) = zero
+       gpppix(:) = zero
+       !laieff_pix (:) = zero
+       lai(:,1) = zero
+       gpp_daily(:,1) = zero
+       laipix(:) = SUM(lai(:,:)*veget_max(:,:),2)
+       gpppix(:) = SUM(gpp_daily(:,:)*veget_max(:,:),2)
+       !WRITE (numout,*) 'lai'
+       !WRITE (numout,*) 'lai per pixel', laipix 
+       CALL histwrite_p(hist_id_stomate, 'LAIPIX', itime, laipix, npts, hori_index)
+       CALL histwrite_p (hist_id_stomate, 'NPP', itime, &
+            npp_daily, npts*nvm, horipft_index)
+       ! Use orphan flux so gpp is accounted for even if the PFT was removed
+       CALL histwrite_p (hist_id_stomate, 'GPP', itime, &
+            orphan_flux(:,:,igpp,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p(hist_id_stomate, 'GPPPIX',itime, gpppix, npts, hori_index)
+       CALL histwrite_p (hist_id_stomate, 'IND', itime, &
+            ind, npts*nvm, horipft_index)
+
+       ! Calculate lai per level.  Also print out the real height of
+       ! the canopy level.
+       DO ivm=1,nvm
+!          CALL combine_lai_levels(lai_per_level,lai_per_level_temp)
+!          DO ipts=1,npts
+!             lai_per_level_temp(ipts,ivm,:)=SUM(lai_per_level_temp(ipts,ivm,:))
+!          ENDDO
+          WRITE(var_name,'(A,I3.3)') 'LAI_PER_LEVEL_',ivm
+          CALL histwrite_p (hist_id_stomate, var_name, itime, &
+               lai_per_level(:,ivm,:), npts*nlevels_tot, horican_index)
+
+          WRITE(var_name,'(A,I3.3)') 'CLEVEL_HEIGHT_',ivm
+          CALL histwrite_p (hist_id_stomate, var_name, itime, &
+               z_level_photo(:,ivm,:), npts*nlevels_tot, horican_index) 
+
+       ENDDO
+
+       CALL histwrite_p (hist_id_stomate, 'CN_IND', itime, &
+            cn_ind, npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'WOODMASS_IND', itime, &
+            woodmass_ind, npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'LEAF_M', itime, &
+            biomass(:,:,ileaf,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'SAP_M_AB', itime, &
+            biomass(:,:,isapabove,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'SAP_M_BE', itime, &
+            biomass(:,:,isapbelow,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'HEART_M_AB', itime, &
+            biomass(:,:,iheartabove,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'HEART_M_BE', itime, &
+            biomass(:,:,iheartbelow,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'ROOT_M', itime, &
+            biomass(:,:,iroot,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'FRUIT_M', itime, &
+            biomass(:,:,ifruit,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'RESERVE_M', itime, &
+            biomass(:,:,icarbres,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'LABILE_M', itime, &
+            biomass(:,:,ilabile,icarbon), npts*nvm, horipft_index)
+        
+       CALL histwrite_p (hist_id_stomate, 'MAINT_RESP_LEAF', itime, &
+            resp_maint_part(:,:,ileaf), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'MAINT_RESP_SAP_AB', itime, &
+            resp_maint_part(:,:,isapabove), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'MAINT_RESP_SAP_BE', itime, &
+            resp_maint_part(:,:,isapbelow), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'MAINT_RESP_HEART_AB', itime, &
+            resp_maint_part(:,:,iheartabove), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'MAINT_RESP_HEART_BE', itime, &
+            resp_maint_part(:,:,iheartbelow), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'MAINT_RESP_FRUIT', itime, &
+            resp_maint_part(:,:,ifruit), npts*nvm, horipft_index)    
+
+       CALL histwrite_p (hist_id_stomate, 'MAINT_RESP_ROOT', itime, &
+            resp_maint_part(:,:,iroot), npts*nvm, horipft_index)
+
+
+
+       ! Total living biomass (gC m-2)
+       tot_live_biomass(:,:,:) = biomass(:,:,ileaf,:) + biomass(:,:,isapabove,:) &
+            + biomass(:,:,isapbelow,:) + &
+            biomass(:,:,iheartabove,:) + &
+            biomass(:,:,iheartbelow,:) + &
+            biomass(:,:,iroot,:) + &
+            biomass(:,:,ifruit,:) + biomass(:,:,icarbres,:)
+
+       ! Written in g C m-2
+       CALL histwrite_p (hist_id_stomate, 'TOTAL_M', itime, &
+            tot_live_biomass(:,:,icarbon), npts*nvm, horipft_index) 
+       CALL histwrite_p (hist_id_stomate, 'LEAF_TURN', itime, &
+            turnover_daily(:,:,ileaf,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'SAP_AB_TURN', itime, &
+            turnover_daily(:,:,isapabove,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'ROOT_TURN', itime, &
+            turnover_daily(:,:,iroot,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'FRUIT_TURN', itime, &
+            turnover_daily(:,:,ifruit,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'LEAF_BM_LITTER', itime, &
+            bm_to_litter(:,:,ileaf,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'SAP_AB_BM_LITTER', itime, &
+            bm_to_litter(:,:,isapabove,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'SAP_BE_BM_LITTER', itime, &
+            bm_to_litter(:,:,isapbelow,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'HEART_AB_BM_LITTER', itime, &
+            bm_to_litter(:,:,iheartabove,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'HEART_BE_BM_LITTER', itime, &
+            bm_to_litter(:,:,iheartbelow,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'ROOT_BM_LITTER', itime, &
+            bm_to_litter(:,:,iroot,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'FRUIT_BM_LITTER', itime, &
+            bm_to_litter(:,:,ifruit,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'RESERVE_BM_LITTER', itime, &
+            bm_to_litter(:,:,icarbres,icarbon), npts*nvm, horipft_index)
+       ! Use orphan flux so maint_resp is accounted for even if the PFT was removed
+       CALL histwrite_p (hist_id_stomate, 'MAINT_RESP', itime, &
+            orphan_flux(:,:,irmain,icarbon), npts*nvm, horipft_index)
+       ! Use orphan flux so growth_resp is accounted for even if the PFT was removed
+       CALL histwrite_p (hist_id_stomate, 'GROWTH_RESP', itime, &
+            orphan_flux(:,:,irgrow,icarbon), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'AGE', itime, &
+            age, npts*nvm, horipft_index)
+        CALL histwrite_p (hist_id_stomate, 'DIAMETER', itime, &
+            qm_dia, npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'HEIGHT', itime, &
+            qm_height, npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'MOISTRESS', itime, &
+            moiavail_week, npts*nvm, horipft_index)
+      ! added by yitong yao in Feb 24 2020 17:50 
+
+      CALL histwrite_p (hist_id_stomate, 'MOISTRESS_daily', itime, &
+            moiavail_daily, npts*nvm, horipft_index)
+
+      ! added by yitong yao in Feb 24 2020 17:51
+        CALL histwrite_p (hist_id_stomate, 'VCMAX', itime, &
+            vcmax, npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'TURNOVER_TIME_LEAF', itime, &
+            turnover_time(:,:,ileaf), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'TURNOVER_TIME_ROOT', itime, &
+            turnover_time(:,:,iroot), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'TURNOVER_TIME_SAP', itime, &
+            turnover_time(:,:,isapabove), npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'TURNOVER_TIME_FRUIT', itime, &
+            turnover_time(:,:,ifruit), npts*nvm, horipft_index) 
+
+       !! 16.2 Land cover and management change variables
+
+       CALL histwrite_p (hist_id_stomate, 'CFLUX_PROD_S', itime, &
+            cflux_prod_s, npts, hori_index)
+       CALL histwrite_p (hist_id_stomate, 'CFLUX_PROD_M', itime, &
+            cflux_prod_m, npts, hori_index)
+       CALL histwrite_p (hist_id_stomate, 'CFLUX_PROD_L', itime, &
+            cflux_prod_l, npts, hori_index)
+       CALL histwrite_p (hist_id_stomate, 'PROD_S', itime, &
+            prod_s, npts*(nshort+1), horip_ss_index)
+       CALL histwrite_p (hist_id_stomate, 'PROD_M', itime, &
+            prod_m, npts*(nmedium+1), horip_mm_index)
+       CALL histwrite_p (hist_id_stomate, 'PROD_L', itime, &
+            prod_l, npts*(nlong+1), horip_ll_index)
+       CALL histwrite_p (hist_id_stomate, 'FLUX_S', itime, &
+            flux_s, npts*nshort, horip_s_index)
+       CALL histwrite_p (hist_id_stomate, 'FLUX_M', itime, &
+            flux_m, npts*nmedium, horip_m_index)
+       CALL histwrite_p (hist_id_stomate, 'FLUX_L', itime, &
+            flux_l, npts*nlong, horip_l_index)
+       CALL histwrite_p (hist_id_stomate, 'BM_SYNC', itime, &
+            bm_sync(:,:,icarbon), npts*nvm, horipft_index) 
+
+       ! for functional allocation, we have all of this information
+       ! at every step so we can write it out.
+       var_real=REAL(age_stand)
+       CALL histwrite_p (hist_id_stomate, 'AGE_STAND', itime, &
+            var_real, npts*nvm, horipft_index) 
+       CALL histwrite_p (hist_id_stomate, 'MAI', itime, &
+            mai, npts*nvm, horipft_index) 
+       CALL histwrite_p (hist_id_stomate, 'PAI', itime, &
+            pai, npts*nvm, horipft_index) 
+       var_real=REAL(rotation_n)
+       CALL histwrite_p (hist_id_stomate, 'ROTATION_N', itime, &
+            var_real, npts*nvm, horipft_index)
+       var_real=REAL(last_cut)
+       CALL histwrite_p (hist_id_stomate, 'LAST_CUT', itime, &
+            var_real, npts*nvm, horipft_index)
+       var_real=REAL(forest_managed)
+       CALL histwrite_p (hist_id_stomate, 'FOREST_MANAGED', itime, &
+            var_real, npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'LITTER_RAKE_FRAC', itime, &
+            lrake_frac, npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'SIGMA', itime, &
+            sigma, npts*nvm, horipft_index)
+       CALL histwrite_p (hist_id_stomate, 'GAMMA', itime, &
+            gammas, npts*nvm, horipft_index)
+
+       ! These next ones are all commented out because the variable they
+       ! are writing no longer exists
+!       CALL histwrite_p (hist_id_stomate, 'EXPORTED_BM', itime, &
+!            exported_bm, npts*nvm, horipft_index)
+!       CALL histwrite_p (hist_id_stomate, 'LAI_MAX_LYEAR', itime, &
+!            lai_max_lastyear, npts*nvm, horipft_index) 
+!       lai_max_lastyear(:,:) = zero
+!       CALL histwrite_p (hist_id_stomate, 'STANDING_AB_BM', itime, &
+!            standing_ab_bm, npts*nvm, horipft_index) 
+!       CALL histwrite_p (hist_id_stomate, 'DELTAVOL', itime, &
+!            deltavol, npts*nvm, horipft_index) 
+!       CALL histwrite_p (hist_id_stomate, 'STANDING_AB_VOL', itime, &
+!            standing_ab_vol, npts*nvm, horipft_index)
+!       CALL histwrite_p (hist_id_stomate, 'HAR_VOL', itime, &
+!            harvestable_vol, npts*nvm, horipft_index)
+!       CALL histwrite_p (hist_id_stomate, 'HAR_VOL_INC', itime, &
+!            harvestable_vol_inc, npts*nvm, horipft_index)
+!       CALL histwrite_p (hist_id_stomate, 'EXPORTED_VOL', itime, &
+!            exported_vol, npts*nvm, horipft_index)
+!       CALL histwrite_p (hist_id_stomate, 'EXPORTED_VOL_TH', itime, &
+!            exported_vol_th, npts*nvm, horipft_index)
+!       CALL histwrite_p (hist_id_stomate, 'CIRC_MIN', itime, &
+!            circ_min, npts*nvm, horipft_index)
+!       CALL histwrite_p (hist_id_stomate, 'CIRC_MAX', itime, &
+!            circ_max, npts*nvm, horipft_index)
+       !             CALL histwrite_p (hist_id_stomate, 'RDI', itime, &
+       !                  rdi, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC02', itime, &
+!!$            circ_class_n(:,:,ic02), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC04', itime, &
+!!$            circ_class_n(:,:,ic04), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC06', itime, &
+!!$            circ_class_n(:,:,ic06), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC08', itime, &
+!!$            circ_class_n(:,:,ic08), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC10', itime, &
+!!$            circ_class_n(:,:,ic10), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC12', itime, &
+!!$            circ_class_n(:,:,ic12), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC14', itime, &
+!!$            circ_class_n(:,:,ic14), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC16', itime, &
+!!$            circ_class_n(:,:,ic16), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC18', itime, &
+!!$            circ_class_n(:,:,ic18), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC20', itime, &
+!!$            circ_class_n(:,:,ic20), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC222', itime, &
+!!$            circ_class_n(:,:,ic222), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CCPO', itime, &
+!!$            circ_class_n(:,:,icpo), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CCSW', itime, &
+!!$            circ_class_n(:,:,icsw), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CCMW', itime, &
+!!$            circ_class_n(:,:,icmw), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CCLW', itime, &
+!!$            circ_class_n(:,:,iclw), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC02_BT', itime, &
+!!$            circ_class_n_bt(:,:,ic02), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC04_BT', itime, &
+!!$            circ_class_n_bt(:,:,ic04), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC06_BT', itime, &
+!!$            circ_class_n_bt(:,:,ic06), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC08_BT', itime, &
+!!$            circ_class_n_bt(:,:,ic08), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC10_BT', itime, &
+!!$            circ_class_n_bt(:,:,ic10), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC12_BT', itime, &
+!!$            circ_class_n_bt(:,:,ic12), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC14_BT', itime, &
+!!$            circ_class_n_bt(:,:,ic14), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC16_BT', itime, &
+!!$            circ_class_n_bt(:,:,ic16), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC18_BT', itime, &
+!!$            circ_class_n_bt(:,:,ic18), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC20_BT', itime, &
+!!$            circ_class_n_bt(:,:,ic20), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CC222_BT', itime, &
+!!$            circ_class_n_bt(:,:,ic222), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CCPO_BT', itime, &
+!!$            circ_class_n_bt(:,:,icpo), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CCSW_BT', itime, &
+!!$            circ_class_n_bt(:,:,icsw), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CCMW_BT', itime, &
+!!$            circ_class_n_bt(:,:,icmw), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CCLW_BT', itime, &
+!!$            circ_class_n_bt(:,:,iclw), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'IND_BT', itime, &
+!!$            ind_bt, npts*nvm, horipft_index)
+       !++++++ end variables which no longer exist
+       !-----
+
+       !! 16.3 Calculated variables
+
+       ! Soil and litter carbon (gC m-2)
+       tot_soil_carb(:,:) = zero
+       tot_litter_carb(:,:) = zero
+       DO j=1,nvm
+
+          tot_litter_carb(:,j) = tot_litter_carb(:,j) + &
+               (litter(:,istructural,j,iabove,icarbon) + &
+               litter(:,imetabolic,j,iabove,icarbon) + &
+               litter(:,istructural,j,ibelow,icarbon) + &
+               litter(:,imetabolic,j,ibelow,icarbon) + &
+               litter(:,iwoody,j,iabove,icarbon) + &
+               litter(:,iwoody,j,ibelow,icarbon))
+          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(:,:)
+
+       CALL xios_orchidee_send_field("TOTAL_SOIL_CARB",tot_litter_soil_carb)
+       CALL xios_orchidee_send_field("cLitter",SUM(tot_litter_carb*veget_max,dim=2)/1e3*contfrac)
+       CALL xios_orchidee_send_field("cSoil",SUM(tot_soil_carb*veget_max,dim=2)/1e3*contfrac)
+
+!!$       CALL histwrite_p (hist_id_stomate, 'TOTAL_SOIL_CARB', itime, &
+!!$            tot_litter_soil_carb, npts*nvm, horipft_index)
+
+       ! Write output file for IPCC
+       IF ( hist_id_stomate_IPCC > 0 ) THEN
+
+          vartmp(:)=SUM(tot_litter_carb*veget_max,dim=2)/1e3*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "cLitter", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM(tot_soil_carb*veget_max,dim=2)/1e3*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "cSoil", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=(prod_s_total + prod_m_total + prod_l_total)/1e3
+          CALL histwrite_p (hist_id_stomate_IPCC, "cProduct", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM(lai*veget_max,dim=2)*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "lai", itime, &
+               vartmp, npts, hori_index)
+          ! Use orphan flux so gpp is accounted for even if the PFT was removed
+          vartmp(:)=SUM(orphan_flux(:,:,igpp,icarbon)*orphan_flux(:,:,ivegold,icarbon),dim=2)/&
+               1e3/one_day*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "gpp", itime, &
+               vartmp, npts, hori_index)
+          ! Use orphan fluxes so autotrophic respiration is accounted for even if the PFT was removed
+          vartmp(:)=SUM(orphan_flux(:,:,irgrow,icarbon)*orphan_flux(:,:,ivegold,icarbon),dim=2)/&
+               1e3/one_day*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "rGrowth", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM(orphan_flux(:,:,irmain,icarbon)*orphan_flux(:,:,ivegold,icarbon),dim=2)/&
+               1e3/one_day*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "rMaint", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM((orphan_flux(:,:,irmain,icarbon)+orphan_flux(:,:,irgrow,icarbon))*&
+               orphan_flux(:,:,ivegold,icarbon),dim=2)/1e3/one_day*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "ra", itime, &
+               vartmp, npts, hori_index)
+          ! Use orphan fluxes so npp is accounted for even if the PFT was removed
+          vartmp(:)=SUM(orphan_flux(:,:,inpp,icarbon)*orphan_flux(:,:,ivegold,icarbon),dim=2)/&
+               1e3/one_day*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "npp", itime, &
+               vartmp, npts, hori_index)
+          ! Use orphan fluxes so heterotrophic respiration is accounted for even if the PFT was removed
+          vartmp(:)=SUM(orphan_flux(:,:,irhet,icarbon)*orphan_flux(:,:,ivegold,icarbon),dim=2)/&
+               1e3/one_day*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "rh", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM(co2_fire*veget_max,dim=2)/1e3/one_day*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "fFire", itime, &
+               vartmp, npts, hori_index)
+        
+          vartmp(:)=SUM(SUM(soilcarbon_input,dim=2)*veget_max,dim=2)&
+               /1e3/one_day*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "fLitterSoil", itime, &
+               vartmp, npts, hori_index)
+          ! The biomass pools are updated during land cover change
+          vartmp(:)=SUM(biomass(:,:,ileaf,icarbon)*veget_max,dim=2)/1e3*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "cLeaf", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM((biomass(:,:,isapabove,icarbon)+&
+               biomass(:,:,iheartabove,icarbon))*veget_max,dim=2)/1e3*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "cWood", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM(( biomass(:,:,iroot,icarbon) + biomass(:,:,isapbelow,icarbon) &
+               + biomass(:,:,iheartbelow,icarbon) ) &
+               *veget_max,dim=2)/1e3*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "cRoot", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM(( biomass(:,:,icarbres,icarbon) + &
+               biomass(:,:,ifruit,icarbon))*veget_max,dim=2)/1e3*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "cMisc", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM((litter(:,istructural,:,iabove,icarbon)+&
+               litter(:,imetabolic,:,iabove,icarbon))*veget_max,dim=2)/1e3*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "cLitterAbove", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM((litter(:,istructural,:,ibelow,icarbon)+&
+               litter(:,imetabolic,:,ibelow,icarbon))*veget_max,dim=2)/1e3*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "cLitterBelow", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM(carbon(:,iactive,:)*veget_max,dim=2)/1e3*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "cSoilFast", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM(carbon(:,islow,:)*veget_max,dim=2)/1e3*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "cSoilMedium", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM(carbon(:,ipassive,:)*veget_max,dim=2)/1e3*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "cSoilSlow", itime, &
+               vartmp, npts, hori_index)
+          DO j=1,nvm
+             histvar(:,j)=veget_max(:,j)*contfrac(:)*100
+          ENDDO
+          CALL histwrite_p (hist_id_stomate_IPCC, "landCoverFrac", itime, &
+               histvar, npts*nvm, horipft_index)
+          vartmp(:)=zero
+          DO j = 2,nvm
+             IF (is_deciduous(j)) THEN
+                vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100
+             ENDIF
+          ENDDO
+          CALL histwrite_p (hist_id_stomate_IPCC, "treeFracPrimDec", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=zero
+          DO j = 2,nvm
+             IF (is_evergreen(j)) THEN
+                vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100
+             ENDIF
+          ENDDO
+          CALL histwrite_p (hist_id_stomate_IPCC, "treeFracPrimEver", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=zero
+          DO j = 2,nvm
+             IF ( .NOT.(is_c4(j)) ) THEN
+                vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100
+             ENDIF
+          ENDDO
+          CALL histwrite_p (hist_id_stomate_IPCC, "c3PftFrac", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=zero
+          DO j = 2,nvm
+             IF ( is_c4(j) ) THEN
+                vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100
+             ENDIF
+          ENDDO
+          CALL histwrite_p (hist_id_stomate_IPCC, "c4PftFrac", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM(bm_alloc(:,:,ileaf,icarbon)*veget_max,dim=2)/1e3/one_day*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "nppLeaf", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM(bm_alloc(:,:,isapabove,icarbon)*veget_max,dim=2)/1e3/one_day*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "nppWood", itime, &
+               vartmp, npts, hori_index)
+          vartmp(:)=SUM(( bm_alloc(:,:,isapbelow,icarbon) + bm_alloc(:,:,iroot,icarbon) )*veget_max,dim=2)/&
+               1e3/one_day*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "nppRoot", itime, &
+               vartmp, npts, hori_index)
+          CALL histwrite_p (hist_id_stomate_IPCC, 'RESOLUTION_X', itime, &
+               resolution(:,1), npts, hori_index)
+          CALL histwrite_p (hist_id_stomate_IPCC, 'RESOLUTION_Y', itime, &
+               resolution(:,2), npts, hori_index)
+          CALL histwrite_p (hist_id_stomate_IPCC, 'CONTFRAC', itime, &
+               contfrac(:), npts, hori_index)
+
+          ! Total living biomass (gC m-2)
+          tot_live_biomass(:,:,:) = biomass(:,:,ileaf,:) + biomass(:,:,isapabove,:) &
+               + biomass(:,:,isapbelow,:) + &
+               biomass(:,:,iheartabove,:) + &
+               biomass(:,:,iheartbelow,:) + &
+               biomass(:,:,iroot,:) + &
+               biomass(:,:,ifruit,:) + biomass(:,:,icarbres,:)
+
+          CALL xios_orchidee_send_field("TOTAL_M",tot_live_biomass)
+          CALL xios_orchidee_send_field("cVeg",SUM(tot_live_biomass(:,:,icarbon)*veget_max,dim=2)/1e3*contfrac)
+
+          ! Written in kg C m-2, note the division by 1000 and multiplication by veget_max 
+          vartmp(:)=SUM(tot_live_biomass(:,:,icarbon)*veget_max,dim=2)/1e3*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "cVeg", itime, &
+               vartmp, npts, hori_index)
+
+!tzj          ! Written in g C m-2
+!          CALL histwrite_p (hist_id_stomate, 'TOTAL_M', itime, &
+!               tot_live_biomass(:,:,icarbon), npts*nvm, horipft_index) 
+
+          ! Ratio of above and belowground woody biomass (shoot_ratio)
+          shoot_ratio(:,:) = zero
+          WHERE ( (biomass(:,:,isapabove,icarbon) + biomass(:,:,iheartabove,icarbon) & 
+               + biomass(:,:,isapbelow,icarbon) + biomass(:,:,iheartbelow,icarbon)) > min_stomate )
+
+             shoot_ratio(:,:) = (biomass(:,:,isapabove,icarbon) + &
+                  biomass(:,:,iheartabove,icarbon))/ &
+                  (biomass(:,:,isapabove,icarbon) + biomass(:,:,iheartabove,icarbon) + &
+                  biomass(:,:,isapbelow,icarbon) + biomass(:,:,iheartbelow,icarbon))
+
+          END WHERE
+
+          ! Aboveground woody biomass (gC m-2)
+          woody_biomass_above(:,:) = biomass(:,:,isapabove,icarbon) + &
+               biomass(:,:,iheartabove,icarbon) + &
+               (biomass(:,:,icarbres,icarbon) + biomass(:,:,ilabile,icarbon)) * &
+               shoot_ratio(:,:)
+
+          ! Belowground woody biomass (gC m-2)
+          woody_biomass_below(:,:) = biomass(:,:,isapbelow,icarbon) + &
+               biomass(:,:,iheartbelow,icarbon) + &
+               (biomass(:,:,icarbres,icarbon) + biomass(:,:,ilabile,icarbon)) * &
+               (1. - shoot_ratio(:,:))
+
+          WHERE (.NOT. PFTpresent(:,:))
+             woody_biomass_above(:,:) = zero
+             woody_biomass_below(:,:) = zero
+          ENDWHERE
+
+          !+++CHECK+++
+          ! The trunk version of code calculates a series of derived fluxes i.e.
+          ! ::wood_loss_ab, wood_loss_be(:,:), ::fHarvest, ::nbp
+          ! Several of these fluxes make use of ::exported_bm (gC m-2). In this branch
+          ! ::exported_bm was replaced by ::harvest_pool (gC). The change in variable
+          ! came with a change in units. Calculating the harvest biomass in gC m-2
+          ! requires adding a new dimension to this variable. Given that the variable
+          ! already has six dimension (to store the activity to lead to the harvesting)
+          ! it was decided not to add surface area unless really needed. Consequently 
+          ! the aforementioned variables can not be calculated for the moment. Rather
+          ! than having a wrong calculation in the code it was decided to delete these 
+          ! variables. The way they have to be calculated can be found in previous 
+          ! versions (r1630 and before) of this branch. Please note that ::exported_bm
+          ! will have to be replaced by ::harvest_pool and that the units of 
+          ! ::harvest_pool will need to be converted first.
+          
+          ! Total turnover (gC m-2 dt_slow-1)
+          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,:) + &
+               turnover_daily(:,:,ilabile,:)
+          CALL xios_orchidee_send_field("TOTAL_TURN",tot_turnover)
+          CALL histwrite_p (hist_id_stomate, 'TOTAL_TURN', itime, &
+               tot_turnover(:,:,icarbon), npts*nvm, horipft_index)
+
+          ! Total biomass to litter (gC m-2 dt_slow-1)
+          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,:)
+
+          CALL xios_orchidee_send_field("TOTAL_BM_LITTER",tot_bm_to_litter(:,:,icarbon))
+          CALL xios_orchidee_send_field("fVegLitter",SUM((tot_bm_to_litter(:,:,icarbon) + tot_turnover(:,:,icarbon))*&
+               veget_max,dim=2)/1e3/one_day*contfrac)
+
+          ! Written gC m-2 dt_slow-1
+          CALL histwrite_p (hist_id_stomate, 'TOTAL_BM_LITTER', itime, &
+               tot_bm_to_litter(:,:,icarbon), npts*nvm, horipft_index)
+
+          ! Written in kg C m-2 s-1, note the division by 1000 and one day
+          ! and multiplication by veget_max 
+          vartmp(:)=SUM((tot_bm_to_litter(:,:,icarbon) + &
+               tot_turnover(:,:,icarbon))*veget_max,dim=2)/1e3/one_day*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "fVegLitter", itime, &
+               vartmp, npts, hori_index)
+
+          ! Total carbon mass kgC m-2 s-1, note the division by 1000 and one day
+          ! and the multiplication with veget_max
+          carb_mass_variation(:)=-carb_mass_total(:)
+          carb_mass_total(:)=SUM((tot_live_biomass(:,:,icarbon)+tot_litter_carb+&
+               tot_soil_carb)*veget_max,dim=2) + &
+               (prod_s_total + prod_m_total + prod_l_total)
+          carb_mass_variation(:)=carb_mass_total(:)+carb_mass_variation(:)
+          CALL xios_orchidee_send_field("cMassVariation",carb_mass_variation/1e3/one_day*contfrac)
+          vartmp(:)=carb_mass_variation/1e3/one_day*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "cMassVariation", itime, &
+               vartmp, npts, hori_index)
+       
+          vartmp(:)=cflux_prod_total/1e3/one_day*contfrac
+          CALL histwrite_p (hist_id_stomate_IPCC, "fLuc", itime, &
+               vartmp, npts, hori_index)
+          !+++++++++++
+          
+       ENDIF
+
+    ELSE
+
+       ! This is the old version of Stomate_lpj, starting from when Didier created
+       ! the branch and then updated a little when a few routines merged. While
+       ! developing we tried to keep this working but at one point too many changes
+       ! were introduced. There shouldn't be any big conflicts it would probably take
+       ! a couple of days before this is working again. This version uses the
+       ! resource based allocation and the DGVM should still work. However, there is 
+       ! NO functional allocation, NO new albedo, NO forestry, NO age classes, 
+       ! NO hydraulic architecture, NO multilayer energy-budget, NO analytic 
+       ! photosynthese, NO mass balance closure (not guaranteed) and NO improved 
+       ! consistency for veget_max, lai, height, ... Why would you want to use that?
+
+!!$    !+++CHECK++
+!!$    Declare this variables in the variable list when old forestry needs to be re-animated
+!!$    Note that some variables may be missing but it is a good start
+!!$    ! Old forestry parameters
+!!$    REAL(r_std), DIMENSION(npts,nvm)                 :: av_circ                 !! Average circumference of trees in the stand (m)
+!!$    REAL(r_std), DIMENSION(npts,nvm)                 :: standing_ab_bm          !! Standing aboveground biomass (gC/m2)
+!!$    REAL(r_std), DIMENSION(npts,nvm)                 :: deltavol                !! Annual aboveground volume increment 
+!!$                                                                                !! (m3/ha/yr)
+!!$    REAL(r_std), DIMENSION(npts,nvm)                 :: standing_ab_vol         !! Standing aboveground volume (m3/ha)
+!!$    REAL(r_std), DIMENSION(npts,nvm)                 :: exported_bm             !! Biomass exported (gC/m2)
+!!$    REAL(r_std), DIMENSION(npts,nvm)                 :: exported_vol            !! Volume exported (m3/m2) -- this year
+!!$    REAL(r_std), DIMENSION(npts,nvm)                 :: exported_vol_th         !! Volume exported for thinnings 
+!!$                                                                                !! (clear-cuts not included) (m3/m2) 
+!!$                                                                                !! -- this year
+!!$    REAL(r_std), DIMENSION(npts,nvm,ncirc)           :: circ_class_n_bt         !! Number of trees in each circumference 
+!!$                                                                                !! class (0-2.2+ and poles-large wood)
+!!$                                                                                !! (bt for before thinning)
+!!$    REAL(r_std), DIMENSION(npts,nvm)                 :: circ_lim                !! Limit circumference (m, trees larger than 
+!!$                                                                                !! circ_lim are not affected by thinnings)
+!!$    REAL(r_std), DIMENSION(npts,nvm)                 :: circ_min                !! Smallest circumference (m)
+!!$    REAL(r_std), DIMENSION(npts,nvm)                 :: circ_max                !! Largest circumference (m)
+!!$    REAL(r_std), DIMENSION(npts,nvm)                 :: harvestable_vol         !! Harvestable volume (diameter > 0.175 m
+!!$                                                                                !! without branches) (m3/ha)
+!!$    REAL(r_std), DIMENSION(npts,nvm)                 :: harvestable_vol_inc     !! Yearly increment in harvestable volume 
+!!$                                                                                !! (diameter > 0.175 m without branches) 
+!!$                                                                                !! (m3/ha/yr)
+!!$    REAL(r_std), DIMENSION(npts,nvm)                 :: ind_bt                  !! Density of individuals before thinning 
+!!$                                                                                !! @tex $(m^{-2})$ @endtex of nat/agri 
+!!$                                                                                !! ground
+!!$    !+++++++++ 
+
+!!$       !! 1. Initializations
+!!$
+!!$       !! 1.1 Initialize variables to zero
+!!$       co2_to_bm(:,:) = zero
+!!$       co2_fire(:,:) = zero
+!!$       npp_daily(:,:) = zero
+!!$       resp_maint(:,:) = zero
+!!$       resp_growth(:,:) = zero
+!!$       bm_to_litter(:,:,:,:) = zero
+!!$       cn_ind(:,:) = zero
+!!$       woodmass_ind(:,:) = zero
+!!$       turnover_daily(:,:,:,:) = zero
+!!$
+!!$       !! 1.2  Initialize variables to veget_max
+!!$       veget_max_old(:,:) = veget_max(:,:)
+!!$
+!!$       ! 1.25 Correct management status if waiting for clearcut (management only changes after a clearcut, except if it's to
+!!$       ! become unmanaged)
+!!$       IF ( control%forest_management ) THEN
+!!$
+!!$          DO j = 2,nvm
+!!$             DO i = 1,npts
+!!$                IF ( (forest_managed(i,j) /= forest_managed_lastyear(i,j)) .AND. (forest_managed_lastyear(i,j) > 0) .AND. &
+!!$                     & (forest_managed(i,j) > 0) .AND.(age_stand(i,j) > 1) ) THEN
+!!$                   forest_managed(i,j) = forest_managed_lastyear(i,j)
+!!$                ENDIF
+!!$             ENDDO
+!!$          ENDDO
+!!$          IF (EndOfYear) forest_managed_lastyear(:,:) = forest_managed(:,:)
+!!$
+!!$       END IF ! control%forest_management
+!!$
+!!$       !! 1.3 Calculate some vegetation characteristics
+!!$
+!!$       !! 1.3.1 Calculate some vegetation characteristics 
+!!$       !        Calculate cn_ind (individual crown mass) and individual height from
+!!$       !        state variables if running DGVM or dynamic mortality in static cover mode
+!!$       !??        Explain (maybe in the header once) why you mulitply with veget_max in the DGVM
+!!$       !??        and why you don't multiply with veget_max in stomate.
+!!$       IF ( control%ok_dgvm .OR. .NOT.control%ok_constant_mortality) THEN
+!!$          IF(control%ok_dgvm) THEN
+!!$             WHERE (ind(:,:).GT.min_stomate)
+!!$                woodmass_ind(:,:) = &
+!!$                     ((biomass(:,:,isapabove,icarbon)+biomass(:,:,isapbelow,icarbon) &
+!!$                     +biomass(:,:,iheartabove,icarbon)+biomass(:,:,iheartbelow,icarbon)) & 
+!!$                     *veget_max(:,:))/ind(:,:)
+!!$             ENDWHERE
+!!$          ELSE
+!!$             WHERE (ind(:,:).GT.min_stomate)
+!!$                woodmass_ind(:,:) = &
+!!$                     (biomass(:,:,isapabove,icarbon)+biomass(:,:,isapbelow,icarbon) &
+!!$                     +biomass(:,:,iheartabove,icarbon)+biomass(:,:,iheartbelow,icarbon))/ind(:,:)
+!!$             ENDWHERE
+!!$          ENDIF
+!!$
+!!$          CALL crown_diagnostic (npts,  PFTpresent, &
+!!$               ind, biomass, woodmass_ind, &
+!!$               veget_max, cn_ind, height, &
+!!$               forest_managed)
+!!$       ENDIF
+!!$
+!!$       !! 1.3.2 Prescribe 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 the first call, if the DGVM is not activated, 
+!!$       !        impose a minimum biomass for prescribed PFTs and declare them present.
+!!$       CALL prescribe_diagnostic (npts, &
+!!$            veget_max, dt_days, PFTpresent, everywhere, when_growthinit, &
+!!$            biomass, leaf_frac, ind, cn_ind, co2_to_bm)
+!!$
+!!$
+!!$       !! 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. Determine introduction and elimination of PTS based on climate criteria
+!!$
+!!$       IF ( control%ok_dgvm ) THEN
+!!$
+!!$          !! 3.1 Calculate introduction and elimination
+!!$          CALL pftinout (npts, dt_days, adapted, regenerate, &
+!!$               neighbours, veget_max, &
+!!$               biomass, ind, cn_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_diagnostic (npts, 'pftinout  ', lm_lastyearmax, &
+!!$               ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
+!!$               age, leaf_age, leaf_frac, npp_longterm, &
+!!$               when_growthinit, everywhere, veget_max, bm_to_litter)
+!!$
+!!$
+!!$          !! 3.3 Calculate new crown area and diameter 
+!!$          !      Calculate new crown area, diameter and maximum vegetation cover**[No longer used in the subroutine]
+!!$          !      unsure whether this is really required
+!!$          !      - in theory this could ONLY be done at the END of stomate_lpj
+!!$          !      calculate woodmass of individual tree
+!!$          WHERE ((ind(:,:).GT.min_stomate))
+!!$             WHERE  ( veget_max(:,:) .GT. min_stomate)
+!!$                woodmass_ind(:,:) = &
+!!$                     ((biomass(:,:,isapabove,icarbon) + biomass(:,:,isapbelow,icarbon) &
+!!$                     + biomass(:,:,iheartabove,icarbon) + biomass(:,:,iheartbelow,icarbon))*veget_max(:,:))/ind(:,:)
+!!$             ELSEWHERE
+!!$                woodmass_ind(:,:) =(biomass(:,:,isapabove,icarbon) + biomass(:,:,isapbelow,icarbon) &
+!!$                     + biomass(:,:,iheartabove,icarbon) + biomass(:,:,iheartbelow,icarbon))/ind(:,:)
+!!$             ENDWHERE
+!!$
+!!$          ENDWHERE
+!!$
+!!$          ! Calculate crown area and diameter for all PFTs (including the newly established)
+!!$          CALL crown_diagnostic (npts, PFTpresent, &
+!!$               ind, biomass, woodmass_ind, &
+!!$               veget_max, cn_ind, height, &
+!!$               forest_managed)
+!!$
+!!$       ENDIF
+!!$
+!!$       !! 4. Phenology
+!!$
+!!$       !! 4.1 Write values to history file
+!!$       !      Current values for ::when_growthinit 
+!!$       CALL histwrite_p (hist_id_stomate, 'WHEN_GROWTHINIT', itime, when_growthinit, npts*nvm, horipft_index)
+!!$
+!!$       ! Set and write values for ::PFTpresent
+!!$       WHERE(PFTpresent)
+!!$          histvar=un
+!!$       ELSEWHERE
+!!$          histvar=zero
+!!$       ENDWHERE
+!!$       CALL histwrite_p (hist_id_stomate, 'PFTPRESENT', itime, histvar, npts*nvm, horipft_index)
+!!$
+!!$       ! Set and write values for gdd_midwinter
+!!$       WHERE(gdd_midwinter.EQ.undef)
+!!$          histvar=val_exp
+!!$       ELSEWHERE
+!!$          histvar=gdd_midwinter
+!!$       ENDWHERE
+!!$       CALL histwrite_p (hist_id_stomate, 'GDD_MIDWINTER', itime, histvar, npts*nvm, horipft_index)
+!!$
+!!$       ! Set and write values for gdd_m5_dormance
+!!$       WHERE(gdd_m5_dormance.EQ.undef)
+!!$          histvar=val_exp
+!!$       ELSEWHERE
+!!$          histvar=gdd_m5_dormance
+!!$       ENDWHERE
+!!$       CALL histwrite (hist_id_stomate, 'GDD_M5_DORMANCE', itime, histvar, npts*nvm, horipft_index)
+!!$
+!!$       ! Set and write values for ncd_dormance
+!!$       WHERE(ncd_dormance.EQ.undef)
+!!$          histvar=val_exp
+!!$       ELSEWHERE
+!!$          histvar=ncd_dormance
+!!$       ENDWHERE
+!!$       CALL histwrite_p (hist_id_stomate, 'NCD_DORMANCE', itime, histvar, npts*nvm, horipft_index)
+!!$
+!!$       !! 4.2 Calculate phenology
+!!$       CALL phenology_diagnostic (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_hum_min, &
+!!$            biomass, leaf_frac, leaf_age, &
+!!$            when_growthinit, co2_to_bm)
+!!$
+!!$       !! 5. Allocate C to different plant parts
+!!$       CALL growth_res_lim (npts, dt_days, lai, veget_max, & 
+!!$            PFTpresent, senescence, when_growthinit, moiavail_week, & 
+!!$            soilhum_month, tsoil_month, gpp_daily, resp_maint_part, & 
+!!$            resp_maint, resp_growth, npp_daily, biomass, & 
+!!$            age, leaf_age, leaf_frac)
+!!$
+!!$!       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, &
+!!$!            lai_max_calc, forest_managed, age_stand, last_cut)
+!!$
+!!$       !! 6. NPP, maintenance and growth respiration
+!!$
+!!$       !! 6.1 Calculate NPP and respiration terms
+!!$!       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%forest_management ) THEN
+!!$
+!!$          ! We have made extensive changes to the flow of the forestry
+!!$          ! module.  As the version of the forestry module in this
+!!$          ! branch had never been tested anyway, it doesn't make
+!!$          ! sense to maintain any backwards compatibility.  If one
+!!$          ! wants to do forestry, the new allocation scheme already
+!!$          ! has circumference classes, so the old way of creating
+!!$          ! circumference classes from a big leaf canopy does not
+!!$          ! make any sense.  In addition, forestry should introduce
+!!$          ! gaps into the canopy, but the old albedo scheme could not
+!!$          ! handle gaps.  So its better to use the new allocation scheme.
+!!$
+!!$           CALL ipslerr(3,stomate_lpj',&
+!!$               'Cannot run forestry with the old allocation.','','')
+!!$!          CALL forestry (npts, biomass, lai, &
+!!$!               ind, circ, EndOfYear, & 
+!!$!               lai_max_calc, circ_class, bm_to_litter, &
+!!$!               biomass_lastyear, lai_max_lastyear, when_growthinit, leaf_frac, &
+!!$!               veget_max, sigma, gamma, age_stand, &
+!!$!               rotation_n, last_cut, av_circ, ba, &
+!!$!               dom_height, av_height, &
+!!$!               med_height, q1_height, q3_height, &
+!!$!               standing_ab_bm, deltavol, standing_ab_vol, & 
+!!$!               harvestable_vol, harvestable_vol_inc, exported_bm, &
+!!$!               exported_vol, exported_vol_th, & 
+!!$!               circ_lim, circ_min, circ_max, circ_class_n, circ_class_n_bt, &
+!!$!               forest_managed, ind_bt, rdi)
+!!$
+!!$       END IF ! control%forest_management
+!!$
+!!$       !! 6.2 Kill slow growing PFTs in DGVM or STOMATE with constant mortality
+!!$       IF ( control%ok_dgvm .OR. .NOT.control%ok_constant_mortality) THEN
+!!$          CALL kill_diagnostic (npts, 'npp       ', lm_lastyearmax,  &
+!!$               ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
+!!$               age, leaf_age, leaf_frac, npp_longterm, &
+!!$               when_growthinit, everywhere, veget_max, bm_to_litter)
+!!$
+!!$          !! 6.2.1 Update wood biomass      
+!!$          !        For the DGVM
+!!$          IF(control%ok_dgvm) THEN
+!!$             WHERE (ind(:,:).GT.min_stomate)
+!!$                woodmass_ind(:,:) = &
+!!$                     ((biomass(:,:,isapabove,icarbon) + biomass(:,:,isapbelow,icarbon) &
+!!$                     + biomass(:,:,iheartabove,icarbon) + biomass(:,:,iheartbelow,icarbon)) & 
+!!$                     *veget_max(:,:))/ind(:,:)
+!!$             ENDWHERE
+!!$
+!!$             ! For all pixels with individuals
+!!$          ELSE
+!!$             WHERE (ind(:,:).GT.min_stomate)
+!!$                woodmass_ind(:,:) = &
+!!$                     (biomass(:,:,isapabove,icarbon) + biomass(:,:,isapbelow,icarbon) &
+!!$                     + biomass(:,:,iheartabove,icarbon) + biomass(:,:,iheartbelow,icarbon))/ind(:,:)
+!!$             ENDWHERE
+!!$          ENDIF ! control%ok_dgvm
+!!$
+!!$          !! 6.2.2 New crown area and maximum vegetation cover after growth
+!!$          CALL crown_diagnostic (npts, PFTpresent, &
+!!$               ind, biomass, woodmass_ind,&
+!!$               veget_max, cn_ind, height, &
+!!$               forest_managed)
+!!$
+!!$       ENDIF ! control%ok_dgvm
+!!$
+!!$       !! 7. fire
+!!$
+!!$       !! 7.1. Burn PFTs
+!!$       CALL fire (npts, dt_days, litterpart, &
+!!$            litterhum_daily, t2m_daily, lignin_struc, lignin_wood, veget_max, &
+!!$            fireindex, firelitter, biomass, ind, &
+!!$            litter, dead_leaves, bm_to_litter, black_carbon, &
+!!$            co2_fire, MatrixA)
+!!$
+!!$       !! 7.2 Kill PFTs in DGVM
+!!$       IF ( control%ok_dgvm ) THEN
+!!$
+!!$          ! reset attributes for eliminated PFTs
+!!$          CALL kill_diagnostic (npts, 'fire      ', lm_lastyearmax, &
+!!$               ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
+!!$               age, leaf_age, leaf_frac, npp_longterm, &
+!!$               when_growthinit, everywhere, veget_max, bm_to_litter)
+!!$
+!!$       ENDIF ! control%ok_dgvm
+!!$
+!!$       !! 8. Tree mortality
+!!$
+!!$       ! Does not depend on age, therefore does not change crown area.
+!!$       CALL gap_diagnostic (npts, dt_days, &
+!!$            npp_longterm, turnover_longterm, lm_lastyearmax, &
+!!$            PFTpresent, biomass, ind, bm_to_litter, mortality , &
+!!$            forest_managed)
+!!$
+!!$       IF ( control%ok_dgvm ) THEN
+!!$
+!!$          ! reset attributes for eliminated PFTs
+!!$          CALL kill_diagnostic (npts, 'gap       ', lm_lastyearmax, &
+!!$               ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
+!!$               age, leaf_age, leaf_frac, npp_longterm, &
+!!$               when_growthinit, everywhere, veget_max, bm_to_litter)
+!!$
+!!$       ENDIF
+!!$
+!!$       !! 9. Calculate vcmax and photosynthesis temperatures
+!!$
+!!$       CALL vmax_diagnostic (npts, dt_days, &
+!!$            leaf_age, leaf_frac, &
+!!$            forest_managed, age_stand, &
+!!$            vcmax)
+!!$
+!!$       CALL assim_temp (npts, tlong_ref, t2m_month, &
+!!$            t_photo_min, t_photo_opt, t_photo_max)
+!!$
+!!$       !! 10. Leaf senescence, new lai and other turnover processes
+!!$
+!!$       CALL turnover_diagnostic (npts, dt_days, PFTpresent, &
+!!$            herbivores, &
+!!$            maxmoiavail_lastyear, minmoiavail_lastyear, &
+!!$            moiavail_week,  moiavail_month,tlong_ref, t2m_month, t2m_week, veget_max, &
+!!$            gdd_from_growthinit, leaf_age, leaf_frac, age, lai, biomass, &
+!!$            turnover_daily, senescence, turnover_time, &
+!!$            forest_managed)
+!!$
+!!$       !! 11. Light competition
+!!$
+!!$       !! If not using constant mortality then kill with light competition
+!!$       !    IF ( control%ok_dgvm .OR. .NOT.(control%ok_constant_mortality) ) THEN
+!!$       IF ( control%ok_dgvm ) THEN
+!!$
+!!$          !! 11.1 Light competition
+!!$          CALL light (npts, dt_days, &
+!!$               veget_max, fpc_max, PFTpresent, cn_ind, lai, maxfpc_lastyear, &
+!!$               lm_lastyearmax, ind, biomass, veget_lastlight, bm_to_litter, mortality)
+!!$
+!!$          !! 11.2 Reset attributes for eliminated PFTs
+!!$          CALL kill_diagnostic (npts, 'light     ', lm_lastyearmax, &
+!!$               ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
+!!$               age, leaf_age, leaf_frac, npp_longterm, &
+!!$               when_growthinit, everywhere, veget_max, bm_to_litter)
+!!$
+!!$       ENDIF
+!!$
+!!$
+!!$       !! 12. Establishment of saplings
+!!$
+!!$       IF ( control%ok_dgvm .OR. .NOT.control%ok_constant_mortality ) THEN
+!!$
+!!$          !! 12.1 Establish new plants
+!!$          CALL establish_diagnostic (npts, dt_days, PFTpresent, regenerate, &
+!!$               neighbours, resolution, need_adjacent, herbivores, &
+!!$               precip_lastyear, gdd0_lastyear, lm_lastyearmax, &
+!!$               cn_ind, lai, avail_tree, avail_grass, npp_longterm, &
+!!$               leaf_age, leaf_frac, &
+!!$               ind, biomass, age, everywhere, co2_to_bm, veget_max, woodmass_ind)
+!!$
+!!$          !! 12.2 Calculate new crown area (and maximum vegetation cover)
+!!$          CALL crown_diagnostic (npts, PFTpresent, &
+!!$               ind, biomass, woodmass_ind, &
+!!$               veget_max, cn_ind, height, &
+!!$               forest_managed)
+!!$
+!!$       ENDIF
+!!$
+!!$       !! 13. Calculate final LAI and vegetation cover
+!!$
+!!$       CALL cover (npts, cn_ind, ind, biomass, &
+!!$            veget_max, veget_max_old, lai, &
+!!$            litter, carbon, turnover_daily, bm_to_litter, &
+!!$            lignin_struc, lignin_wood)
+!!$
+!!$       !! 14. Update litter pools to account for harvest
+!!$
+!!$       ! 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.\n
+!!$       ! added by shilong for harvest
+!!$       IF (control%ok_agricultural_harvest) THEN
+!!$          CALL crop_harvest(npts, dt_days, veget_max, turnover_daily, &
+!!$               harvest_pool, resolution)
+!!$       ENDIF
+!!$
+!!$       !! 15. Land cover change
+!!$
+!!$       !shilong adde turnover_daily
+!!$       IF(EndOfYear) THEN
+!!$          IF (control%ok_land_cover_change) THEN
+!!$             CALL lcchange_main (npts, dt_days, veget_max, veget_max_new, &
+!!$                  biomass, ind, age, PFTpresent, senescence, when_growthinit, everywhere, &
+!!$                  co2_to_bm, bm_to_litter, turnover_daily, cn_ind,flux_m,flux_l, &
+!!$!               prod10,prod100,prod10_total,prod100_total,&
+!!$!               convflux,cflux_prod_total,cflux_prod10,cflux_prod100,leaf_frac,&
+!!$                  prod_m,prod_l,cflux_prod_s,cflux_prod_m,cflux_prod_l,leaf_frac,&
+!!$                  npp_longterm, lm_lastyearmax, litter, carbon , &
+!!$                  lignin_struc, lignin_wood)
+!!$          ENDIF
+!!$       ENDIF
+!!$       !MM dÃ©placement pour initialisation correcte des grandeurs cumulÃ©es :
+!!$       cflux_prod_total(:) = cflux_prod_s(:) + cflux_prod_m(:) + cflux_prod_l(:)
+!!$       prod_m_total(:) = SUM(prod_m(:,:),dim=2)
+!!$       prod_l_total(:) = SUM(prod_l(:,:),dim=2)
+!!$       !SL Added so the new and old LCC/product use approach both work
+!!$       prod_s_total(:) = zero
+!!$
+!!$       !! 16. Total heterotrophic respiration
+!!$
+!!$       tot_soil_carb(:,:) = zero
+!!$       tot_litter_carb(:,:) = zero
+!!$       DO j=1,nvm
+!!$
+!!$          tot_litter_carb(:,j) = tot_litter_carb(:,j) + (litter(:,istructural,j,iabove,icarbon) + &
+!!$               &          litter(:,imetabolic,j,iabove,icarbon) + &
+!!$               &          litter(:,istructural,j,ibelow,icarbon) + litter(:,imetabolic,j,ibelow,icarbon) + &
+!!$               &          litter(:,iwoody,j,iabove,icarbon) + litter(:,iwoody,j,ibelow,icarbon))
+!!$
+!!$          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(:,:)
+!!$
+!!$!     DO k = 1, nelements ! Loop over # elements
+!!$!        tot_live_biomass(:,:,k) = biomass(:,:,ileaf,k) + biomass(:,:,isapabove,k) + biomass(:,:,isapbelow,k) +&
+!!$!             &                    biomass(:,:,iheartabove,k) + biomass(:,:,iheartbelow,k) + &
+!!$!             &                    biomass(:,:,iroot,k) + biomass(:,:,ifruit,k) + biomass(:,:,icarbres,k)
+!!$!    END DO ! Loop over # elements
+!!$
+!!$       tot_live_biomass(:,:,:) = biomass(:,:,ileaf,:) + biomass(:,:,isapabove,:) + biomass(:,:,isapbelow,:) +&
+!!$            &                    biomass(:,:,iheartabove,:) + biomass(:,:,iheartbelow,:) + &
+!!$            &                    biomass(:,:,iroot,:) + biomass(:,:,ifruit,:) + biomass(:,:,icarbres,:)
+!!$
+!!$       shoot_ratio(:,:) = zero
+!!$       WHERE ( (biomass(:,:,isapabove,icarbon) + biomass(:,:,iheartabove,icarbon) & 
+!!$            + biomass(:,:,isapbelow,icarbon) + biomass(:,:,iheartbelow,icarbon)) > min_stomate )
+!!$
+!!$          shoot_ratio(:,:) = (biomass(:,:,isapabove,icarbon) + biomass(:,:,iheartabove,icarbon))/ &
+!!$               & (biomass(:,:,isapabove,icarbon) + biomass(:,:,iheartabove,icarbon) + &
+!!$               &  biomass(:,:,isapbelow,icarbon) + biomass(:,:,iheartbelow,icarbon))
+!!$
+!!$       END WHERE
+!!$
+!!$       woody_biomass_above(:,:) = biomass(:,:,isapabove,icarbon) + biomass(:,:,iheartabove,icarbon) & 
+!!$            + biomass(:,:,icarbres,icarbon)* shoot_ratio(:,:)
+!!$
+!!$       woody_biomass_below(:,:) = biomass(:,:,isapbelow,icarbon) + biomass(:,:,iheartbelow,icarbon) &
+!!$            + biomass(:,:,icarbres,icarbon)* (1. - shoot_ratio(:,:))
+!!$
+!!$       wood_loss_ab(:,:) = exported_bm(:,:) + bm_to_litter(:,:,isapabove,icarbon) & 
+!!$            & + bm_to_litter(:,:,iheartabove,icarbon) + &
+!!$            & bm_to_litter(:,:,icarbres,icarbon)*shoot_ratio(:,:) + &
+!!$            & turnover_daily(:,:,isapabove,icarbon) + turnover_daily(:,:,iheartabove,icarbon) + &
+!!$            & turnover_daily(:,:,icarbres,icarbon) * shoot_ratio(:,:)
+!!$
+!!$       wood_loss_be(:,:) = bm_to_litter(:,:,isapbelow,icarbon) + bm_to_litter(:,:,iheartbelow,icarbon) & 
+!!$            & + bm_to_litter(:,:,icarbres,icarbon) * (1. - shoot_ratio(:,:)) &
+!!$            & + turnover_daily(:,:,isapbelow,icarbon) + turnover_daily(:,:,iheartbelow,icarbon) &
+!!$            & + turnover_daily(:,:,icarbres,icarbon) * (1. - shoot_ratio(:,:))
+!!$
+!!$       WHERE (.NOT. PFTpresent(:,:))
+!!$          woody_biomass_above(:,:) = zero
+!!$          woody_biomass_below(:,:) = zero
+!!$          wood_loss_ab(:,:) = zero
+!!$          wood_loss_be(:,:) = zero
+!!$       ENDWHERE
+!!$
+!!$       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,:)
+!!$
+!!$       carb_mass_variation(:)=-carb_mass_total(:)
+!!$       carb_mass_total(:)=SUM((tot_live_biomass(:,:,icarbon)+tot_litter_carb+tot_soil_carb)*veget_max,dim=2) + &
+!!$            &                 (prod_m_total + prod_l_total)
+!!$       carb_mass_variation(:)=carb_mass_total(:)+carb_mass_variation(:)
+!!$
+!!$       !! 17. Write history
+!!$
+!!$       CALL histwrite_p (hist_id_stomate, 'RESOLUTION_X', itime, &
+!!$            resolution(:,1), npts, hori_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'RESOLUTION_Y', itime, &
+!!$            resolution(:,2), npts, hori_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CONTFRAC', itime, &
+!!$            contfrac(:), npts, hori_index)
+!!$
+!!$       CALL histwrite_p (hist_id_stomate, 'LITTER_STR_AB', itime, &
+!!$            litter(:,istructural,:,iabove,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'LITTER_MET_AB', itime, &
+!!$            litter(:,imetabolic,:,iabove,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'LITTER_STR_BE', itime, &
+!!$            litter(:,istructural,:,ibelow,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'LITTER_MET_BE', itime, &
+!!$            litter(:,imetabolic,:,ibelow,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'LITTER_WOD_AB', itime, &
+!!$            litter(:,iwoody,:,iabove,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'LITTER_WOD_BE', itime, &
+!!$            litter(:,iwoody,:,ibelow,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'DEADLEAF_COVER', itime, &
+!!$            deadleaf_cover, npts, hori_index)
+!!$
+!!$       CALL histwrite_p (hist_id_stomate, 'TOTAL_SOIL_CARB', itime, &
+!!$            tot_litter_soil_carb, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CARBON_ACTIVE', itime, &
+!!$            carbon(:,iactive,:), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CARBON_SLOW', itime, &
+!!$            carbon(:,islow,:), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CARBON_PASSIVE', itime, &
+!!$            carbon(:,ipassive,:), npts*nvm, horipft_index)
+!!$
+!!$       CALL histwrite_p (hist_id_stomate, 'T2M_MONTH', itime, &
+!!$            t2m_month, npts, hori_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'T2M_WEEK', itime, &
+!!$            t2m_week, npts, hori_index)
+!!$
+!!$       CALL histwrite_p (hist_id_stomate, 'HET_RESP', itime, &
+!!$            resp_hetero(:,:), npts*nvm, horipft_index)
+!!$
+!!$       CALL histwrite_p (hist_id_stomate, 'BLACK_CARBON', itime, &
+!!$            black_carbon, npts, hori_index)
+!!$
+!!$       CALL histwrite_p (hist_id_stomate, 'FIREINDEX', itime, &
+!!$            fireindex(:,:), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'LITTERHUM', itime, &
+!!$            litterhum_daily, npts, hori_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CO2_FIRE', itime, &
+!!$            co2_fire, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CO2_TAKEN', itime, &
+!!$            co2_to_bm, npts*nvm, horipft_index)
+!!$       ! land cover change
+!!$       CALL histwrite_p (hist_id_stomate, 'CFLUX_PROD_S', itime, &
+!!$            cflux_prod_s, npts, hori_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CFLUX_PROD_M', itime, &
+!!$            cflux_prod_m, npts, hori_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CFLUX_PROD_L', itime, &
+!!$            cflux_prod_l, npts, hori_index)  
+!!$       CALL histwrite_p (hist_id_stomate, 'HARVEST_ABOVE', itime, &
+!!$            SUM(harvest_pool(:,:,1,ifm_crop,icut_crop),2), npts, hori_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'LAI', itime, &
+!!$            lai, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'VEGET_MAX', itime, &
+!!$            veget_max, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'NPP', itime, &
+!!$            npp_daily, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'GPP', itime, &
+!!$            gpp_daily, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'IND', itime, &
+!!$            ind, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'CN_IND', itime, &
+!!$            cn_ind, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'WOODMASS_IND', itime, &
+!!$            woodmass_ind, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'TOTAL_M', itime, &
+!!$            tot_live_biomass(:,:,icarbon), npts*nvm, horipft_index)
+!!$       !
+!!$       IF ( control%forest_management ) THEN
+!!$          CALL histwrite_p (hist_id_stomate, 'TOTAL_WOOD_BE', itime, &
+!!$               woody_biomass_below(:,:), npts*nvm, horipft_index)
+!!$          CALL histwrite_p (hist_id_stomate, 'TOTAL_WOOD_AB', itime, &
+!!$               woody_biomass_above(:,:), npts*nvm, horipft_index)
+!!$          CALL histwrite_p (hist_id_stomate, 'WOOD_LOSS_AB', itime, &
+!!$               wood_loss_ab(:,:), npts*nvm, horipft_index)
+!!$          CALL histwrite_p (hist_id_stomate, 'WOOD_LOSS_BE', itime, &
+!!$               wood_loss_be(:,:), npts*nvm, horipft_index)
+!!$       END IF ! control%forest_management
+!!$       !
+!!$       CALL histwrite_p (hist_id_stomate, 'LEAF_M', itime, &
+!!$            biomass(:,:,ileaf,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'SAP_M_AB', itime, &
+!!$            biomass(:,:,isapabove,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'SAP_M_BE', itime, &
+!!$            biomass(:,:,isapbelow,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'HEART_M_AB', itime, &
+!!$            biomass(:,:,iheartabove,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'HEART_M_BE', itime, &
+!!$            biomass(:,:,iheartbelow,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'ROOT_M', itime, &
+!!$            biomass(:,:,iroot,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'FRUIT_M', itime, &
+!!$            biomass(:,:,ifruit,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'RESERVE_M', itime, &
+!!$            biomass(:,:,icarbres,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'TOTAL_TURN', itime, &
+!!$            tot_turnover(:,:,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'LEAF_TURN', itime, &
+!!$            turnover_daily(:,:,ileaf,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'SAP_AB_TURN', itime, &
+!!$            turnover_daily(:,:,isapabove,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'ROOT_TURN', itime, &
+!!$            turnover_daily(:,:,iroot,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'FRUIT_TURN', itime, &
+!!$            turnover_daily(:,:,ifruit,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'TOTAL_BM_LITTER', itime, &
+!!$            tot_bm_to_litter(:,:,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'LEAF_BM_LITTER', itime, &
+!!$            bm_to_litter(:,:,ileaf,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'SAP_AB_BM_LITTER', itime, &
+!!$            bm_to_litter(:,:,isapabove,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'SAP_BE_BM_LITTER', itime, &
+!!$            bm_to_litter(:,:,isapbelow,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'HEART_AB_BM_LITTER', itime, &
+!!$            bm_to_litter(:,:,iheartabove,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'HEART_BE_BM_LITTER', itime, &
+!!$            bm_to_litter(:,:,iheartbelow,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'ROOT_BM_LITTER', itime, &
+!!$            bm_to_litter(:,:,iroot,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'FRUIT_BM_LITTER', itime, &
+!!$            bm_to_litter(:,:,ifruit,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'RESERVE_BM_LITTER', itime, &
+!!$            bm_to_litter(:,:,icarbres,icarbon), npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'MAINT_RESP', itime, &
+!!$            resp_maint, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'GROWTH_RESP', itime, &
+!!$            resp_growth, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'AGE', itime, &
+!!$            age, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'HEIGHT', itime, &
+!!$            height, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'MOISTRESS', itime, &
+!!$            moiavail_week, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'VCMAX', itime, &
+!!$            vcmax, npts*nvm, horipft_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'TURNOVER_TIME', itime, &
+!!$            turnover_time, npts*nvm, horipft_index)
+!!$       ! land cover change
+!!$       CALL histwrite_p (hist_id_stomate, 'PROD_M', itime, &
+!!$            prod_m, npts*(nmedium+1), horip_mm_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'PROD_L', itime, &
+!!$            prod_l, npts*(nlong+1), horip_ll_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'FLUX_M', itime, &
+!!$            flux_m, npts*nmedium, horip_m_index)
+!!$       CALL histwrite_p (hist_id_stomate, 'FLUX_L', itime, &
+!!$            flux_l, npts*nlong, horip_l_index)
+!!$
+!!$       ! forest management
+!!$
+!!$       ! For state variables, in order to be consistent with other history variables that are
+!!$       ! null all the time but the last day of the year, their value is recorded as 0 for all 
+!!$       ! days but the last of the year.
+!!$
+!!$       IF ( control%forest_management ) THEN
+!!$
+!!$          IF ( EndOfYear ) THEN
+!!$             var_real=REAL(age_stand)
+!!$             CALL histwrite_p (hist_id_stomate, 'AGE_STAND', itime, &
+!!$                  var_real, npts*nvm, horipft_index) 
+!!$             var_real=REAL(rotation_n)
+!!$             CALL histwrite_p (hist_id_stomate, 'ROTATION_N', itime, &
+!!$                  var_real, npts*nvm, horipft_index)
+!!$             var_real=REAL(last_cut)
+!!$             CALL histwrite_p (hist_id_stomate, 'LAST_CUT', itime, &
+!!$                  var_real, npts*nvm, horipft_index)
+!!$             var_real=REAL(forest_managed)
+!!$             CALL histwrite_p (hist_id_stomate, 'FOREST_MANAGED', itime, &
+!!$                  var_real, npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'WOOD_LOSS_AB_EOY', itime, &
+!!$                  wood_loss_ab, npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'EXPORTED_BM', itime, &
+!!$                  exported_bm, npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'LAI_MAX_LYEAR', itime, &
+!!$                  lai_max_lastyear, npts*nvm, horipft_index) 
+!!$             lai_max_lastyear(:,:) = zero
+!!$             CALL histwrite_p (hist_id_stomate, 'SIGMA', itime, &
+!!$                  sigma, npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'GAMMA', itime, &
+!!$                  gamma, npts*nvm, horipft_index) ! modifTL
+!!$             CALL histwrite_p (hist_id_stomate, 'AV_CIRC', itime, &
+!!$                  av_circ, npts*nvm, horipft_index) 
+!!$             CALL histwrite_p (hist_id_stomate, 'DOM_HEIGHT', itime, &
+!!$                  dom_height, npts*nvm, horipft_index) 
+!!$             CALL histwrite_p (hist_id_stomate, 'AV_HEIGHT', itime, &
+!!$                  av_height, npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'MED_HEIGHT', itime, &
+!!$                  med_height, npts*nvm, horipft_index) 
+!!$             CALL histwrite_p (hist_id_stomate, 'Q1_HEIGHT', itime, &
+!!$                  q1_height, npts*nvm, horipft_index) 
+!!$             CALL histwrite_p (hist_id_stomate, 'Q3_HEIGHT', itime, &
+!!$                  q3_height, npts*nvm, horipft_index) 
+!!$             CALL histwrite_p (hist_id_stomate, 'STANDING_AB_BM', itime, &
+!!$                  standing_ab_bm, npts*nvm, horipft_index) 
+!!$             CALL histwrite_p (hist_id_stomate, 'DELTAVOL', itime, &
+!!$                  deltavol, npts*nvm, horipft_index) 
+!!$             CALL histwrite_p (hist_id_stomate, 'STANDING_AB_VOL', itime, &
+!!$                  standing_ab_vol, npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'HAR_VOL', itime, &
+!!$                  harvestable_vol, npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'HAR_VOL_INC', itime, &
+!!$                  harvestable_vol_inc, npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'EXPORTED_VOL', itime, &
+!!$                  exported_vol, npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'EXPORTED_VOL_TH', itime, &
+!!$                  exported_vol_th, npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CIRC_MIN', itime, &
+!!$                  circ_min, npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CIRC_MAX', itime, &
+!!$                  circ_max, npts*nvm, horipft_index)
+!!$!             CALL histwrite_p (hist_id_stomate, 'RDI', itime, &
+!!$!                  rdi, npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC02', itime, &
+!!$                  circ_class_n(:,:,ic02), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC04', itime, &
+!!$                  circ_class_n(:,:,ic04), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC06', itime, &
+!!$                  circ_class_n(:,:,ic06), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC08', itime, &
+!!$                  circ_class_n(:,:,ic08), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC10', itime, &
+!!$                  circ_class_n(:,:,ic10), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC12', itime, &
+!!$                  circ_class_n(:,:,ic12), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC14', itime, &
+!!$                  circ_class_n(:,:,ic14), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC16', itime, &
+!!$                  circ_class_n(:,:,ic16), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC18', itime, &
+!!$                  circ_class_n(:,:,ic18), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC20', itime, &
+!!$                  circ_class_n(:,:,ic20), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC222', itime, &
+!!$                  circ_class_n(:,:,ic222), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CCPO', itime, &
+!!$                  circ_class_n(:,:,icpo), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CCSW', itime, &
+!!$                  circ_class_n(:,:,icsw), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CCMW', itime, &
+!!$                  circ_class_n(:,:,icmw), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CCLW', itime, &
+!!$                  circ_class_n(:,:,iclw), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC02_BT', itime, &
+!!$                  circ_class_n_bt(:,:,ic02), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC04_BT', itime, &
+!!$                  circ_class_n_bt(:,:,ic04), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC06_BT', itime, &
+!!$                  circ_class_n_bt(:,:,ic06), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC08_BT', itime, &
+!!$                  circ_class_n_bt(:,:,ic08), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC10_BT', itime, &
+!!$                  circ_class_n_bt(:,:,ic10), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC12_BT', itime, &
+!!$                  circ_class_n_bt(:,:,ic12), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC14_BT', itime, &
+!!$                  circ_class_n_bt(:,:,ic14), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC16_BT', itime, &
+!!$                  circ_class_n_bt(:,:,ic16), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC18_BT', itime, &
+!!$                  circ_class_n_bt(:,:,ic18), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC20_BT', itime, &
+!!$                  circ_class_n_bt(:,:,ic20), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CC222_BT', itime, &
+!!$                  circ_class_n_bt(:,:,ic222), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CCPO_BT', itime, &
+!!$                  circ_class_n_bt(:,:,icpo), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CCSW_BT', itime, &
+!!$                  circ_class_n_bt(:,:,icsw), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CCMW_BT', itime, &
+!!$                  circ_class_n_bt(:,:,icmw), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'CCLW_BT', itime, &
+!!$                  circ_class_n_bt(:,:,iclw), npts*nvm, horipft_index)
+!!$             CALL histwrite_p (hist_id_stomate, 'IND_BT', itime, &
+!!$                  ind_bt, npts*nvm, horipft_index)
+!!$          ENDIF
+!!$
+!!$       END IF  ! control%forest_management
+!!$
+!!$       IF ( hist_id_stomate_IPCC > 0 ) THEN
+!!$          vartmp(:)=SUM(tot_live_biomass(:,:,icarbon)*veget_max,dim=2)/1e3*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "cVeg", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(tot_litter_carb*veget_max,dim=2)/1e3*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "cLitter", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(tot_soil_carb*veget_max,dim=2)/1e3*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "cSoil", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=(prod_m_total + prod_l_total)/1e3
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "cProduct", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=carb_mass_variation/1e3/one_day*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "cMassVariation", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(lai*veget_max,dim=2)*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "lai", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(gpp_daily*veget_max,dim=2)/1e3/one_day*contfrac
+!!$          CALL histwrite_p (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_p (hist_id_stomate_IPCC, "ra", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(npp_daily*veget_max,dim=2)/1e3/one_day*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "npp", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(resp_hetero*veget_max,dim=2)/1e3/one_day*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "rh", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(co2_fire*veget_max,dim=2)/1e3/one_day*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "fFire", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(harvest_pool(:,:,1,ifm_crop,icut_crop),2)/1e3/one_day*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "fHarvest", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=cflux_prod_total/1e3/one_day*contfrac
+!!$          CALL histwrite_p (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-SUM(harvest_pool(:,:,1,ifm_crop,icut_crop),2))/ &
+!!$               1e3/one_day*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "nbp", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM((tot_bm_to_litter(:,:,icarbon) + tot_turnover(:,:,icarbon))*veget_max,dim=2)/1e3/one_day*contfrac
+!!$          CALL histwrite_p (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_p (hist_id_stomate_IPCC, "fLitterSoil", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(biomass(:,:,ileaf,icarbon)*veget_max,dim=2)/1e3*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "cLeaf", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM((biomass(:,:,isapabove,icarbon)+biomass(:,:,iheartabove,icarbon))*veget_max,dim=2)/1e3*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "cWood", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(( biomass(:,:,iroot,icarbon) + biomass(:,:,isapbelow,icarbon) + biomass(:,:,iheartbelow,icarbon) ) &
+!!$               &        *veget_max,dim=2)/1e3*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "cRoot", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(( biomass(:,:,icarbres,icarbon) + biomass(:,:,ifruit,icarbon))*veget_max,dim=2)/1e3*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "cMisc", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM((litter(:,istructural,:,iabove,icarbon)+litter(:,imetabolic,:,iabove,icarbon))*veget_max,dim=2)/1e3*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "cLitterAbove", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM((litter(:,istructural,:,ibelow,icarbon)+litter(:,imetabolic,:,ibelow,icarbon))*veget_max,dim=2)/1e3*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "cLitterBelow", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(carbon(:,iactive,:)*veget_max,dim=2)/1e3*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "cSoilFast", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(carbon(:,islow,:)*veget_max,dim=2)/1e3*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "cSoilMedium", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(carbon(:,ipassive,:)*veget_max,dim=2)/1e3*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "cSoilSlow", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          DO j=1,nvm
+!!$             histvar(:,j)=veget_max(:,j)*contfrac(:)*100
+!!$          ENDDO
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "landCoverFrac", itime, &
+!!$               histvar, npts*nvm, horipft_index)
+!!$          !-
+!!$          vartmp(:)=zero
+!!$          DO j = 2,nvm
+!!$             IF (is_deciduous(j)) THEN
+!!$                vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100
+!!$             ENDIF
+!!$          ENDDO
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "treeFracPrimDec", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          !-
+!!$          vartmp(:)=zero
+!!$          DO j = 2,nvm
+!!$             IF (is_evergreen(j)) THEN
+!!$                vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100
+!!$             ENDIF
+!!$          ENDDO
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "treeFracPrimEver", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          !-
+!!$          vartmp(:)=zero
+!!$          DO j = 2,nvm
+!!$             IF ( .NOT.(is_c4(j)) ) THEN
+!!$                vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100
+!!$             ENDIF
+!!$          ENDDO
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "c3PftFrac", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          !-
+!!$          vartmp(:)=zero
+!!$          DO j = 2,nvm
+!!$             IF ( is_c4(j) ) THEN
+!!$                vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100
+!!$             ENDIF
+!!$          ENDDO
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "c4PftFrac", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          !-
+!!$          vartmp(:)=SUM(resp_growth*veget_max,dim=2)/1e3/one_day*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "rGrowth", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(resp_maint*veget_max,dim=2)/1e3/one_day*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "rMaint", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(bm_alloc(:,:,ileaf,icarbon)*veget_max,dim=2)/1e3/one_day*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "nppLeaf", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(bm_alloc(:,:,isapabove,icarbon)*veget_max,dim=2)/1e3/one_day*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "nppWood", itime, &
+!!$               vartmp, npts, hori_index)
+!!$          vartmp(:)=SUM(( bm_alloc(:,:,isapbelow,icarbon) + bm_alloc(:,:,iroot,icarbon) )*veget_max,dim=2)/1e3/one_day*contfrac
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, "nppRoot", itime, &
+!!$               vartmp, npts, hori_index)
+!!$
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, 'RESOLUTION_X', itime, &
+!!$               resolution(:,1), npts, hori_index)
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, 'RESOLUTION_Y', itime, &
+!!$               resolution(:,2), npts, hori_index)
+!!$          CALL histwrite_p (hist_id_stomate_IPCC, 'CONTFRAC', itime, &
+!!$               contfrac(:), npts, hori_index)
+!!$
+!!$       ENDIF
+
+    ENDIF ! checking to see if we are doing new or old allocation
+
+    !---TEMP---
+    CALL check_biomass_sync("stomate_lpj.f90: After LPJ", npts, biomass, &
+         circ_class_biomass, circ_class_n, ind, &
+         lsync, bm_sync)
+    
+    !write(*,*) 'BIOMASS_after_after',sum(sum(biomass(1,2,1:8,:),dim=2),dim=1)
+    !write(*,*) 'sync_after_after',sum(bm_sync(1,2,:))
+
+
+    firstcall = .FALSE.
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving stomate_lpj'
+
+  END SUBROUTINE StomateLpj
+
+END MODULE stomate_lpj
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_mark_kill.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_mark_kill.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_mark_kill.f90	(revision 7236)
@@ -0,0 +1,982 @@
+! =================================================================================================================================
+! MODULE       : stomate_mark_kill
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         Marks vegetation for killing by natural causes.  Replaces
+!                lpj_kill.  Does not work with the DGVM.
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	:
+!!
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_stomate/stomate_mark_kill.f90 $
+!! $Date: 2013-09-13 17:14:52 +0200 (Fri, 13 Sep 2013) $
+!! $Revision: 1470 $
+!! \n
+!_ ================================================================================================================================
+
+
+MODULE stomate_mark_kill
+
+  ! modules used:
+
+  USE ioipsl_para
+  USE stomate_data
+  USE pft_parameters
+  USE constantes
+  USE function_library,       ONLY : distribute_mortality_biomass_yyt,&
+                                     nmax,  wood_to_dia,  P50_vary_class
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC kill_prognostic
+
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE  : kill_prognostic
+!!
+!>\BRIEF       Kills natural pfts that have low biomass or low number of individuals.
+!!             Does not change the biomass or litter pools.
+!!
+!! DESCRIPTION : Kills natural PFTS.  Forests can die through self-thinning or
+!!             environmental conditions.  Crops can die through environmental
+!!             conditions, and grasses don't die at all.  The total number
+!!             of individuals to be killed in each circ class are outputted
+!!             in circ_class_kill, and the biomass is actually killed in
+!!             gap_prognostic.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::circ_class_kill
+!!
+!! REFERENCE(S) : None
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE kill_prognostic (npts, whichroutine, lm_lastyearmax, ind, &
+       PFTpresent, biomass, npp_longterm, circ_class_biomass, &
+       circ_class_n, circ_class_kill, rue_longterm, turnover_longterm, &
+       dt, veget_max, st_dist, forest_managed,lpft_replant,stem_plc,psi_stem,counter_psi,counter_2,counter_0,st_mortality,d_mortality,kill_st,kill_d,circ_class_st, circ_class_mor, circ_class_litter, circ_class_leaflitter, circ_class_saplitter, circ_class_heartlitter)
+
+ !! 0. Variable and parameter description
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                                :: npts                !! Domain size (unitless)
+    CHARACTER(LEN=10), INTENT(in)                             :: whichroutine        !! Message (unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: veget_max           !! "maximal" coverage fraction of a PFT on 
+                                                                                     !! the ground (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: lm_lastyearmax      !! Last year's maximum leaf mass, for each 
+                                                                                     !! PFT @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: rue_longterm        !! Longterm radiation use efficiency 
+                                                                                     !! (??units??)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                                   INTENT(in) :: turnover_longterm   !! "Long term" (default 3-year) turnover 
+                                                                                     !! rate @tex $(gC m^{-2} year^{-1})$ @endtex
+    REAL(r_std), INTENT(in)                                   :: dt                  !! Time step (days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: npp_longterm        !! "Long term" (default = 3-year) net primary 
+                                                                                     !! productivity 
+                                                                                     !! @tex $(gC.m^{-2} year^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:), INTENT(in)                     :: st_dist             !! The probability distribution of trees 
+                                                                                     !! removed from a circ class in case of  
+                                                                                     !! self thinning (unitless).
+    INTEGER(i_std), DIMENSION (:,:), INTENT(in)               :: forest_managed      !! forest management flag (is the forest 
+                                                                                     !! being managed?)
+
+    !! 0.2 Output variables
+
+
+    !! 0.3 Modified variables
+
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)               :: PFTpresent          !! Is pft there (true/false)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: ind                 !! Number of individuals 
+                                                                                     !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                                INTENT(inout) :: biomass             !! Biomass @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements), &                         
+                                                INTENT(inout) :: circ_class_biomass  !! Biomass of the componets of the model  
+                                                                                     !! tree within a circumference
+                                                                                     !! class @tex $(gC ind^{-1})$ @endtex  
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(inout)     :: circ_class_n        !! Number of individuals in each circ class
+                                                                                     !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nfm_types,ncut_times),&
+                                            INTENT(inout)     :: circ_class_kill     !! Number of trees within a circ that needs
+                                                                                     !! to be killed @tex $(ind m^{-2})$ @endtex
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)               :: lpft_replant        !! Set to true if a PFT has been clearcut
+                                                                                     !! and needs to be replaced by another species
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                            :: ipts, ivm,icir,ipar !! Indices       (unitless)
+    INTEGER(i_std)                                            :: iele, imbc, istep   !! Indices       (unitless)
+    INTEGER(i_std)                                            :: ifm                 !! Indices       (unitless)
+    LOGICAL, DIMENSION(npts)                                  :: was_killed          !! Bookkeeping   (true/false)
+    REAL(r_std), DIMENSION(ncirc)                             :: diameters_temp      !! Trunk diameter calculated from allometry
+    REAL(r_std)                                               :: Dg                  !! Quadratic mean diameter of the stand (cm)
+    REAL(r_std)                                               :: bm_difference       !! the difference between self-thinning biomass
+                                                                                     !! and that due to environmental mortality
+    REAL(r_std)                                               :: difference          !! the difference between the self-thinning 
+                                                                                     !! density
+                                                                                     !! and the true density (individuals per m**2)
+    REAL(r_std), DIMENSION(npts,nvm)                          :: st_dens             !! the self-thinning density of the stand 
+                                                                                     !! (individuals per m**2)
+    REAL(r_std), DIMENSION(npts,nvm),INTENT(out)              :: st_mortality        !! biomass killed due to self-thinning density 
+    REAL(r_std), DIMENSION(npts,nvm),INTENT(out)              :: d_mortality         !! biomass killed due to the environment
+    REAL(r_std)                                               :: delta_biomass       !! Net biomass increase for the previous
+                                                                                     !! year @tex $(gC m^{-2} year^{-1})$ @endtex
+    REAL(r_std)                                               :: vigour              !! Growth efficiency, an indicator of tree
+                                                                                     !! vitality, used to calculate mortality
+    REAL(r_std)                                               :: mortality_greff     !! Mortality rate derived by growth
+	                                                                             !! efficiency @tex $(year^{-1})$ @endtex
+    REAL(r_std)                                               :: mortality           !! Mortality (fraction of trees that is
+                                                                                     !! dying per time step)
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements)        :: check_intern        !! Contains the components of the internal
+                                                                                     !! mass balance chech for this routine
+                                                                                     !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)                :: closure_intern      !! Check closure of internal mass balance
+                                                                                     !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)                :: pool_start, pool_end!! Start and end pool of this routine 
+                                                                                     !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std)                                               :: temp  
+    LOGICAL                                                   :: lconverged          !! Checking for loop convergence
+    REAL(r_std), DIMENSION(ncirc)                             :: target_st_kill      !! How many trees from each circumference
+                                                                                     !! class we would like to kill.
+                                                                                     !! @tex $(trees m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                             :: true_st_kill        !! How many trees from each circumference
+                                                                                     !! class that we actually killed.
+                                                                                     !! @tex $(trees m^{-2})$ @endtex
+    REAL(r_std)                                               :: excess_ind          !! THe difference between the amount of
+                                                                                     !! trees we want to kill and how many we
+                                                                                     !! can actually kill based on our
+                                                                                     !! circ_class distribution.
+                                                                                     !! @tex $(trees m^{-2})$ @endtex
+    ! added by Yitong Yao in 06 Jan 2020 16:06
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(in)      :: stem_plc
+    ! added by Yitong Yao in 06 Jan 2020 16:06 above line
+   
+    ! added by Yitong Yao in 06 Jan 2020 16:06
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(in)      :: psi_stem
+    ! added by Yitong Yao in 06 Jan 2020 16:06 above line
+
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)   :: kill_st
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)   :: kill_d
+    
+    
+    REAL(r_std), DIMENSION(ncirc)                             :: circ_diameters_temp     
+    REAL(r_std), DIMENSION(ncirc)                             :: circ_class_P50
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(inout)              :: counter_psi
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(inout)              :: counter_2
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(inout)              :: counter_0
+
+
+
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(out)                     :: circ_class_mor 
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(out)       :: circ_class_st 
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(out)       :: circ_class_litter
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(out)       :: circ_class_leaflitter
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(out)       :: circ_class_saplitter
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(out)       :: circ_class_heartlitter
+    !! 
+        REAL(r_std) :: yyt_test
+    !!  
+!    INTEGER,SAVE :: counter=0
+!_ ================================================================================================================================
+   
+    !++++ TEMP +++++
+ !   counter=counter+1
+    !++++++++++
+
+
+
+   IF (bavard.GE.2) WRITE(numout,*) 'Entering kill_prognostic'
+
+ !! 1. Initialize 
+   !! 1.1 Initialize check for mass balance closure
+   !  The mass balance is calculated at the end of this routine
+   !  in section 4.
+   pool_start = zero
+   DO ipar = 1,nparts
+      DO iele = 1,nelements
+         !  Initial biomass pool
+         pool_start(:,:,iele) = pool_start(:,:,iele) + &
+              (biomass(:,:,ipar,iele) * veget_max(:,:))
+      ENDDO
+   ENDDO
+
+   !! 1.2 Initialize variables
+   d_mortality(:,:)=zero
+   st_mortality(:,:)=zero
+   circ_class_mor(:,:,:)=zero
+   circ_class_litter(:,:,:)=zero   
+   circ_class_leaflitter(:,:,:)=zero
+   circ_class_saplitter(:,:,:)=zero
+   circ_class_heartlitter(:,:,:)=zero
+   kill_st(:,:)=zero
+   kill_d(:,:)=zero
+   circ_class_st(:,:,:)=zero
+ !! 2. Kill PFTs
+
+   ! Kill 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
+   ! processor
+   DO ivm = 2,nvm ! loop plant functional types
+
+      was_killed(:) = .FALSE.
+!      WRITE(numout,*) 'is_nautral ',natural(ivm),ivm
+      IF ( natural(ivm) ) THEN
+         
+         !! 2.2 Kill natural PFTs when running STOMATE without DGVM
+
+         !! 2.2.1 Kill PFTs 
+         !  Kill PFTs but not in the first year because one year
+         !  is needed to fill the long-term and seasonal variables.
+         !  Therefore no leaves are grown in the first year. As
+         !  long as the plant has never grown leaves, ::rue_longterm
+         !  keeps its initial value of 1. Note that the logic of
+         !  this statement differs from the original verison that
+         !  was used for the resource limited allocation where the
+         !  carbohydrate reserves pool was treated differently than
+         !  in the functional allocation. 
+         IF(ld_kill)THEN
+            DO ipts=1,npts
+               IF( PFTpresent(ipts,ivm) .AND. &
+                    (rue_longterm(ipts,ivm) .NE. un) .AND. & 
+                    (biomass(ipts,ivm,icarbres,icarbon) .LE. min_stomate .AND. & 
+                   biomass(ipts,ivm,ilabile,icarbon) .LE. min_stomate .AND. &
+                    biomass(ipts,ivm,ileaf,icarbon) .LE. min_stomate ) .AND. & 
+                    ind(ipts,ivm) .GT. zero) THEN
+                  
+                  WRITE(numout,*) 'Killing PFT, ipts: ',ivm,ipts
+                  WRITE(numout,*) 'rue_longterm(ipts,ivm)',rue_longterm(ipts,ivm)
+                  WRITE(numout,*) 'biomass(ipts,ivm,icarbres,icarbon)',biomass(ipts,ivm,icarbres,icarbon)
+                  WRITE(numout,*) 'biomass(ipts,ivm,ilabile,icarbon)',biomass(ipts,ivm,ilabile,icarbon)
+                  WRITE(numout,*) 'biomass(ipts,ivm,ileaf,icarbon) ',biomass(ipts,ivm,ileaf,icarbon) 
+                  WRITE(numout,*) 'ind(ipts,ivm)',ind(ipts,ivm)
+               ENDIF
+            ENDDO
+         ENDIF
+
+         WHERE ( PFTpresent(:,ivm) .AND. &
+              (rue_longterm(:,ivm) .NE. un) .AND. & 
+              (biomass(:,ivm,icarbres,icarbon) .LE. min_stomate .AND. & 
+              biomass(:,ivm,ilabile,icarbon) .LE. min_stomate .AND. &
+              biomass(:,ivm,ileaf,icarbon) .LE. min_stomate ) .AND. & 
+              ind(:,ivm) .GT. zero)
+
+            was_killed(:) = .TRUE.
+
+         ENDWHERE
+         
+         !++++++++++++++++++++++++++++ testing...REMOVE
+!         WRITE(numout,*) 'KILLING test ',ivm,counter
+!         IF(counter == 175)THEN
+!            WRITE(numout,*) 'KILLING ARTIFICIALLY IN STOMATE_MARK_KILL'
+!            was_killed(:)=.TRUE.
+!         ENDIF
+         !++++++++++++++++++++++++++++
+
+         !! If the density of a forest goes below a certain level,
+         !! the forest dies off.  The density limit is referred to
+         !! in Bellasen et al 2010.
+
+         IF(is_tree(ivm))THEN
+
+            WHERE ( PFTpresent(:,ivm) .AND. &
+               (ind(:,ivm) .LE. dens_target(ivm)*ha_to_m2))
+               
+               was_killed(:) = .TRUE.
+                  
+            ENDWHERE
+
+         ENDIF ! checking for trees
+
+         ! Print some information if we are debugging
+         IF(ld_kill)THEN
+            IF(is_tree(ivm))THEN
+               DO ipts=1,npts
+                  IF( PFTpresent(ipts,ivm) .AND. &
+                       (ind(ipts,ivm) .LE. dens_target(ivm)*ha_to_m2))THEN
+                     
+                     WRITE(numout,*) 'Killing PFT, ipts: ',ivm,ipts
+                     WRITE(numout,*) 'Forest density too low'
+                     WRITE(numout,*) 'ind(ipts,ivm)',ind(ipts,ivm)
+                     WRITE(numout,*) 'dens_target(ivm)*ha_to_m2',dens_target(ivm)*ha_to_m2
+                  ENDIF
+
+               
+               ENDDO
+            ENDIF
+
+            DO ipts=1,npts
+               IF ( PFTpresent(ipts,ivm) .AND. &
+                    (rue_longterm(ipts,ivm) .NE. un) .AND. & 
+                    (biomass(ipts,ivm,icarbres,icarbon) .LE. min_stomate .AND. & 
+                    biomass(ipts,ivm,ilabile,icarbon) .LE. min_stomate .AND. &
+                    biomass(ipts,ivm,ileaf,icarbon) .LE. min_stomate ) .AND. & 
+                    ind(ipts,ivm) .GT. zero)THEN
+
+                  WRITE(numout,*) 'Killing PFT, ipts: ',ivm,ipts
+                  WRITE(numout,*) 'No roots, leaves, labile pool.'
+                  WRITE(numout,*) 'ind(ipts,ivm)',ind(ipts,ivm)
+                  WRITE(numout,*) 'Reserve pool',biomass(ipts,ivm,icarbres,icarbon)
+                  WRITE(numout,*) 'Labile pool',biomass(ipts,ivm,ilabile,icarbon)
+                  WRITE(numout,*) 'Leaves',biomass(ipts,ivm,ileaf,icarbon)
+                  
+               ENDIF
+            ENDDO
+         ENDIF
+
+         !! 2.3 Bookkeeping for PFTs that were killed
+         !  For PFTs that were killed, return biomass pools to litter 
+         !  and update biomass pools to zero
+         
+         DO ipts = 1,npts
+
+            !+++++++++ TEMP +++++++
+            !IF(test_pft == ivm)THEN
+            !   WRITE(numout,*) 'WAS_KILLED ',was_killed(ipts),rue_longterm(ipts,ivm)
+            !ENDIF
+            !+++++++++++++++++++++
+            !write(*,*) 'was_killed',was_killed(ipts)
+            IF ( was_killed(ipts) ) THEN
+
+               !+++++++++ TEMP +++++++
+               !IF(test_pft == ivm)THEN
+               !   WRITE(numout,*) 'WAS_KILLED KILLED',was_killed(ipts)
+               !ENDIF
+               !+++++++++++++++++++++
+
+               ! If a PFT is killed, this just means that we mark all the individuals
+               ! for a natural death (all debris stays on site).
+               ! The killing actually takes place in lpj_gap.f90.
+               ! We have to do this differently for trees and non-trees, since
+               ! circ_class_n is not defined for non-trees.
+               IF(is_tree(ivm))THEN
+
+                  ! In reality, if the forest is managed we will not lose this
+                  ! wood.  The forest would be harvested.  So, let's put these into
+                  ! different pools depending on the management type.
+                  ifm=forest_managed(ipts,ivm)
+                  write(*,*) 'forest_managed',ifm
+
+                  DO icir=1,ncirc
+                     circ_class_kill(ipts,ivm,icir,ifm,icut_clear)=&
+                          circ_class_n(ipts,ivm,icir)
+                  ENDDO
+
+                  ! If a stand dies while it is under management, perhaps
+                  ! we need to change the species.
+                  IF(forest_managed(ipts,ivm) .NE. 1)THEN
+                     lpft_replant(ipts,ivm)=.TRUE.
+                  ENDIF
+                     
+
+               ELSE
+
+                  ! Since lpj_gap only knows about circ_class_kill and circ_class_biomass,
+                  ! we need to give values to icir=1 for these variables for grasses
+                  ! and crops so that the correct amount of biomass is killed.
+                  circ_class_kill(ipts,ivm,1,ifm_none,icut_clear)=ind(ipts,ivm)
+                  DO iele=1,nelements
+                     DO ipar=1,nparts
+                        circ_class_biomass(ipts,ivm,1,ipar,iele)=biomass(ipts,ivm,ipar,iele)/&
+                             circ_class_kill(ipts,ivm,1,ifm_none,icut_clear)
+                     ENDDO
+                  ENDDO
+
+               ENDIF ! is_tree(ivm)
+
+               !! 2.7 Print sub routine messages
+               IF ( ld_kill ) THEN
+
+                  WRITE(numout,*) 'kill: eliminated ',PFT_name(ivm)
+                  WRITE(numout,*) '  pft number: ',ivm
+                  WRITE(numout,*) '  at grid: ',ipts
+
+               ENDIF
+
+            ENDIF ! was_killed
+
+         ENDDO ! loop over points
+
+      ENDIF       ! PFT is natural
+
+      !! We need to enforce two different types of killing at the moment,
+      !! self-thinning and environmental mortality.  Self-thinning is due
+      !! to resouce competition in dense stands, and environmental
+      !! mortality is due to environmental stress.  Self-thinning is
+      !! only applicable to forests.  
+      DO ipts=1,npts
+
+         ! Don't waste time if the whole PFT was already scheduled to die,
+         ! or if the PFT is not here.
+         IF(was_killed(ipts))CYCLE
+         IF(.NOT. PFTpresent(ipts,ivm))CYCLE
+  
+         
+         !! let's calculate the self-thinning limit first
+
+         ! Number of indiviudals for trees and grasses are calculated differently
+         IF ( is_tree(ivm) ) THEN
+
+            ! Calculate the self-thinning density.  This is the target density
+            ! for which we will kill small trees until we reach.
+            ! there are unit conversions here because the forestry routines
+            ! prefer to work with trees per hectare.  I convert everything to
+            ! individuals per m**2 when I can.
+            Dg=zero
+            diameters_temp(:)=wood_to_dia(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)
+            diameters_temp(:)=diameters_temp(:)*m_to_cm
+
+            DO icir=1,ncirc
+               Dg=Dg+circ_class_n(ipts,ivm,icir)*m2_to_ha*diameters_temp(icir)**2
+            ENDDO
+
+            ! After a coppice at the end of the year, it's possible that all 
+            ! the aboveground biomass is killed, but we still have individuals
+            ! because the roots are alive.  This means we don't have
+            ! a diameter, though, and therefore we will divide by zero
+            ! in the next block of code.  So we skip it, which is okay because
+            ! there will be no self-thinning in this case anyways.
+            IF(Dg .LT. min_stomate) CYCLE
+
+            Dg=SQRT(Dg/(ind(ipts,ivm)*m2_to_ha))
+            st_dens(ipts,ivm)=Nmax(Dg,ivm)*ha_to_m2
+
+            IF(ld_kill .AND. ivm == test_pft .AND. ipts == test_grid)THEN
+               WRITE(numout,*) 'Does self thinning happen?'
+               WRITE(numout,*) 'ipts,ivm: ',ipts,ivm
+               WRITE(numout,*) 'ind(ipts,ivm),st_dens(ipts,ivm): ',&
+                    ind(ipts,ivm),st_dens(ipts,ivm)
+            ENDIF
+            
+            !write(*,*) 'first Dg',Dg,'ind',ind(ipts,ivm)
+            !write(*,*) 'third st_dens',st_dens(ipts,ivm)
+            IF(ind(ipts,ivm) .GT. st_dens(ipts,ivm))THEN
+
+               IF(ld_kill .AND. ivm == test_pft)THEN
+                  WRITE(numout,*) 'Self thinning is taking place.'
+                  WRITE(numout,*) 'ipts,ivm: ',ipts,ivm
+                  WRITE(numout,*) 'ind(ipts,ivm),st_dens(ipts,ivm): ',&
+                       ind(ipts,ivm),st_dens(ipts,ivm)
+                  WRITE(numout,*) 'difference: ',&
+                       ind(ipts,ivm)-st_dens(ipts,ivm)
+                  WRITE(numout,*) 'st_dist: ',&
+                       st_dist(:)
+               ENDIF
+
+               ! Here is where we actually do the self thinning.  The number of
+               ! trees that we want to kill is the differnce between the
+               ! self thinning density and the true density.  Originally, we
+               ! killed only small trees until the densities were equal, the
+               ! reason being that self-thinning represents competition
+               ! driven mortality, and small trees are not able to compete for
+               ! resources (e.g. light) as well as larger trees.  However, this
+               ! seemed to cause strange results for both temperate and tropical
+               ! PFTs, so now we kill trees based on a user-defined distribution.
+               difference=ind(ipts,ivm) - st_dens(ipts,ivm)
+               !write(*,*) 'ind_diff',difference,'st_dens',st_dens(ipts,ivm),'ind',ind(ipts,ivm) 
+               ! This is what we want to kill.
+               target_st_kill(:)=st_dist(:)*difference
+               ! added by yitong yao in March 22 2020 09:31 cut STmortality 
+
+               !DO icir=1,ncirc
+               !   target_st_kill(icir)=target_st_kill(icir) / st_cut_fac
+               !ENDDO
+               ! added by yitong yao in March 22 2020 09:32 above lines 
+               ! However, we may not have a sufficient number of trees in each class,
+               ! so we might have to adjust things a bit.
+               true_st_kill(:)=target_st_kill(:)
+
+               istep=1
+               DO
+
+                  lconverged=.FALSE.
+
+                  ! Find out how many indivuals we cannot kill with the current
+                  ! distribution.
+                  excess_ind=zero
+                  DO icir=1,ncirc
+                     IF(circ_class_n(ipts,ivm,icir) .LT. true_st_kill(icir))THEN
+                        excess_ind=excess_ind+true_st_kill(icir)-circ_class_n(ipts,ivm,icir)
+                        true_st_kill(icir)=circ_class_n(ipts,ivm,icir)
+                     ENDIF
+                  ENDDO
+
+                  IF(excess_ind .GT. zero)THEN
+                     ! We have something to redistribute.
+                     ! Put all of the excess in the first class which is not already completely
+                     ! killed.  If we add too much, we'll catch it in the next loop.
+                     DO icir=1,ncirc
+                        IF(circ_class_n(ipts,ivm,icir) .GT. true_st_kill(icir))THEN
+                           true_st_kill(icir)=true_st_kill(icir)+excess_ind
+                           excess_ind=zero
+                        ENDIF
+                     ENDDO
+                  ELSE
+                     ! Done.
+                     lconverged=.TRUE.
+                  ENDIF
+
+                  IF(lconverged)EXIT
+
+                  istep=istep+1
+                  IF(istep .GT. 100)THEN
+                     ! This is an arbitrary exit here, just to make sure
+                     ! we don't get stuck in an infinite loop.  We should
+                     ! exit before we ever get here.  Otherwise, you can increase
+                     ! the number in the if statement and try again.
+                     WRITE (numout,*) 'ipts, ivm : ',ipts,ivm
+                     CALL ipslerr_p (3,'kill_prognostic', &
+                          'Was not able to distribute self-thinning individuals!', &
+                          'See the comments at this part of the code for a solution','')
+
+                  END IF
+               ENDDO
+               DO icir=1,ncirc
+                  true_st_kill(icir)=true_st_kill(icir) / st_cut_fac
+               ENDDO
+               circ_class_kill(ipts,ivm,:,ifm_none,icut_thin)=true_st_kill(:)
+               !write(*,*) 'circ_class_kill_NONE_thin',circ_class_kill(ipts,ivm,1,ifm_none,icut_thin)
+               circ_class_st(ipts,ivm,:)=true_st_kill(:) 
+               !DO icir=1,ncirc
+               !  write(*,*) 'circ_class_st ',icir,' ',circ_class_st(ipts,ivm,icir)
+               !ENDDO
+! This is for the old scheme that always took the youngest trees.
+!!$               icir=1
+!!$               DO
+!!$
+!!$                  IF(circ_class_n(ipts,ivm,icir) .GT. difference)THEN
+!!$                     circ_class_kill(ipts,ivm,icir,ifm_none,icut_thin)=difference
+!!$                     difference=zero
+!!$                  ELSE
+!!$                     circ_class_kill(ipts,ivm,icir,ifm_none,icut_thin)=circ_class_n(ipts,ivm,icir)
+!!$                     difference=difference-circ_class_n(ipts,ivm,icir)
+!!$                  ENDIF
+!!$                  
+!!$!                  WRITE(numout,*) 'self thinning difference ',icir,difference,circ_class_n(ipts,ivm,icir),&
+!!$!                       ind(ipts,ivm),st_dens(ipts,ivm)
+!!$                  IF(difference .LE. min_stomate)EXIT
+!!$                  icir=icir+1
+!!$                  IF(icir .GT. ncirc)THEN
+!!$                     CALL ipslerr(3,'stomate_mark_kill',&
+!!$                          'We have a problem.  We are trying to access ',&
+!!$                          'circumference classes in ljp_kill that do not exist!','')
+!!$                  ENDIF
+!!$
+!!$               ENDDO
+!!$               
+               IF(ld_kill .AND. ivm == test_pft)THEN
+                  WRITE(numout,*) 'After self thinning.'
+                  WRITE(numout,*) 'circ_class_kill: ',circ_class_kill(ipts,ivm,:,ifm_none,icut_thin)
+               ENDIF
+
+            ENDIF ! ind(ipts,ivm) .GT. st_dens(ipts,ivm)
+
+            ! now let's look at environmental mortality.  The calculation of this
+            ! rate depends on if it is fixed for the whole simulation or if it's
+            ! allowed to respond to things like NPP.
+
+            !write(*,*) 'stomate_constant_mortality',control%ok_constant_mortality
+            !! 3.1 Use growth efficiency or constant mortality?
+            IF ( .NOT. control%ok_constant_mortality  ) THEN
+
+               ! Was the PFT alive last year?
+               IF ( ( lm_lastyearmax(ipts,ivm) .GT. min_stomate ) ) THEN
+
+                  !! 3.1.1 Estimate net biomass increment
+                  ! Estimate net biomass increment by subtracting turnover from
+                  ! last year's NPP.
+                  ! Note that npp_longterm is the longterm growth efficiency
+                  ! (NPP/LAI) to be fair to deciduous trees
+                  delta_biomass = MAX( npp_longterm(ipts,ivm) - &
+                       ( turnover_longterm(ipts,ivm,ileaf,icarbon) + &
+                       turnover_longterm(ipts,ivm,iroot,icarbon) + &
+                       turnover_longterm(ipts,ivm,ifruit,icarbon) + & 
+                       turnover_longterm(ipts,ivm,isapabove,icarbon) + &
+                       turnover_longterm(ipts,ivm,isapbelow,icarbon) ), zero)
+
+                  !! 3.1.2 Calculate growth efficiency 
+                  !  Calculate growth efficiency by dividing net biomass increment
+                  !  by last year's maximum LAI. (corresponding actually to the
+                  !  maximum LAI of the previous year)
+                  vigour = delta_biomass / (lm_lastyearmax(ipts,ivm) * sla(ivm))
+                  !write(*,*) 'vigour',vigour
+                  ! PFT does not exist or as dead   
+               ELSE
+
+                  vigour = zero
+
+               END IF ! ( lm_lastyearmax(ipts,ivm) .GT. min_stomate)
+
+               !! 3.1.3 Calculate growth efficiency mortality rate
+               mortality_greff = mortality_max(ivm) / &
+                    ( un + ref_mortality(ivm) * vigour )
+
+               ! Scale mortality rate (fraction, 0-1) by timesteps per year 
+               mortality = MAX(mortality_min(ivm), mortality_greff) * dt/&
+                    one_year  
+               write(*,*) 'mortality_vigour',mortality
+            ! .NOT. control%ok_constant_mortality
+            ELSE
+
+               !! 3.2 Use constant mortality accounting for the residence time 
+               !! of each tree PFT
+
+               !  Scale mortality rate (fraction, 0-1) by timesteps per year
+               !  NOTE: the meaning of residence_time is very different between
+               !  the DOFOCO branch and the trunk. In the trunk biomass has no age
+               !  thus the residence time accounts for all forest dynamics including
+               !  self-thinning, pests, diseases and wind fall. In the DOFOCO branch
+               !  biomass does have an age and self-thinning is explicitly accounted 
+               !  for, hence, the residence time should be much higher as it only 
+               !  accounts for pest, diseases and windfall. Even the latter is not
+               !  exact because as long as those disturbances are small scale they
+               !  are probably accounted for in the parametrization of self-thinning.
+               mortality = dt/(residence_time(ivm)*one_year)
+               write(*,*) 'F_mortality',mortality
+!WRITE(*,*) "tzj_smk mortality", mortality
+!WRITE(*,*) "tzj_smk restime", residence_time
+
+            ENDIF ! .NOT.  control%ok_constant_mortality
+                
+           ! added by yitong yao in 06 Jan 2020 22:10  commented in 07 Jan 10:47
+           ! DO icir=1,ncirc
+           !     IF (stem_plc(1,2,icir) .GE. 50) THEN
+           !         mortality=mortality+circ_class_n(1,2,icir)*plc_kill_frac(2)
+           !     ENDIF
+           ! ENDDO
+            ! added by yitong YAO in 06 Jan 2020 22:10 above lines
+             
+            ! added by yitong yao in 10 Jan 2020 11:13 using linear relaxation
+            ! to get smoother estimate for counter 
+
+
+            ! added by Yitong Yao in 10 Jan 2020 11:14 above lines
+             
+            ! added by yitong yao in 07 Jan 2020 10:36 
+            ! yang hui
+            IF (yyt_flag_mortality .EQ. 1) THEN  
+             mortality = 0
+            ENDIF
+             yyt_test=yyt_flag_mortality 
+            
+            ! yang hui 
+            circ_class_P50(:)=zero
+            circ_diameters_temp(:)=wood_to_dia(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)
+            CALL P50_vary_class (circ_diameters_temp,circ_class_P50)
+            DO icir =1,ncirc
+                IF (stem_plc(ipts,ivm,icir) .GE. plc_threshold) THEN 
+                   !IF (psi_stem(ipts,ivm,icir) .LT. 0 .AND. psi_stem(ipts,ivm,icir) .GT. -25) THEN
+                         !write(*,*) 'psi_stem_',icir,' ',circ_diameters_temp(icir),' ',psi_stem(ipts,ivm,icir),' ', circ_class_P50(icir)
+                       counter_psi(ipts,ivm,icir)=counter_psi(ipts,ivm,icir) + 1
+                       IF (counter_0(ipts,ivm,icir) .GT. 0) THEN
+                          counter_2(ipts,ivm,icir) = counter_2(ipts,ivm,icir) + 1 
+                       ELSE
+                          counter_2(ipts,ivm,icir) = counter_psi(ipts,ivm,icir)
+                       ENDIF
+                       counter_0(ipts,ivm,icir) = counter_0(ipts,ivm,icir) + 0
+                       ! using flag to judge whether we need relax on
+                       ! counter_psi
+                        IF (relax_counter .EQ. 1) THEN 
+                                IF ((counter_psi(ipts,ivm,icir) .GE. day_threshold) .OR. ((counter_2(ipts,ivm,icir) .GE. day_threshold) .AND. (counter_psi(ipts,ivm,icir) .GT. counter_0(ipts,ivm,icir)) )) THEN
+                           !mortality=mortality+circ_class_n(ipts,ivm,icir)*plc_kill_frac(2)
+                           circ_class_mor(ipts,ivm,icir)=circ_class_n(ipts,ivm,icir)*mor_kill_frac(2)
+                                ENDIF
+                        ELSE
+                                IF (counter_psi(ipts,ivm,icir) .GE. day_threshold) THEN 
+                                     circ_class_mor(ipts,ivm,icir)=circ_class_n(ipts,ivm,icir)*mor_kill_frac(2)
+                                ENDIF
+                        ENDIF
+                       ! flag yitong yao 9 Feb 2021
+                   !ENDIF
+
+                ELSE
+                    counter_psi(ipts,ivm,icir) = 0
+                    IF (counter_2(ipts,ivm,icir) .GT. 0 ) THEN
+                        counter_0(ipts,ivm,icir) = counter_0(ipts,ivm,icir) + 1
+                    ELSE
+                        counter_0(ipts,ivm,icir) = 0
+                    ENDIF 
+                    counter_2(ipts,ivm,icir)=counter_2(ipts,ivm,icir)+0
+                    IF (counter_0(ipts,ivm,icir) .GE. 5) THEN 
+                        counter_2(ipts,ivm,icir) = 0
+                        counter_0(ipts,ivm,icir) = 0
+                    ENDIF
+                ENDIF
+
+               ! write(*,*) 'counter_psi ',icir,' ',counter_psi(ipts,ivm,icir)
+            ENDDO
+            ! added by yitong yao in 07 Jan 2020 10:37 above line 
+            !write(*,*) 'day_threshold',day_threshold
+            !write(*,*) 'after_mortality',mortality
+
+
+            !---TEMP---
+            IF (ld_kill .AND. ivm .EQ. test_pft) THEN
+               WRITE(numout,*) 'Mortality rate (0-1), ', mortality
+            ENDIF
+            !----------
+
+
+            ! Now the mortality is just a percentage of the total biomass
+            ! on the site.  Since the main variable we output here is
+            ! circ_class_kill, we need to convert that biomass into the
+            ! number of individuals that are killed, and from which
+            ! circumference classes.  Mortality in excess of the self-thinning
+            ! mortality will preferenctially kill large trees, since they are
+            ! assumed to be less resistant to climatic change.
+
+            ! Aggregate over the different biomass components
+            DO ipar = 1,nparts
+               IF (yyt_flag_mortality .EQ. 1) THEN
+               ! Aggregate over the different circumference classes
+                 DO icir = 1,ncirc
+
+                  ! Mortality from self-thinning
+                  ! Note that the unit of st_mortaility (g C m-2 dt-1) differs
+                  ! from that of mortality (rate dt-1)
+                  st_mortality(ipts,ivm) = st_mortality(ipts,ivm) + &
+                       circ_class_kill(ipts,ivm,icir,ifm_none,icut_thin) * &
+                       circ_class_biomass(ipts,ivm,icir,ipar,icarbon)
+                  ! yang hui      
+                  d_mortality(ipts,ivm) = d_mortality(ipts,ivm) + & 
+                      circ_class_mor(ipts,ivm,icir) * &
+                       circ_class_biomass(ipts,ivm,icir,ipar,icarbon) 
+                  ! yang hui
+                 ENDDO
+
+               ! Ageing and environmental mortality
+               ! Note that the unit of d_mortaility (g C m-2 dt-1) differs from 
+               ! that of mortality (rate dt-1)
+               ! yang hui 
+               ! below two lines commented by yitong yao 09 Feb 22:31
+                !IF (yyt_flag_mortality .EQ. 0) THEN
+              ELSE
+                    d_mortality(ipts,ivm) =  d_mortality(ipts,ivm) + &
+                    mortality * biomass(ipts,ivm,ipar,icarbon)  
+              ENDIF    
+               ! yang hui 
+
+            ENDDO ! ipar = 1,nparts
+            !write(*,*) 'yyt_st_mortality',st_mortality(ipts,ivm)
+            !write(*,*) 'yyt_d_mortality',d_mortality(ipts,ivm)
+!WRITE(*,*) "tzj_smk dmortality", d_mortality
+!WRITE(*,*) "tzj_smk biomass", biomass(ipts,2,:,icarbon)
+
+            ! added by yitong yao in March 18 2020 23:37
+
+            DO icir=1,ncirc
+                IF (circ_class_mor(ipts,ivm,icir) .GT. circ_class_kill(ipts,ivm,icir,ifm_none,icut_thin))  THEN
+                    circ_class_kill(ipts,ivm,icir,ifm_none,icut_thin)=circ_class_mor(ipts,ivm,icir)
+                    
+                ENDIF
+            ENDDO
+            DO icir=1,ncirc
+                write(*,*) 'circ_class_kill', icir,circ_class_kill(ipts,ivm,icir,ifm_none,icut_thin)
+                write(*,*) 'circ_class_biomass ', icir, circ_class_biomass(ipts,ivm,icir,7,1), circ_class_biomass(ipts,ivm,icir,4,1)
+                IF (circ_class_kill(ipts,ivm,icir,ifm_none,icut_thin) .LT. circ_class_n(ipts,ivm,icir)) THEN
+           circ_class_litter(ipts,ivm,icir)=(circ_class_biomass(ipts,ivm,icir,1,1)+circ_class_biomass(ipts,ivm,icir,2,1)+circ_class_biomass(ipts,ivm,icir,4,1)+circ_class_biomass(ipts,ivm,icir,7,1))*circ_class_kill(ipts,ivm,icir,ifm_none,icut_thin)
+                
+           circ_class_leaflitter(ipts,ivm,icir)=circ_class_biomass(ipts,ivm,icir,1,1)*circ_class_kill(ipts,ivm,icir,ifm_none,icut_thin)   
+              circ_class_saplitter(ipts,ivm,icir)=circ_class_biomass(ipts,ivm,icir,2,1)*circ_class_kill(ipts,ivm,icir,ifm_none,icut_thin)   
+          circ_class_heartlitter(ipts,ivm,icir)=circ_class_biomass(ipts,ivm,icir,4,1)*circ_class_kill(ipts,ivm,icir,ifm_none,icut_thin)  
+        ELSE
+         circ_class_litter(ipts,ivm,icir)=(circ_class_biomass(ipts,ivm,icir,1,1)+circ_class_biomass(ipts,ivm,icir,2,1)+circ_class_biomass(ipts,ivm,icir,4,1)+circ_class_biomass(ipts,ivm,icir,7,1))*circ_class_n(ipts,ivm,icir)
+         
+         circ_class_leaflitter(ipts,ivm,icir)=circ_class_biomass(ipts,ivm,icir,1,1)*circ_class_n(ipts,ivm,icir)
+         circ_class_saplitter(ipts,ivm,icir)=circ_class_biomass(ipts,ivm,icir,2,1)*circ_class_n(ipts,ivm,icir)
+         circ_class_heartlitter(ipts,ivm,icir)=circ_class_biomass(ipts,ivm,icir,4,1)*circ_class_n(ipts,ivm,icir)
+                ENDIF 
+            ENDDO
+            ! added by yitong yao in March 18 2020 23:37
+
+
+            IF(ld_kill .AND. test_pft .EQ. ivm .AND. test_grid == ipts)THEN
+               WRITE(numout,*) 'Does mortality happen?'
+               WRITE(numout,*) 'ipts,ivm: ',ipts,ivm
+               WRITE(numout,*) 'd_mortality(ipts,ivm): ',d_mortality(ipts,ivm)
+               WRITE(numout,*) 'st_mortality(ipts,ivm): ',st_mortality(ipts,ivm)
+            ENDIF
+
+            kill_st(ipts,ivm)=SUM(circ_class_kill(ipts,ivm,:,ifm_none,icut_thin),dim=1)
+            kill_d(ipts,ivm)=SUM(circ_class_mor(ipts,ivm,:),dim=1)
+            ! do we have extra killing that needs to be done?
+            bm_difference=d_mortality(ipts,ivm)- st_mortality(ipts,ivm)
+
+!WRITE(*,*) "tzj_smk bm_diff", bm_difference
+            !++++++ CHECK ++++++++++
+            ! The question still stands of which trees we kill with the
+            ! environmental mortality.  If we only kill the biggest, we
+            ! lose a circ class within the first year sometimes.
+            IF(bm_difference .GT. zero )THEN
+
+               ! We know the total biomass that we want to kill.  Let's partition 
+               ! this biomass among all our circumference classes based on an 
+               ! exponential distribution which takes more biomass from
+               ! the largest class than the smallest.  There is a chance that we
+               ! will not have enough biomass to kill in some classes, in which
+               ! case we need to rearrange it a bit.
+
+               IF(ld_kill .AND. ivm == test_pft .AND. ipts == test_grid)THEN
+                  WRITE(numout,*) 'Mortality is taking place.'
+                  WRITE(numout,*) 'ipts,ivm: ',ipts,ivm
+                  WRITE(numout,*) 'bm_difference: ',bm_difference
+                  WRITE(numout,*) 'circ_class_kill(ipts,ivm,:,ifm_none,icut_thin): ', &
+                    circ_class_kill(ipts,ivm,:,ifm_none,icut_thin)
+                   WRITE(numout,*) 'circ_class_n(ipts,ivm,:): ', &
+                    circ_class_n(ipts,ivm,:)
+               ENDIF
+
+
+               !CALL distribute_mortality_biomass( bm_difference, &
+               !     death_distribution_factor(ivm), circ_class_n(ipts,ivm,:), &
+               !     circ_class_biomass(ipts,ivm,:,:,icarbon), &
+               !     circ_class_kill(ipts,ivm,:,ifm_none,icut_thin) )
+               ! yang hui
+               ! commented by yitong yao to replace the routine for
+               ! circ_class_kill March 18 2020 23:41
+               !CALL distribute_mortality_biomass_yyt( bm_difference, &
+               !     death_distribution_factor(ivm), circ_class_n(ipts,ivm,:), &
+               !     circ_class_biomass(ipts,ivm,:,:,icarbon), &
+               !     circ_class_kill(ipts,ivm,:,ifm_none,icut_thin),circ_class_mor(ipts,ivm,:) )
+              !  yang hui 
+
+               IF(ld_kill .AND. ivm == test_pft .AND. ipts == test_grid)THEN
+                  WRITE(numout,*) 'after circ_class_kill(ipts,ivm,:,ifm_none,icut_thin): ', &
+                    circ_class_kill(ipts,ivm,:,ifm_none,icut_thin)
+                  WRITE(numout,*) 'circ_class_n(ipts,ivm,:): ', &
+                       circ_class_n(ipts,ivm,:)
+               ENDIF
+
+           ENDIF ! bm_difference .GT. zero 
+
+         ELSE ! IF(is_tree(ivm))
+
+            ! we don't seem to use self thinning for grasses, since grasses have
+            ! a constant density of 1/m**2.  This is the original code for the
+            ! mortality.  Notice that it doesn't actually do anything, due to
+            ! Sebastiaan's changes and CHECK statement, so I will leave it 
+            ! commented out for now.
+
+            ! one thing I will set is 
+            ! circ_class_kill(ipts,ivm,1,ifm_none,icut_thin) and
+            ! circ_class_biomass(:,:,1,:,:), since if we decide to
+            ! use grass/crop mortality later on we will use these variables
+            ! to tell lpj_gap how much biomass to actually kill.
+            circ_class_kill(ipts,ivm,1,ifm_none,icut_thin)=zero
+            !circ_class_biomass(ipts,ivm,1,:,:)=zero
+
+!!$             IF ( control%ok_dgvm .OR. .NOT.control%ok_constant_mortality) THEN
+!!$
+!!$                ! +++CHECK+++
+!!$                ! For grasses, if last year's NPP is very small (less than 10 gCm^{-2}year{-1})
+!!$                ! the grasses completely die. Grasses and crops are deciduous so in the first 
+!!$                ! year they have no leaves. Consequently npp_longterm is less then 
+!!$                ! ::npp_longterm_init. At the beginning of the second year when rue_longterm is
+!!$                ! no longer 1, the PFT is killed immediatly. The IF statement needs to be refined
+!!$                ! to properly allow for this type of PFT killing.
+!!$                ! The more fundamental and conceptual question is whether we want to kill grasses?
+!!$                ! Unless we simulate desertification, it is not clear why we would kill the grass
+!!$                ! most likely to replace it by ... grass. Because grass has hardly any biomass it
+!!$                ! seem unlikely that killing the grass will affect the C-fluxes.
+!!$                ! For both reasons i.e. the technical and conceptual, it was decided NOT to kill
+!!$                ! the grass PFTs 
+!!$                IF ( PFTpresent(ipts,ivm) .AND. ( npp_longterm(ipts,ivm) .LE. npp_longterm_init ) ) THEN
+!!$
+!!$                   ! ORIGINAL code - see above to justify the change
+!!$                   !!$mortality = un
+!!$                   mortality = zero
+!!$
+!!$                END IF
+!!$                ! +++++++++++
+!!$
+!!$                ! Update biomass and litter pools
+!!$                DO ielem = 1,nelements
+!!$
+!!$                   DO ipart = 1, nparts
+!!$
+!!$                      IF ( PFTpresent(ipts,ivm) ) THEN
+!!$
+!!$                         d_mortality(ipts,ivm) =  mortality * biomass(ipts,ivm,ipart,ielem)
+!!$                         bm_to_litter(ipts,ivm,ipart,ielem) = bm_to_litter(ipts,ivm,ipart,ielem) + &
+!!$                              d_mortality(ipts,ivm)
+!!$                         biomass(ipts,ivm,ipart,ielem) = biomass(ipts,ivm,ipart,ielem) - &
+!!$                              d_mortality(ipts,ivm)
+!!$
+!!$                      END IF ! PFTpresent(ipts,ivm)
+!!$
+!!$                   ENDDO ! nparts
+!!$
+!!$                END DO ! nelements
+!!$
+!!$             ENDIF ! .NOT.control%ok_dgvm .AND. .NOT.control%ok_constant_mortality
+
+         ENDIF ! end check for trees
+
+      ENDDO ! loop over grid points
+
+   ENDDO         ! loop over PFTs
+   
+    !DO icir=1,ncirc
+    !    write(*,*) 'circK_class_kill ',icir,' ',sum(sum(circ_class_kill(1,2,icir,:,:),dim=2),dim=1)
+    !ENDDO
+
+ !! 4. Check mass balance closure
+
+    !! 4.1 Calculate pools at the end of the routine
+    pool_end = zero
+    DO ipar = 1,nparts
+       DO iele = 1,nelements
+          pool_end(:,:,iele) = pool_end(:,:,iele) + &
+               (biomass(:,:,ipar,iele) * veget_max(:,:))
+       ENDDO
+    ENDDO
+
+    !! 4.2 Calculate components of the mass balance
+    check_intern(:,:,iatm2land,icarbon) = zero
+    check_intern(:,:,iland2atm,icarbon) = -un * zero
+    check_intern(:,:,ilat2out,icarbon) = zero
+    check_intern(:,:,ilat2in,icarbon) = -un * zero
+    check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - pool_start(:,:,icarbon))
+    closure_intern = zero
+    DO imbc = 1,nmbcomp
+       closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + check_intern(:,:,imbc,icarbon)
+    ENDDO
+
+    ! Write outcome
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          IF(ABS(closure_intern(ipts,ivm,icarbon)) .LE. min_stomate)THEN
+             IF (ld_massbal) WRITE(numout,*) 'Mass balance closure in kill_prognostic'
+          ELSE
+             WRITE(numout,*) 'Error: mass balance is not closed in kill_prognostic'
+             WRITE(numout,*) '   ipts,ivm; ', ipts,ivm
+             WRITE(numout,*) '   Difference is, ', closure_intern(ipts,ivm,icarbon)
+             WRITE(numout,*) '   pool_end,pool_start: ', pool_end(ipts,ivm,icarbon), pool_start(ipts,ivm,icarbon)
+             IF(ld_stop)THEN
+                CALL ipslerr_p (3,'kill_prognostic', 'Mass balance error.','','')
+             ENDIF
+          ENDIF
+       ENDDO
+    ENDDO
+    
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving kill_prognostic'
+
+ END SUBROUTINE kill_prognostic
+
+
+END MODULE stomate_mark_kill
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_phenology.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_phenology.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_phenology.f90	(revision 7236)
@@ -0,0 +1,2635 @@
+! =================================================================================================================================
+! MODULE        : stomate_phenology
+!
+! CONTACT       : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE       : IPSL (2006). This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        This module manages the beginning of the growing season (leaf onset).
+!!      
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! SVN          :
+!! $HeadURL$ 
+!! $Date$
+!! $Revision$
+!! \n
+!_ =================================================================================================================================
+
+MODULE stomate_phenology
+
+  ! modules used:
+
+  USE ioipsl_para
+  USE xios_orchidee
+  USE ioipsl_para
+  USE stomate_data
+  USE constantes
+  USE pft_parameters
+  USE sapiens_agriculture, ONLY: crop_planting
+  USE function_library, ONLY: wood_to_height_eff, calculate_c0_alloc
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC phenology_diagnostic, phenology_prognostic, phenology_clear
+
+  ! first call
+  LOGICAL, SAVE                                              :: firstcall = .TRUE.
+!$OMP THREADPRIVATE(firstcall)
+  LOGICAL, SAVE                                              :: firstcall_hum = .TRUE.
+!$OMP THREADPRIVATE(firstcall_hum)
+  LOGICAL, SAVE                                              :: firstcall_moi = .TRUE.
+!$OMP THREADPRIVATE(firstcall_moi)
+  LOGICAL, SAVE                                              :: firstcall_humgdd = .TRUE.
+!$OMP THREADPRIVATE(firstcall_humgdd)
+  LOGICAL, SAVE                                              :: firstcall_moigdd = .TRUE.
+!$OMP THREADPRIVATE(firstcall_moigdd)
+
+CONTAINS
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : phenology_clear
+!!
+!>\BRIEF          Flags setting   
+!!
+!! DESCRIPTION  : This subroutine sets flags 
+!!                ::firstcall, ::firstcall_hum, ::firstcall_moi, ::firstcall_humgdd, 
+!!                ::firstcall_moigdd to .TRUE., and therefore activates section 1.1 of each 
+!!                subroutine which writes messages to the output. \n
+!!                This subroutine is called at the beginning of ::stomateLpj_clear in the 
+!!                ::stomate_lpj module.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::firstcall, ::firstcall_hum, ::firstcall_moi, ::firstcall_humgdd, 
+!!                ::firstcall_moigdd
+!!
+!! REFERENCE(S)  : None
+!!
+!! FLOWCHART     : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE phenology_clear
+    firstcall=.TRUE.
+    firstcall_hum=.TRUE.
+    firstcall_moi = .TRUE.
+    firstcall_humgdd = .TRUE.
+    firstcall_moigdd = .TRUE.
+  END SUBROUTINE phenology_clear
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : phenology_diagnostic
+!!
+!>\BRIEF          This subroutine controls the detection of the beginning of the growing season 
+!!                (if dormancy has been long enough), leaf onset, given favourable biometeorological 
+!!                conditions, and leaf growth and biomass allocation when leaf biomass is low (i.e. 
+!!                at the start of the growing season.
+!!
+!! DESCRIPTION  : This subroutine is called by the module ::stomate_lpj and deals with the beginning of the  
+!!                growing season. First it is established whether the beginning of the growing season is
+!!                allowed. This occurs if the dormance period has been long enough (i.e. greater 
+!!                than a minimum PFT-dependent threshold, specified by ::lowgpp_time), 
+!!                AND if the last beginning of the growing season was a sufficiently long time ago 
+!!                (i.e. when the growing season length is greater than a minimum threshold, specified
+!!                by ::min_growthinit_time, which is defined in this module to be 300 days. \n
+!!                The dormancy time-length is represented by the variable 
+!!                ::time_lowgpp, which is calculated in ::stomate_season. It is increased by 
+!!                the stomate time step when the weekly GPP is lower than a threshold. Otherwise
+!!                it is set to zero. \n
+!!                ::lowgpp_time is set for each PFT in ::stomate_data from a table of all
+!!                PFT values (::lowgpp_time_tab), which is defined in ::stomate_constants. \n
+!!                The growing season length is given by ::when_growthinit, which increases
+!!                by the stomate time-step at each call to this phenology module, except for when
+!!                leaf onset is detected, when it is set to 0. \n
+!!                If these two conditions are met, leaf onset occurs if the biometeorological 
+!!                conditions are also met. This is determined by the leaf onset models, which are
+!!                biome-specific. Each PFT is looped over (ignoring bare soil).
+!!                The onset phenology model is selected, (according to the parameter 
+!!                ::pheno_model, which is initialised in stomate_data), and called. \n
+!!                There are six leaf onset phenology models currently being used by ORCHIDEE. 
+!!                These are: 'hum' and 'moi', which are based exclusively on moisture conditions,
+!!                'humgdd' and 'moigdd', which are based on both temperature and moisture conditions,
+!!                'ncdgdd', which is based on a "chilling" requirement for leaf onset, and 
+!!                'ngd', which is based on the number of growing days since the temperature was 
+!!                above a certain threshold, to account for the end of soil frost.
+!!                Those models which are based mostly on temperature conditions are used for
+!!                temperate and boreal biomes, and those which include a moisture condition are used
+!!                for tropical biomes. More detail on the biometeorological conditions is provided
+!!                in the sections on the individual onset models. \n
+!!                The moisture conditions are based on the concept of plant "moisture availability".
+!!                This is based on the soil humidity (relative soil moisture), but is moderated by
+!!                the root density profile, as per the equation:
+!!                \latexonly
+!!                \input{phenology_moiavail_eqn1.tex}
+!!                \endlatexonly
+!!                \n
+!!                Although some studies have shown that the length of the photoperiod is important
+!!                in determining onset (and senescence) dates, this is not considered in the current
+!!                versions of the onset models (Krinner et al., 2005). \n
+!!                If conditions are favourable, leaf onset occurs (::begin_leaves is set to TRUE), 
+!!                ::when_growthinit is set to 0.0, and the growing season has begun. \n
+!!                Following the detection of leaf onset, biomass is allocated from the carbohydrate 
+!!                reserves equally to the leaves and roots IF the leaf biomass is lower than a minimum
+!!                threshold, which is calculated in this subroutine from the parameter
+!!                ::lai_initmin, divided by the specific leaf area (both of which are
+!!                PFT-dependent and set in ::stomate_constants). \n
+!!                Finally, if biomass is required to be allocated from the carbohydrate reserve 
+!!                because the leaf biomass is too low, the leaf age and leaf age distribution is 
+!!                re-set. In this case the youngest age class fraction is set to 1 and all other   
+!!                leaf age class fractions are set to 0. All leaf ages are set to 0. If there is 
+!!                no biomass in the carbohydrate reserve, leaf onset will not occur and the PFT
+!!                will disappear from the grid cell (Krinner et al., 2005). \n
+!!                This subrouting is called in ::stomate_lpj.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::biomass, 
+!!                        ::when_growthinit,
+!!                        ::leaf age distribution
+!!                        ::leaf fraction
+!!
+!! REFERENCE(S) :
+!! - Krinner, G., N. Viovy, N. de Noblet-Ducoudre, J. Ogee, J. Polcher, P. 
+!! Friedlingstein, P. Ciais, S. Sitch and I.C. Prentice (2005), A dynamic global
+!! vegetation model for studies of the coupled atmosphere-biosphere system, Global
+!! Biogeochemical Cycles, 19, doi:10.1029/2003GB002199.
+!!
+!! FLOWCHART    : 
+!! \latexonly
+!! \includegraphics[scale = 1]{phenology_flowchart.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE phenology_diagnostic (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_hum_min, biomass, leaf_frac, &
+       leaf_age, when_growthinit, co2_to_bm)
+
+ !! 0. Variable and parameter declaration 
+
+    !! 0.1 Input variables
+   
+    INTEGER(i_std), INTENT(in)                                 :: npts                 !! Domain size - number of grid 
+                                                                                       !! cells (unitless) 
+    REAL(r_std), INTENT(in)                                    :: dt                   !! time step (dt_days)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                   :: PFTpresent           !! PFT exists (true/false)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: veget_max            !! "maximal" coverage fraction of a 
+                                                                                       !! PFT (LAI -> infinity) on ground 
+                                                                                       !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                   :: tlong_ref            !! "long term" 2 meter reference 
+                                                                                       !! temperatures (K) 
+    REAL(r_std), DIMENSION(npts), INTENT(in)                   :: t2m_month            !! "monthly" 2-meter temperatures 
+                                                                                       !! (K) 
+    REAL(r_std), DIMENSION(npts), INTENT(in)                   :: t2m_week             !! "weekly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: gpp                  !! daily gross primary productivity 
+                                                                                       !! @tex ($gC m^{-2} of 
+                                                                                       !! ground/day$) @endtex 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: maxmoiavail_lastyear !! last year's maximum moisture 
+                                                                                       !! availability (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: minmoiavail_lastyear !! last year's minimum moisture 
+                                                                                       !! availability (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: moiavail_month       !! "monthly" moisture availability 
+                                                                                       !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: moiavail_week        !! "weekly" moisture availability 
+                                                                                       !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: gdd_m5_dormance      !! growing degree days above a 
+                                                                                       !! threshold of -5 deg C (C) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: gdd_midwinter        !! growing degree days, since 
+                                                                                       !! midwinter (C) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: ncd_dormance         !! number of chilling days since 
+                                                                                       !! leaves were lost (days) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: ngd_minus5           !! number of growing days above a 
+                                                                                       !! threshold of -5 deg C (days) 
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                   :: senescence           !! is the plant senescent? (only 
+                                                                                       !! for deciduous trees - 
+                                                                                       !! carbohydrate reserve) 
+                                                                                       !! (true/false) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: time_hum_min         !! time elapsed since strongest 
+                                                                                       !! moisture availability (days) 
+
+    !
+    !! 0.2 Ouput variables 
+    !
+
+    !
+    !! 0.3 Modified variables
+    !
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                              INTENT(inout)    :: biomass              !! biomass @tex ($gC m^{-2} of 
+                                                                                                !! ground$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_frac            !! fraction of leaves in leaf age 
+                                                                                       !! class (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_age             !! leaf age (days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: when_growthinit      !! how many days since the 
+                                                                                       !! beginning of the growing season 
+                                                                                       !! (days) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: co2_to_bm            !! co2 taken up by carbohydrate 
+                                                                                       !! reserve at the beginning of the 
+                                                                                       !! growing season @tex ($gC m^{-2} 
+                                                                                       !! of total ground/day$) @endtex 
+
+    !! 0.4 Local variables
+    
+    LOGICAL, DIMENSION(npts,nvm)                               :: allow_initpheno      !! are we allowed to decalre the 
+                                                                                       !! beginning of the growing 
+                                                                                       !! season? (true/false)
+    LOGICAL(r_std), DIMENSION(npts)                            :: age_reset            !! does the leaf age distribution 
+                                                                                       !! have to be reset? (true/false) 
+    INTEGER(i_std)                                             :: i,j,k,l,m            !! indices (unitless) 
+    REAL(r_std), DIMENSION(npts)                               :: bm_wanted            !! biomass we would like to have 
+                                                                                       !! @tex ($gC m^{-2} of ground$) 
+                                                                                       !! @endtex 
+    REAL(r_std), DIMENSION(npts)                               :: bm_use               !! biomass we use (from 
+                                                                                       !! carbohydrate reserve or from 
+                                                                                       !! atmosphere) @tex ($gC m^{-2} of 
+                                                                                       !! ground$) @endtex
+    REAL(r_std), DIMENSION(npts)                               :: lm_min               !! minimum leaf mass @tex ($gC 
+                                                                                       !! m^{-2} of ground$) @endtex   
+    LOGICAL, DIMENSION(npts,nvm)                               :: begin_leaves         !! signal to start putting leaves 
+                                                                                       !! on (true/false) 
+    REAL(r_std), DIMENSION(npts,nvm)                           :: histvar              !! controls the history output 
+                                                                                       !! level - 0: nothing is written; 
+                                                                                       !! 10: everything is written 
+                                                                                       !! (0-10, unitless)    
+!_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering phenology'  
+
+ !! 2. first call
+    
+    !  output message giving the setting of the ::always_init
+    !  and ::min_growthinit_time parameters.
+
+    IF ( firstcall ) THEN
+
+       WRITE(numout,*) 'phenology:'
+
+       WRITE(numout,*) '   > take carbon from atmosphere if carbohydrate' // &
+            ' reserve too small (::always_init): ', always_init
+
+       WRITE(numout,*) '   > minimum time since last beginning of a growing' // &
+            ' season (d) (::min_growthinit_time): ', min_growthinit_time
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    
+ !! 3. Detection of the beginning of the growing season.
+
+    !! 3.1 Allow detection of the beginning of the growing season 
+    !      if dormance was long enough (i.e. when ::time_lowgpp, which is calculated in ::stomate_season, 
+    !      is above a certain PFT-dependent threshold, ::lowgpp_time, which is given in ::stomate_constants),
+    !      AND the last beginning of growing season was a sufficiently long time ago 
+    !      (i.e. when ::when_growthinit, which is calculated in this module, 
+    !      is greater than ::min_growthinit_time, which is declared at the beginning of this module).
+    !      If these conditions are met, allow_initpheno is set to TRUE. Each PFT is looped over
+    allow_initpheno(:,1) = .FALSE.
+    DO j = 2,nvm
+
+       WHERE ( 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_p (hist_id_stomate, 'ALLOW_INITPHENO', itime, histvar, npts*nvm, horipft_index)
+
+    !! 3.2 increase the ::when_growthinit counter, which gives the number of days since the beginning of the growing season.
+    !  Needed for allocation and for the detection of the beginning of the growing season.
+    when_growthinit(:,:) = when_growthinit(:,:) + dt
+
+
+ !! 4. Leaf onset
+
+    !  Check biometeorological conditions using the onset phenological models, 
+    !  which are different for each PFT group (i.e. grass versus tropical etc. 
+    !  See below for more detail on the different models and which PFTs use each model).
+    !  By default: phenology does not start (::begin_leaves set to FALSE).
+    begin_leaves(:,:) = .FALSE.
+
+    ! - The onset phenology model is selected, (according to the parameter ::pheno_model, 
+    ! which is initialised in stomate_data), and called.
+    ! Each PFT is looped over (ignoring bare soil). 
+    ! If conditions are favourable, begin_leaves is set to TRUE.
+    ! parameter used in all the differents models of phenology 
+    t_always = ZeroCelsius + t_always_add
+
+    DO j = 2,nvm ! Loop over # PFTs
+
+       SELECT CASE ( 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, ncd_dormance, &
+               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)',j
+          WRITE(numout,*) '  phenology model (::pheno_model(j)) : ',pheno_model(j)
+          STOP
+
+       END SELECT
+
+    ENDDO
+
+    WHERE(begin_leaves)
+
+       histvar=un
+
+    ELSEWHERE
+
+       histvar=zero
+
+    ENDWHERE
+
+    CALL histwrite_p (hist_id_stomate, 'BEGIN_LEAVES', itime, histvar, npts*nvm, horipft_index)
+
+ !! 5. Leaf growth and biomass allocation when leaf biomass is low.
+
+    !  Leaves start to grow if biometeorological conditions are favourable (::begin_leaves == TRUE) and if
+    !  leaf growth is allowed (::allow_initpheno == TRUE).
+    !  PFTs and then grid cells are looped over.
+    DO j = 2,nvm ! Loop over # PFTs
+
+       age_reset(:) = .FALSE.
+
+       DO i = 1, npts
+
+          IF ( begin_leaves(i,j) ) THEN
+
+             !! 5.1 First minimum biomass is calculated using the following equation:
+             !! \latexonly
+             !! \input{phenology_lm_min_eqn2.tex}
+             !! \endlatexonly
+             !! \n           
+             lm_min(i) = lai_initmin(j) / sla(j)
+     
+
+             ! If leaf biomass is lower than the minimum biomass then biomass must 
+             ! be allocated from the carbohydrate reserves to leaves and roots.
+             IF ( biomass(i,j,ileaf,icarbon) .LT. lm_min(i) ) THEN
+
+                ! Determine how much biomass is available to use
+                ! First calculate how much biomass is wanted/required 
+                ! (::bm_wanted = 2 x the minimum leaf biomass).
+                bm_wanted(i) = 2. * lm_min(i)
+
+                ! If the biomass in the carbohydrate reserves is less than the required biomass
+                ! take the required amount of carbon from the atmosphere and put it into the
+                ! carbohydrate reserve. This only occurs if the parameter ::always_init 
+                ! (set at beginning of this ::subroutine) is TRUE. Default is FALSE. 
+                IF ( always_init .AND. ( biomass(i,j,icarbres,icarbon) .LT. bm_wanted(i) ) ) THEN
+
+                   co2_to_bm(i,j) = co2_to_bm(i,j) + ( bm_wanted(i) - biomass(i,j,icarbres,icarbon) ) / dt
+                   biomass(i,j,icarbres,icarbon) = bm_wanted(i)
+
+                ENDIF
+
+                ! The biomass available to use is set to be the minimum of the biomass of 
+                ! the carbohydrate reservoir (if carbon not taken from the atmosphere), and 
+                ! the wanted biomass.
+                bm_use(i) = MIN( biomass(i,j,icarbres,icarbon), bm_wanted(i) )
+
+                ! Divide the biomass which is available to use equally between the leaves 
+                ! and roots.
+                biomass(i,j,ileaf,icarbon) = biomass(i,j,ileaf,icarbon) + bm_use(i) / 2.
+                biomass(i,j,iroot,icarbon) = biomass(i,j,iroot,icarbon) + bm_use(i) / 2.
+
+                ! Decrease carbohydrate reservoir biomass by the amount that's been allocated 
+                ! to the leaves and roots
+                biomass(i,j,icarbres,icarbon) = biomass(i,j,icarbres,icarbon) - bm_use(i)
+
+                ! set reset leaf age distribution (::age_reset) flag. Default is TRUE.
+                ! done later for better vectorization)
+                age_reset(i) = .TRUE.
+
+             ENDIF  ! leaf mass is very low
+
+             !! 5.2 reset when_growthinit counter: start of the growing season
+             when_growthinit(i,j) = zero
+
+          ENDIF    ! start of the growing season
+
+       ENDDO      ! loop over grid points
+
+       !! 5.3 reset leaf age distribution where necessary (i.e. when age_reset is TRUE)
+       !  simply say that everything is in the youngest age class
+       !  Set the youngest age class fraction to 1 and all other leaf age class fractions to 0.
+       WHERE ( age_reset(:) )
+
+             leaf_frac(:,j,1) = un
+
+          ENDWHERE
+
+          DO m = 2, nleafages
+
+             WHERE ( age_reset(:) )
+
+                leaf_frac(:,j,m) = zero
+
+             ENDWHERE
+
+          ENDDO ! nleafages
+
+          ! Ages - set all leaf ages to 0.
+          DO m = 1, nleafages
+
+             WHERE ( age_reset(:) )
+
+                leaf_age(:,j,m) = zero
+
+             ENDWHERE
+
+          ENDDO ! nleafages
+
+       ENDDO ! loop over # PFTs
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving phenology'
+
+  END SUBROUTINE phenology_diagnostic
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : phenology_prognostic
+!!
+!>\BRIEF          This subroutine controls the detection of the beginning of the growing season 
+!!                (if dormancy has been long enough), leaf onset, given favourable biometeorological 
+!!                conditions, and leaf growth and biomass allocation when leaf biomass is low (i.e. 
+!!                at the start of the growing season.
+!!
+!! DESCRIPTION  : This subroutine is called by the module ::stomate_lpj and deals with the beginning of the  
+!!                growing season. First it is established whether the beginning of the growing season is
+!!                allowed. This occurs if the dormance period has been long enough (i.e. greater 
+!!                than a minimum PFT-dependent threshold, specified by ::lowgpp_time), 
+!!                AND if the last beginning of the growing season was a sufficiently long time ago 
+!!                (i.e. when the growing season length is greater than a minimum threshold, specified
+!!                by ::min_growthinit_time, which is defined in this module to be 300 days. \n
+!!                The dormancy time-length is represented by the variable 
+!!                ::time_lowgpp, which is calculated in ::stomate_season. It is increased by 
+!!                the stomate time step when the weekly GPP is lower than a threshold. Otherwise
+!!                it is set to zero. \n
+!!                ::lowgpp_time is set for each PFT in ::stomate_data from a table of all
+!!                PFT values (::lowgpp_time_tab), which is defined in ::stomate_constants. \n
+!!                The growing season length is given by ::when_growthinit, which increases
+!!                by the stomate time-step at each call to this phenology module, except for when
+!!                leaf onset is detected, when it is set to 0. \n
+!!                If these two conditions are met, leaf onset occurs if the biometeorological 
+!!                conditions are also met. This is determined by the leaf onset models, which are
+!!                biome-specific. Each PFT is looped over (ignoring bare soil).
+!!                The onset phenology model is selected, (according to the parameter 
+!!                ::pheno_model, which is initialised in stomate_data), and called. \n
+!!                There are six leaf onset phenology models currently being used by ORCHIDEE. 
+!!                These are: 'hum' and 'moi', which are based exclusively on moisture conditions,
+!!                'humgdd' and 'moigdd', which are based on both temperature and moisture conditions,
+!!                'ncdgdd', which is based on a "chilling" requirement for leaf onset, and 
+!!                'ngd', which is based on the number of growing days since the temperature was 
+!!                above a certain threshold, to account for the end of soil frost.
+!!                Those models which are based mostly on temperature conditions are used for
+!!                temperate and boreal biomes, and those which include a moisture condition are used
+!!                for tropical biomes. More detail on the biometeorological conditions is provided
+!!                in the sections on the individual onset models. \n
+!!                The moisture conditions are based on the concept of plant "moisture availability".
+!!                This is based on the soil humidity (relative soil moisture), but is moderated by
+!!                the root density profile, as per the equation:
+!!                \latexonly
+!!                \input{phenology_moiavail_eqn1.tex}
+!!                \endlatexonly
+!!                \n
+!!                Although some studies have shown that the length of the photoperiod is important
+!!                in determining onset (and senescence) dates, this is not considered in the current
+!!                versions of the onset models (Krinner et al., 2005). \n
+!!                If conditions are favourable, leaf onset occurs (::begin_leaves is set to TRUE), 
+!!                ::when_growthinit is set to 0.0, and the growing season has begun. \n
+!!                Following the detection of leaf onset, biomass is allocated from the carbohydrate 
+!!                reserves equally to the leaves and roots IF the leaf biomass is lower than a minimum
+!!                threshold, which is calculated in this subroutine from the parameter
+!!                ::lai_initmin, divided by the specific leaf area (both of which are
+!!                PFT-dependent and set in ::stomate_constants). \n
+!!                Finally, if biomass is required to be allocated from the carbohydrate reserve 
+!!                because the leaf biomass is too low, the leaf age and leaf age distribution is 
+!!                re-set. In this case the youngest age class fraction is set to 1 and all other   
+!!                leaf age class fractions are set to 0. All leaf ages are set to 0. If there is 
+!!                no biomass in the carbohydrate reserve, leaf onset will not occur and the PFT
+!!                will disappear from the grid cell (Krinner et al., 2005). \n
+!!                This subrouting is called in ::stomate_lpj.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::biomass, 
+!!                        ::when_growthinit,
+!!                        ::leaf age distribution
+!!                        ::leaf fraction
+!!
+!! REFERENCE(S) :
+!! - Krinner, G., N. Viovy, N. de Noblet-Ducoudre, J. Ogee, J. Polcher, P. 
+!! Friedlingstein, P. Ciais, S. Sitch and I.C. Prentice (2005), A dynamic global
+!! vegetation model for studies of the coupled atmosphere-biosphere system, Global
+!! Biogeochemical Cycles, 19, doi:10.1029/2003GB002199.
+!!
+!! FLOWCHART    : 
+!! \latexonly
+!! \includegraphics[scale = 1]{phenology_flowchart.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE phenology_prognostic (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_hum_min, biomass, leaf_frac, &
+       leaf_age, when_growthinit, co2_to_bm, circ_class_n, &
+       circ_class_biomass, ind, KF, allow_initpheno, &
+       tau_eff_leaf, tau_eff_sap, tau_eff_root, age, &
+       everywhere, npp_longterm, lm_lastyearmax, k_latosa_adapt)
+
+   
+ !! 0. Variable and parameter declaration
+
+   
+    !! 0.1 Input variables
+  
+    INTEGER(i_std), INTENT(in)                         :: npts                 !! Domain size - number of grid cells (unitless) 
+    REAL(r_std), INTENT(in)                            :: dt                   !! time step (dt_days)
+    REAL(r_std), DIMENSION(:), INTENT(in)              :: tlong_ref            !! "long term" 2 meter reference temperatures (K) 
+    REAL(r_std), DIMENSION(:), INTENT(in)              :: t2m_month            !! "monthly" 2-meter temperatures (K) 
+    REAL(r_std), DIMENSION(:), INTENT(in)              :: t2m_week             !! "weekly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: veget_max            !! "maximal" coverage fraction of a 
+                                                                               !! PFT (LAI -> infinity) on ground 
+                                                                               !! (0-1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: gpp                  !! daily gross primary productivity 
+                                                                               !! @tex ($gC m^{-2} of 
+                                                                               !! ground/day$) @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: maxmoiavail_lastyear !! last year's maximum moisture 
+                                                                               !! availability (0-1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: minmoiavail_lastyear !! last year's minimum moisture 
+                                                                               !! availability (0-1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: moiavail_month       !! "monthly" moisture availability 
+                                                                               !! (0-1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: moiavail_week        !! "weekly" moisture availability 
+                                                                               !! (0-1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: gdd_m5_dormance      !! growing degree days above a 
+                                                                               !! threshold of -5 deg C (C) 
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: ncd_dormance         !! number of chilling days since 
+                                                                               !! leaves were lost (days) 
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: tau_eff_root         !! Effective root turnover time that accounts
+                                                                               !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: tau_eff_sap          !! Effective sapwood turnover time that accounts
+                                                                               !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)            :: tau_eff_leaf         !! Effective leaf turnover time that accounts
+                                                                               !! waterstress (days)
+
+    !! 0.2 Ouput variables
+    
+    LOGICAL, DIMENSION(:,:), INTENT(out)               :: allow_initpheno      !! are we allowed to declare the 
+                                                                               !! beginning of the growing season?
+                                                                               !!  and the end of senescence (true/false)
+   
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: gdd_midwinter        !! growing degree days, since midwinter (C) 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: when_growthinit      !! how many days since the 
+                                                                               !! beginning of the growing season (days) 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: co2_to_bm            !! co2 taken up by carbohydrate 
+                                                                               !! reserve at the beginning of the 
+                                                                               !! growing season @tex ($gC m^{-2} 
+                                                                               !! of total ground/day$) @endtex
+    LOGICAL, DIMENSION(:,:), INTENT(inout)             :: PFTpresent           !! PFT exists (true/false)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: ngd_minus5           !! number of growing days above a 
+                                                                               !! threshold of -5 deg C (days)
+    LOGICAL, DIMENSION(:,:), INTENT(inout)             :: senescence           !! is the plant senescent? (only 
+                                                                               !! for deciduous trees - 
+                                                                               !! carbohydrate reserve) (true/false)  
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: ind                  !! Stand level number of individuals
+                                                                               !! @tex $(ind m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: everywhere           !! is the PFT everywhere in the grid box or 
+                                                                               !! very localized (after its introduction) (?)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: time_hum_min         !! time elapsed since strongest 
+                                                                               !! moisture availability (days)
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)       :: circ_class_n         !! Number of individuals in each circ class
+                                                                               !! @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: KF                   !! Scaling factor to convert sapwood mass
+                                                                               !! into leaf mass (m)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: k_latosa_adapt       !! Leaf to sapwood area adapted for long 
+                                                                               !! term water stress (m)
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)       :: leaf_frac            !! fraction of leaves in leaf age 
+                                                                               !! class (0-1, unitless)
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)       :: leaf_age             !! leaf age (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: age                  !! mean age (years)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: npp_longterm         !! "long term" net primary productivity
+                                                                               !! @tex ($gC m^{-2} year^{-1}$) @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)         :: lm_lastyearmax       !! last year's maximum leaf mass for each PFT 
+                                                                               !! @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)     :: biomass              !! biomass @tex ($gC m^{-2} of 
+                                                                               !! ground$) @endtex
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout)   :: circ_class_biomass   !! Biomass components of the model tree  
+                                                                               !! within a circumference class
+                                                                               !! class @tex $(g C ind^{-1})$ @endtex
+    
+    !! 0.4 Local variables
+    
+    REAL(r_std), DIMENSION(npts,nvm)                   :: c0_alloc             !! Root to sapwood tradeoff parameter
+    LOGICAL(r_std), DIMENSION(npts)                    :: age_reset            !! does the leaf age distribution 
+                                                                               !! have to be reset? (true/false)
+    LOGICAL, DIMENSION(npts,nvm)                       :: begin_leaves         !! signal to start putting leaves 
+                                                                               !! on (true/false)
+    INTEGER(i_std)                                     :: i,j,k,l,m            !! indices (unitless)
+    INTEGER(i_std)                                     :: ipts, ivm, ipar      !! indices (unitless)
+    INTEGER(i_std)                                     :: imbc, iele           !! indices (unitless)
+    REAL(r_std)                                        :: deficit              !! Carbon that needs to be taken from the
+                                                                               !! labile and or reserve pools 
+                                                                               !! @tex $(gC m^{-2})$ @endtex     
+    REAL(r_std), DIMENSION(npts,nvm)                   :: LF                   !! Scaling factor to convert sapwood mass
+                                                                               !! into root mass (unitless)
+    REAL(r_std), DIMENSION(npts,nvm)                   :: histvar              !! controls the history output 
+                                                                               !! level - 0: nothing is written; 
+                                                                               !! 10: everything is written 
+                                                                               !! (0-10, unitless)
+!!$    REAL(r_std), DIMENSION(npts,nvm)                   :: lstress_fac          !! Light stress factor, based on total
+!!$                                                                               !! transmitted light (unitless, 0-1)
+    REAL(r_std)                                        :: bm_wanted            !! biomass we would like to have 
+                                                                               !! @tex ($gC m^{-2} of ground$) 
+                                                                               !! @endtex 
+    REAL(r_std)                                        :: bm_use               !! biomass we use (from 
+                                                                               !! carbohydrate reserve or from 
+                                                                               !! atmosphere) @tex ($gC m^{-2} of 
+                                                                               !! ground$) @endtex
+    REAL(r_std), DIMENSION(ncirc)                      :: Cl_tree              !! Individual plant, leaf compartment
+                                                                               !! @tex $(gC tree^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                      :: Cr_tree              !! Individual plant, root compartment
+                                                                               !! @tex $(gC tree^{-1})$ @endtex
+    REAL(r_std), DIMENSION(ncirc)                      :: Cs_tree              !! Individual plant, sapwood compartment
+                                                                               !! @tex $(gC. tree^{-1})$ @endtex
+    REAL(r_std)                                        :: Cs_grass             !! Individual plant, sapwood compartment
+                                                                               !! @tex $(gC. ind^{-1})$ @endtex
+    REAL(r_std)                                        :: Cl_init              !! Initial leaf carbon required to start
+                                                                               !! the growing season
+                                                                               !! @tex $(gC tree^{-1})$ @endtex
+    REAL(r_std)                                        :: Cr_init              !! Initial root carbon required to start
+                                                                               !! the growing season
+                                                                               !! @tex $(gC tree^{-1})$ @endtex
+    REAL(r_std)                                        :: lm_min               !! minimum leaf mass @tex ($gC 
+                                                                               !! m^{-2} of ground$) @endtex 
+    REAL(r_std), DIMENSION(npts,nvm,ncirc)             :: height_eff           !! Effective tree height calculated from allometric 
+                                                                               !! relationships (m) but total biomass (for
+                                                                               !! allocation calculations)
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements) :: check_intern         !! Contains the components of the internal
+                                                                               !! mass balance chech for this routine
+                                                                               !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)         :: closure_intern       !! Check closure of internal mass balance
+                                                                               !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)         :: pool_start           !! Start and end pool of this routine 
+                                                                               !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)         :: pool_end             !! Start and end pool of this routine 
+                                                                               !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std)                                        :: temp_total_biomass   !! Total biomass of a PFT/grid
+                                                                               !! @tex $(gC m^{-2}$) @endtex 
+    REAL(r_std)                                        :: temp_class_biomass   !! Total biomass of a circ_class
+                                                                               !! @tex $(gC m^{-2}$) @endtex
+    REAL(r_std)                                        :: temp_share           !! A weighting factor based on the biomass in a 
+                                                                               !! circ class @tex - @endtex
+    REAL(r_std)                                        :: bm_use_circ          !! biomass we use for a given circ class  
+                                                                               !! $) @endtex
+!_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering phenology'
+  
+ !! 1. Write current values to history file
+
+       ! Current values for ::when_growthinit 
+       CALL xios_orchidee_send_field("WHEN_GROWTHINIT",when_growthinit)
+       CALL histwrite_p (hist_id_stomate, 'WHEN_GROWTHINIT', itime, when_growthinit, npts*nvm, horipft_index)
+
+       ! Set and write values for ::PFTpresent
+       WHERE(PFTpresent)
+          histvar=un
+       ELSEWHERE
+          histvar=zero
+       ENDWHERE
+       CALL xios_orchidee_send_field("PFTPRESENT",histvar)
+       CALL histwrite_p (hist_id_stomate, 'PFTPRESENT', itime, histvar, npts*nvm, horipft_index)
+
+       ! Set and write values for gdd_midwinter
+       WHERE(gdd_midwinter.EQ.undef)
+          histvar=val_exp
+       ELSEWHERE
+          histvar=gdd_midwinter
+       ENDWHERE
+       CALL xios_orchidee_send_field("GDD_MIDWINTER",histvar)
+       CALL histwrite_p (hist_id_stomate, 'GDD_MIDWINTER', itime, histvar, npts*nvm, horipft_index)
+
+       ! Set and write values for gdd_m5_dormance
+       WHERE(gdd_m5_dormance.EQ.undef)
+          histvar=val_exp
+       ELSEWHERE
+          histvar=gdd_m5_dormance
+       ENDWHERE
+       CALL xios_orchidee_send_field('GDD_M5_DORMANCE',histvar)
+       CALL histwrite_p (hist_id_stomate, 'GDD_M5_DORMANCE', itime, histvar, npts*nvm, horipft_index)
+
+       ! Set and write values for ncd_dormance
+       WHERE(ncd_dormance.EQ.undef)
+          histvar=val_exp
+       ELSEWHERE
+          histvar=ncd_dormance
+       ENDWHERE
+       CALL xios_orchidee_send_field("NCD_DORMANCE",histvar)
+       CALL histwrite_p (hist_id_stomate, 'NCD_DORMANCE', itime, histvar, npts*nvm, horipft_index)
+
+  
+ !! 2. first call
+
+    !! 2.1 Initialize check for mass balance closure
+    !  The mass balance is calculated at the end of this routine
+    !  in section 6
+    !  Initial biomass pool
+    pool_start(:,:,:) = zero
+    DO ipar = 1,nparts
+       DO iele = 1,nelements
+          pool_start(:,:,iele) = pool_start(:,:,iele) + &
+               (biomass(:,:,ipar,iele) * veget_max(:,:))
+       ENDDO
+    ENDDO
+
+    ! co2_to_bm is defined as intent inout, the variable accumulates
+    ! carbon over the course of a day. Use the difference between
+    ! start and the end of this routine
+    check_intern(:,:,iatm2land,icarbon) = - un * co2_to_bm(:,:) * veget_max(:,:) * dt
+
+    !! 2.2 Output messages 
+    !  giving the setting of the ::always_init
+    !  and ::min_growthinit_time parameters.
+    IF ( firstcall ) THEN
+
+       WRITE(numout,*) 'phenology:'
+       WRITE(numout,*) '   > take carbon from atmosphere if carbohydrate' // &
+            ' reserve too small (::always_init): ', always_init
+       WRITE(numout,*) '   > minimum time since last beginning of a growing' // &
+            ' season (d) (::min_growthinit_time): ', min_growthinit_time
+       firstcall = .FALSE.
+
+    ENDIF
+
+   
+ !! 3. Detection of the beginning of the growing season 
+
+    !! 3.1 allow detection of the beginning of the growing season if dormance was
+    !  long enough (i.e. when ::time_lowgpp, which is calculated in ::stomate_season, 
+    !  is above a certain PFT-dependent threshold, ::lowgpp_time, 
+    !  which is given in ::stomate_constants),
+    !  AND the last beginning of growing season was a sufficiently long time ago 
+    !  (i.e. when ::when_growthinit, which is calculated in this module, 
+    !  is greater than ::min_growthinit_time, which is declared at the beginning of this module).
+    !  If these conditions are met, allow_initpheno is set to TRUE. Each PFT is looped over.
+    allow_initpheno(:,1) = .FALSE.
+
+    DO j = 2,nvm
+
+       WHERE ( when_growthinit(:,j) .GT. min_growthinit_time )
+
+          ! Change the values of ::allow_initpheno and ::senescence
+          allow_initpheno(:,j) = .TRUE.
+          senescence (:,j) = .FALSE.
+
+       ELSEWHERE
+
+          ! Keep the values of ::allow_initpheno and ::senescence
+          allow_initpheno(:,j) = .FALSE.
+
+       ENDWHERE
+
+    ENDDO
+
+    !+++TEMP+++
+    ! SHORT CIRCUIT phenology
+!!$    IF ( firstcall ) THEN
+!!$       allow_initpheno(:,j) = .TRUE.
+!!$    ENDIF
+    !++++++++++++
+
+    WHERE(allow_initpheno)
+
+       histvar=un
+
+    ELSEWHERE
+
+       histvar=zero
+
+    ENDWHERE
+
+    CALL histwrite_p (hist_id_stomate, 'ALLOW_INITPHENO', itime, histvar, npts*nvm, horipft_index)
+
+    
+    !! 3.2 increase the ::when_growthinit counter, which gives the number of days since the beginning 
+    !  of the growing season.
+    !  Needed for allocation and for the detection of the beginning of the growing season.
+    when_growthinit(:,:) = when_growthinit(:,:) + dt
+
+    ! Keep when_wrowthinit undefined for bare soil
+    when_growthinit(:,1) = undef
+
+   
+ !! 4. Leaf onset
+
+    !    Check biometeorological conditions using the onset phenological models, 
+    !    which are different for each PFT group (i.e. grass versus tropical etc. 
+    !    See below for more detail on the different models and which PFTs use each model).
+    !    - By default: phenology does not start (::begin_leaves set to FALSE).
+    begin_leaves(:,:) = .FALSE.
+
+    ! - The onset phenology model is selected, (according to the parameter ::pheno_model, 
+    ! which is initialised in stomate_data), and called.
+    ! Each PFT is looped over (ignoring bare soil). 
+    ! If conditions are favourable, begin_leaves is set to TRUE.
+    ! parameter used in all the differents models of phenology 
+    t_always = ZeroCelsius + t_always_add
+
+    DO j = 2,nvm ! Loop over # PFTs
+
+       SELECT CASE ( 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, ncd_dormance, &
+               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)',j
+          WRITE(numout,*) ' phenology model (::pheno_model(j)) : ',pheno_model(j)
+          STOP
+
+       END SELECT
+
+    ENDDO
+
+
+    WHERE(begin_leaves)
+
+       histvar=un
+
+    ELSEWHERE
+
+       histvar=zero
+
+    ENDWHERE
+
+    CALL histwrite_p (hist_id_stomate, 'BEGIN_LEAVES', itime, histvar, npts*nvm, horipft_index)
+
+    !+++TEMP+++
+!!$    ! SHORT CIRCUIT phenology
+!!$    IF ( firstcall ) THEN
+!!$       begin_leaves(:,:) = .TRUE.
+!!$       WRITE(numout,*) 'begin leaves, ', begin_leaves(:,:)
+!!$       ! when deleting this line remember to uncomment the firstcall above 
+!!$       firstcall = .FALSE.
+!!$    ENDIF
+    !++++++++++++
+ 
+
+ !! 5. Leaf growth and biomass allocation when leaf biomass is low.
+
+    !  Leaves start to grow if biometeorological conditions are 
+    !  favourable (::begin_leaves == TRUE) and if
+    !  leaf growth is allowed (::allow_initpheno == TRUE).
+    !  PFTs and then grid cells are looped over.
+    DO j = 2,nvm ! Loop over # PFTs
+
+       age_reset(:) = .FALSE.
+       bm_use = zero
+       bm_wanted = zero
+
+       DO i = 1,npts
+
+          ! We might need the c0_alloc factor, so let's
+          ! calculate it now.
+          c0_alloc(i,j)=calculate_c0_alloc(i, j, tau_eff_root(i,j), &
+               tau_eff_sap(i,j))
+
+          IF ( begin_leaves(i,j) ) THEN
+
+             !! 4.1 First minimum biomass is calculated using the following equation:
+             !  \latexonly
+             !  \input{phenology_lm_min_eqn2.tex}
+             !  \endlatexonly
+             !  \n  
+             lm_min = lai_initmin(j) / sla(j)
+               
+             ! The minimum leaf biomass is prescribed by ::lm_min which in turn
+             ! is basically prescribed through ::lai_initmin. However, lm_min could exceed
+             ! the leaf mass that is required to respect the allometric relationships
+             ! therefore this leaf biomass should be calculated
+
+             ! Calculate the allocation factors see stomate_prsecribe.f90 and
+             ! stomate_prescribe.f90 for more details 
+             LF(i,j) = c0_alloc(i,j) * KF(i,j)
+
+             IF ( is_tree(j) ) THEN
+
+                ! Calculate the stand structure (gC tree-1)
+                Cs_tree(:) = ( circ_class_biomass(i,j,:,isapabove,icarbon) + &
+                     circ_class_biomass(i,j,:,isapbelow,icarbon) )
+                height_eff(i,j,:) = wood_to_height_eff(circ_class_biomass(i,j,:,:,icarbon),j)
+
+                ! Calculate the leaves and roots that need to be grown. See 
+                ! stomate_growth_fun_alloc.f90 for more details 
+                ! Note that the units for Cl_init and Cr_init are gC m-2
+                Cl_init = MAX(zero, MIN( lm_min, SUM( (KF(i,j) * Cs_tree(:) / height_eff(i,j,:) - &
+                     circ_class_biomass(i,j,:,ileaf,icarbon)) * circ_class_n(i,j,:) ) ) )
+                Cr_init = MAX(zero, (biomass(i,j,ileaf,icarbon) + Cl_init) / LF(i,j) - &
+                     biomass(i,j,iroot,icarbon) )
+                
+
+             ! Grasses
+             ! Only used when grasses are described as a mixed phenology
+             ! in the DOFOCO branch grasses are simulated as an evergreen
+             ! biome
+             ELSEIF (.NOT. is_tree(j) .AND. natural(j) ) THEN
+
+                ! Calculate the available biomass in sapwood (gC m-2)
+                Cs_grass = biomass(i,j,isapabove,icarbon)
+
+                ! Calculate structure of the crop/grassland i.e. the leaves and roots 
+                ! that need to be grown see stomate_growth_fun_alloc.f90 for more details 
+                ! Note that the units for Cl_init and Cr_init are gC m-2. For grasses
+                ! :: heigh_init(j) is the minimal height_eff and is therefore used at the start of 
+                ! growing season (it could be considered the height_eff of Cs)
+                Cl_init = MAX(zero, MAX( lm_min, Cs_grass * KF(i,j) - &
+                     biomass(i,j,ileaf,icarbon) ) )
+                Cr_init = MAX(zero, (biomass(i,j,ileaf,icarbon) + Cl_init) / LF(i,j) - &
+                     biomass(i,j,iroot,icarbon))
+
+                !+++TEMP+++
+                IF (j.EQ.test_pft .AND. ld_pheno) THEN
+                   WRITE(numout,*) 'Cs_grass, ', biomass(i,j,isapabove,icarbon)
+                   WRITE(numout,*) 'Cl_init', lm_min, biomass(i,j,ileaf,icarbon), Cs_grass * KF(i,j) - &
+                     biomass(i,j,ileaf,icarbon)
+                   WRITE(numout,*) 'Cr_init, ', biomass(i,j,ileaf,icarbon), Cl_init, LF(i,j), biomass(i,j,iroot,icarbon), &
+                     (biomass(i,j,ileaf,icarbon) + Cl_init) / LF(i,j) - &
+                     biomass(i,j,iroot,icarbon)   
+                ENDIF
+                !++++++++++
+
+             ENDIF
+
+             ! Finalize trees and grasslands which are both considered to be natural.
+             ! Because grasses and trees live on during dormance they will consume
+             ! reserves and turnover may continue. There is no guarantee that the 
+             ! required amounts of C for phenology are present and can be used. This
+             ! is now being checked.
+             IF ( natural(j) ) THEN
+
+                ! If leaf biomass is lower than the minimum biomass then biomass must 
+                ! be allocated from the labile pool to leaves and roots.
+                IF ( biomass(i,j,ileaf,icarbon) .LT. Cl_init ) THEN
+
+                   ! First calculate how much biomass is wanted/required 
+                   bm_wanted = Cl_init + Cr_init
+
+                   ! Specific setting for forced phenology
+                   ! If the biomass in the carbohydrate reserves is less than the required biomass
+                   ! take the required amount of carbon from the atmosphere and put it into the
+                   ! labile pool. This only occurs if the parameter ::always_init 
+                   ! (set at beginning of this ::subroutine) is TRUE. Default is FALSE. 
+                   IF ( always_init .AND. ( biomass(i,j,ilabile,icarbon) .LT. bm_wanted ) ) THEN
+
+                      co2_to_bm(i,j) = co2_to_bm(i,j) + ( bm_wanted - biomass(i,j,ilabile,icarbon) ) / dt
+                      biomass(i,j,ilabile,icarbon) = biomass(i,j,ilabile,icarbon) + bm_wanted
+
+                   ENDIF
+
+                   ! The biomass available to use is set to be the minimum of the biomass of 
+                   ! the labile pool (if carbon not taken from the atmosphere), and 
+                   ! the wanted biomass. Convert biomass to gc tree-1 so the allometric
+                   ! relationships can be applied
+                   bm_use = MIN( biomass(i,j,ilabile,icarbon) + biomass(i,j,icarbres,icarbon), &
+                        bm_wanted ) / ind(i,j)
+
+                   ! This bm_use is for the whole stand.  We need to determine how much
+                   ! to distribute for each circ class.  We do this based on the 
+                   ! allometry for each circ class.
+                   ! Total biomass across parts and circumference classes
+                   temp_total_biomass = zero
+
+                   DO l = 1,ncirc 
+
+                      DO k = 1,nparts
+
+                         temp_total_biomass = temp_total_biomass + &
+                              circ_class_biomass(i,j,l,k,icarbon) * circ_class_n(i,j,l)
+
+                      ENDDO
+
+                   ENDDO
+
+                   ! zero the root and leaf biomass pools, since we'll sync them
+                   ! to circ_class_biomass.  Do the same for the labile and
+                   ! the reserve pools
+                   biomass(i,j,ileaf,icarbon) = zero
+                   biomass(i,j,iroot,icarbon) = zero
+                   biomass(i,j,icarbres,icarbon) = zero
+                   biomass(i,j,ilabile,icarbon) = zero
+
+                   DO l=1,ncirc
+
+                      temp_class_biomass = zero
+
+                      DO k = 1,nparts
+
+                         temp_class_biomass = temp_class_biomass + &
+                              circ_class_biomass(i,j,l,k,icarbon) * circ_class_n(i,j,l)
+
+                      ENDDO
+
+                      ! If there is no biomass in this circ class, we'll skip it
+                      ! This should ALWAYS be the case for ncirc > 1 for grasses.
+                      IF (temp_total_biomass .EQ. zero) CYCLE
+
+                      ! Share of this circumference class to the total biomass                      
+                      temp_share = temp_class_biomass / temp_total_biomass
+
+                      bm_use_circ = bm_use * temp_share 
+
+                      ! bm_use_circ is g C / tree for this circumference class. These
+                      ! are the exact same units as circ_class_biomass.
+
+                      ! bm_use may differ from Cr_init and Cl_init, the final allocation will depend 
+                      ! on bm_use. Distribute bm_use over leaves and roots following allometric 
+                      ! relationships. Cl_init and Cr_init take the same units as bm_use 
+                      ! i.e. gC tree-1
+                      ! (i) bm_use = Cl_incp + Cr_incp
+                      ! (ii) Cr_incp = (Cl_incp+Cl)/LF - Cr
+                      ! Substitue (ii) in (i) and solve for Cl_inc
+                      ! <=> Cl_incp = (LF*(b_incp+Cr)-Cl)/(1+LF)
+                      ! Because this is the start of the growing season, Cr = Cl = 0
+                      Cl_init = ((LF(i,j) * bm_use_circ) - circ_class_biomass(i,j,l,ileaf,icarbon)) &
+                           / (un + LF(i,j)) 
+                      Cr_init = (Cl_init + circ_class_biomass(i,j,l,ileaf,icarbon)) / LF(i,j)
+
+                      ! the sum of Cl_init and Cr_init should equal bm_use_circ 
+                      IF (bm_use_circ - Cl_init - Cr_init .LT. -min_stomate .OR. &
+                           bm_use_circ - Cl_init - Cr_init .GT. min_stomate) THEN
+                         WRITE(numout,*) 'over or underspening in phenology, ', &
+                              bm_use_circ - Cl_init - Cr_init
+                         STOP
+                      ENDIF
+
+                      ! Decrease labile pool biomass by the amount that's been allocated 
+                      ! to the leaves and roots. If the labile pool is depleted use carbon
+                      ! from the reserve pool. 
+                      deficit = bm_use_circ - circ_class_biomass(i,j,l,ilabile,icarbon)
+
+                      ! There is enough carbon in the labile pool
+                      IF (deficit .LT. zero) THEN
+
+                         circ_class_biomass(i,j,l,ilabile,icarbon) = &
+                              circ_class_biomass(i,j,l,ilabile,icarbon) - bm_use_circ 
+
+                         ! Deplete the labile pool, use the reserve pool
+                      ELSE
+
+                         circ_class_biomass(i,j,l,ilabile,icarbon) = zero
+                         circ_class_biomass(i,j,l,icarbres,icarbon) = &
+                              circ_class_biomass(i,j,l,icarbres,icarbon) - deficit
+
+                      ENDIF
+
+                      ! Distribute the biomass over the leaves and roots (gC tree-1)
+                      ! Since this whole loop is already over circ class, Cl_init and
+                      ! Cr_init are exactly what we need.
+                      circ_class_biomass(i,j,l,ileaf,icarbon) = &
+                           circ_class_biomass(i,j,l,ileaf,icarbon) + &
+                           Cl_init 
+                      circ_class_biomass(i,j,l,iroot,icarbon) = &
+                           circ_class_biomass(i,j,l,iroot,icarbon) + &
+                           Cr_init 
+
+                      ! Here we sync the biomass
+                      biomass(i,j,ileaf,icarbon) = biomass(i,j,ileaf,icarbon) + &
+                           circ_class_biomass(i,j,l,ileaf,icarbon) * circ_class_n(i,j,l)
+                      biomass(i,j,iroot,icarbon) = biomass(i,j,iroot,icarbon) + &
+                           circ_class_biomass(i,j,l,iroot,icarbon) * circ_class_n(i,j,l)
+                      biomass(i,j,icarbres,icarbon) = biomass(i,j,icarbres,icarbon) + &
+                           circ_class_biomass(i,j,l,icarbres,icarbon) * circ_class_n(i,j,l)
+                      biomass(i,j,ilabile,icarbon) = biomass(i,j,ilabile,icarbon) + &
+                           circ_class_biomass(i,j,l,ilabile,icarbon) * circ_class_n(i,j,l)
+
+                   ENDDO
+
+                   ! set reset leaf age distribution (::age_reset) flag. Default is TRUE.
+                   ! done later for better vectorization)
+                   age_reset(i) = .TRUE.
+
+                ! Leaf mass is high enough
+                ELSE  
+                   
+                   ! Nothing should be done because the minimum amount of leaves
+                   ! to start the growing season is present.
+                   
+                ENDIF ! leaf mass is very low
+
+                !! Reset when_growthinit counter: start of the growing season
+                when_growthinit(i,j) = zero
+                senescence(i,j) = .FALSE.
+
+             ELSEIF ( .NOT. natural(j) ) THEN
+                
+                ! Crops get planted the day that begin_leaves is true. If not, too 
+                ! much of there reserves are used before the start of the growing
+                ! season.
+                CALL crop_planting(npts, dt, i, j, &
+                     veget_max, PFTpresent, c0_alloc, when_growthinit, &
+                     time_hum_min, everywhere, senescence, ind, &
+                     circ_class_n, KF, leaf_frac, age, &
+                     npp_longterm, lm_lastyearmax, biomass, circ_class_biomass, &
+                     co2_to_bm, k_latosa_adapt)
+                
+             ELSE
+                   
+                CALL ipslerr_p (3,'stomate_phenology', 'Begin_leaves is true but case is undefined','','')
+                   
+             END IF
+
+             !---TEMP---
+             IF (j.EQ.test_pft .AND. ld_pheno) THEN
+                WRITE(numout,*) 'circ_class_biomass, ',SUM(circ_class_biomass(i,test_pft,:,:,icarbon))
+             ENDIF
+             !----------
+            
+         ENDIF    ! start of the growing season
+         
+      ENDDO      ! loop over grid point
+      
+      !! 5.4 reset leaf age distribution where necessary (i.e. when age_reset is TRUE)
+      !  simply say that everything is in the youngest age class
+      ! Set the youngest age class fraction to 1 and all other leaf age class fractions to 0.
+      WHERE ( age_reset(:) )
+         
+         leaf_frac(:,j,1) = un
+         
+      ENDWHERE
+      
+      DO m = 2, nleafages
+         
+         WHERE ( age_reset(:) )
+            
+            leaf_frac(:,j,m) = zero
+
+         ENDWHERE
+         
+      ENDDO ! nleafages
+
+      ! Ages - set all leaf ages to 0.
+      DO m = 1, nleafages
+
+         WHERE ( age_reset(:) )
+            
+            leaf_age(:,j,m) = zero
+            
+         ENDWHERE
+         
+      ENDDO ! nleafages
+      
+   ENDDO ! loop over # PFTs
+   
+!! 6. Check mass balance closure
+
+   !! 6.1 Calculate final biomass
+   pool_end(:,:,:) = zero 
+   DO ipar = 1,nparts
+      DO iele = 1,nelements
+         pool_end(:,:,iele) = pool_end(:,:,iele) + &
+              (biomass(:,:,ipar,iele) * veget_max(:,:))
+      ENDDO
+   ENDDO
+   
+   !! 6.2 Calculate mass balance
+   check_intern(:,:,iatm2land,icarbon) = check_intern(:,:,iatm2land,icarbon) + &
+        co2_to_bm(:,:) * veget_max(:,:) * dt
+   check_intern(:,:,iland2atm,icarbon) = -un * zero
+   check_intern(:,:,ilat2out,icarbon) = zero
+   check_intern(:,:,ilat2in,icarbon) = -un * zero
+   check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - pool_start(:,:,icarbon))
+   closure_intern = zero
+   DO imbc = 1,nmbcomp
+      closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + check_intern(:,:,imbc,icarbon)
+   ENDDO
+   
+   ! Write the verdict
+   DO ipts=1,npts
+      DO ivm=1,nvm
+         IF(ABS(closure_intern(ipts,ivm,icarbon)) .LE. min_stomate)THEN
+            IF (ld_massbal) WRITE(numout,*) 'Mass balance closure in phenology_prognostic'
+         ELSE
+            WRITE(numout,*) 'Error: mass balance is not closed in phenology_prognostic'
+            WRITE(numout,*) '   ipts,ivm; ', ipts,ivm
+            WRITE(numout,*) '   Difference is, ', closure_intern(ipts,ivm,icarbon)
+            WRITE(numout,*) '   pool_end,pool_start: ', pool_end(ipts,ivm,icarbon), pool_start(ipts,ivm,icarbon)
+            WRITE(numout,*) '   check_intern,co2_to_bm,veget_max: ', &
+                 check_intern(ipts,ivm,iatm2land,icarbon),co2_to_bm(ipts,ivm), veget_max(ipts,ivm)
+            IF(ld_stop)THEN
+               CALL ipslerr_p (3,'phenology_prognostic', 'Mass balance error.','','')
+            ENDIF
+         ENDIF
+      ENDDO
+   ENDDO
+   
+   IF (bavard.GE.2) WRITE(numout,*) 'Leaving phenology'
+   
+ END SUBROUTINE phenology_prognostic
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : pheno_hum 
+!!
+!>\BRIEF          The 'hum' onset model initiate leaf onset based exclusively on moisture 
+!!                availability criteria. 
+!!                Currently no PFTs are assigned to this onset model.
+!!
+!! DESCRIPTION  : This model is for tropical biomes, where temperatures are high but moisture
+!!                might be a limiting factor on growth. It is based on leaf onset model 4a in 
+!!                Botta et al. (2000), which adopts the approach of Le Roux (1995). \n
+!!                Leaf onset occurs if the monthly moisture availability is still quite
+!!                low (i.e. lower than the weekly availability), but the weekly availability is 
+!!                higher than the critical threshold ::availability_crit (as it reacts faster), 
+!!                which indicates the weekly moisture availability is increasing.
+!!                OR if the monthly moisture availability is high enough (i.e. above the 
+!!                threshold value ::moiavail_always), leaf onset is initiated if this has not 
+!!                already happened. This allows vegetation in arid areas to respond to rapidly
+!!                changing soil moisture conditions (Krinner et al., 2005). \n
+!!                The critical weekly moisture availability threshold (::availability_crit), is
+!!                calculated in this subroutine, and is a function of last year's maximum and
+!!                minimum moisture availability and the PFT-dependent parameter
+!!                ::hum_frac, which specifies how much of last year's available 
+!!                moisture is required for leaf onset, as per the equation:
+!!                \latexonly
+!!                \input{phenology_moi_availcrit_eqn3.tex}
+!!                \endlatexonly
+!!                \n
+!!                ::hum_frac is set for each PFT in ::stomate_data from a table
+!!                which contains all the PFT values (::hum_frac_tab) in ::stomate_constants. \n
+!!                Last year's maximum and minimum moisture availability and the monthly and 
+!!                weekly moisture availability are  
+!!                The ::pheno_hum subroutine is called in the subroutine ::phenology. 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::begin_leaves - specifies whether leaf growth can start.
+!!
+!! REFERENCE(S) : 
+!! - Botta, A., N. Viovy, P. Ciais, P. Friedlingstein and P. Monfray (2000), 
+!! A global prognostic scheme of leaf onset using satellite data,
+!! Global Change Biology, 207, 337-347.
+!! - Le Roux, X. (1995), Etude et modelisation des echanges d'eau et d'energie
+!! sol-vegetation-atmosphere dans une savane humide, PhD Thesis, University
+!! Pierre et Marie Curie, Paris, France.
+!! - Krinner, G., N. Viovy, N. de Noblet-Ducoudre, J. Ogee, J. Polcher, P. 
+!! Friedlingstein, P. Ciais, S. Sitch and I.C. Prentice (2005), A dynamic global
+!! vegetation model for studies of the coupled atmosphere-biosphere system, Global
+!! Biogeochemical Cycles, 19, doi:10.1029/2003GB002199.
+!!
+!! FLOWCHART    : 
+!! \latexonly
+!! \includegraphics[scale = 1]{pheno_hum.png}
+!! \endlatexonly
+!! \n             
+!_ ================================================================================================================================
+
+  SUBROUTINE pheno_hum (npts, j, PFTpresent, allow_initpheno, &
+       moiavail_month, moiavail_week, &
+       maxmoiavail_lastyear, minmoiavail_lastyear, &
+       begin_leaves)
+
+    !
+    !! 0. Variable and parameter declarations
+    !
+
+    !
+    !! 0.1 Input variables
+    !
+    INTEGER(i_std), INTENT(in)                                             :: npts                  !! Domain size - number of 
+                                                                                                    !! grid cells (unitless) 
+    INTEGER(i_std), INTENT(in)                                             :: j                     !! PFT index (unitless)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                               :: PFTpresent            !! PFT exists (true/false)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                               :: allow_initpheno       !! are we allowed to 
+                                                                                                    !! declare the beginning of 
+                                                                                                    !! the growing season? 
+                                                                                                    !! (true/false) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                           :: moiavail_month        !! "monthly" moisture 
+                                                                                                    !! availability (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                           :: moiavail_week         !! "weekly" moisture 
+                                                                                                    !! availability (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                           :: maxmoiavail_lastyear  !! last year's maximum 
+                                                                                                    !! moisture availability 
+                                                                                                    !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                           :: minmoiavail_lastyear  !! last year's minimum 
+                                                                                                    !! moisture availability 
+                                                                                                    !! (0-1, unitless)
+
+    !
+    !! 0.2 Output variables
+    !
+
+    !
+    !! 0.3 Modified variables
+    !
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)                            :: begin_leaves          !! signal to start putting 
+                                                                                                    !! leaves on (true/false) 
+
+    !
+    !! 0.4 Local variables
+    !
+    REAL(r_std)                                                            :: moiavail_always       !! critical monthly 
+                                                                                                    !! moisture availability - set 
+                                                                                                    !! for tree or grass 
+                                                                                                    !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                                           :: availability_crit     !! critical weekly moisture 
+                                                                                                    !! availability (0-1, unitless)
+    INTEGER(i_std)                                                         :: i                     !! index (unitless)
+
+!_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering hum'
+
+    !
+    !! 1. Initializations
+    !
+
+    !
+    !! 1.1 first call - outputs the name of onset model and the moisture availability 
+    !!     parameters for tree and grass
+    !
+
+    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): ', moiavail_always_tree
+       WRITE(numout,*) '         grasses (::moiavail_always_grass):', moiavail_always_grass
+
+       firstcall_hum = .FALSE.
+
+    ENDIF
+
+    !
+    !! 1.2 initialize output
+    !
+
+    begin_leaves(:,j) = .FALSE.
+
+    !
+    !! 1.3 check the critical value ::hum_frac is defined. If not, stop.
+    !
+
+    IF ( hum_frac(j) .EQ. undef ) THEN
+
+       WRITE(numout,*) 'hum: hum_frac is undefined for PFT (::j)',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    !
+    !! 1.4 set the critical monthly moisture availability above which we always detect the beginning of the
+    !!     growing season - set as the moisture availability for trees or grass.
+    !
+
+    IF ( is_tree(j) ) THEN
+       moiavail_always = moiavail_always_tree
+    ELSE
+       moiavail_always = moiavail_always_grass
+    ENDIF
+
+    !
+    !! 2. Check if biometeorological conditions are favourable for leaf growth.
+    !! The 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
+
+          !! 2.1 Calculate the critical weekly moisture availability: depends linearly on the last year 
+          !! minimum and maximum moisture availabilities, and on the parameter ::hum_frac.
+
+          availability_crit(i) = minmoiavail_lastyear(i,j) + hum_frac(j) * &
+               ( maxmoiavail_lastyear(i,j) - minmoiavail_lastyear(i,j) )
+
+          !! 2.2 Determine if growing season should start (if so, ::begin_leaves set to TRUE).
+          !!     Leaf onset occurs if the monthly moisture availability is still quite
+          !!     low (i.e. lower than the weekly availability), but the weekly availability is 
+          !!     already higher than the critical threshold ::availability_crit (as it reacts faster), 
+          !!     which indicates the weekly moisture availability is increasing.
+          !!     OR if the monthly moisture availability is high enough (i.e. above the threshold value 
+          !!     ::moiavail_always), leaf onset is initiated if this has not already happened.
+
+          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 ! end loop over grid points
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving hum'
+
+  END SUBROUTINE pheno_hum
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : pheno_moi
+!!
+!>\BRIEF          The 'moi' onset model (::pheno_moi) initiates leaf onset based exclusively 
+!!                on moisture availability criteria. 
+!!                It is very similar to the 'hum' onset model but instead of the weekly moisture 
+!!                availability being higher than a constant threshold, the condition is that the 
+!!                moisture minimum happened a sufficiently long time ago. 
+!!                Currently PFT 3 (Tropical Broad-leaved Raingreen) is assigned to this model.
+!!
+!! DESCRIPTION  : This model is for tropical biomes, where temperatures are high but moisture
+!!                might be a limiting factor on growth. It is based on leaf onset model 4b in 
+!!                Botta et al. (2000).
+!!                Leaf onset begins if the plant moisture availability minimum was a sufficiently  
+!!                time ago, as specified by the PFT-dependent parameter ::hum_min_time 
+!!                AND if the "monthly" moisture availability is lower than the "weekly"
+!!                availability (indicating that soil moisture is increasing).
+!!                OR if the monthly moisture availability is high enough (i.e. above the threshold 
+!!                value ::moiavail_always), leaf onset is initiated if this has not already 
+!!                happened. \n
+!!                ::hum_min_time is set for each PFT in ::stomate_data, and is 
+!!                defined in the table ::hum_min_time_tab in ::stomate_constants. \n
+!!                ::moiavail_always is defined for both tree and grass in this subroutine 
+!!                (set to 1. and 0.6 respectively). \n
+!!                The ::pheno_moi subroutine is called in the subroutine ::phenology. 
+!!
+!! RECENT CHANGE(S): None
+!!        
+!! MAIN OUTPUT VARIABLE(S): ::begin_leaves - specifies whether leaf growth can start.
+!!
+!! REFERENCE(S) : 
+!! - Botta, A., N. Viovy, P. Ciais, P. Friedlingstein and P. Monfray (2000), 
+!! A global prognostic scheme of leaf onset using satellite data,
+!! Global Change Biology, 207, 337-347.
+!! - Krinner, G., N. Viovy, N. de Noblet-Ducoudre, J. Ogee, J. Polcher, P. 
+!! Friedlingstein, P. Ciais, S. Sitch and I.C. Prentice (2005), A dynamic global
+!! vegetation model for studies of the coupled atmosphere-biosphere system, Global
+!! Biogeochemical Cycles, 19, doi:10.1029/2003GB002199.
+!!
+!! FLOWCHART    : 
+!! \latexonly
+!! \includegraphics[scale = 1]{pheno_moi.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE pheno_moi (npts, j, PFTpresent, allow_initpheno, &
+       time_hum_min, &
+       moiavail_month, moiavail_week, &
+       begin_leaves)
+
+    !
+    !! 0. Variable and parameter declaration
+    !
+
+    !
+    !! 0.1 Input variables
+    !
+    INTEGER(i_std), INTENT(in)                               :: npts            !! Domain size - number of grid cells (unitless)
+    INTEGER(i_std), INTENT(in)                               :: j               !! PFT index (unitless)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                 :: PFTpresent      !! PFT exists (true/false)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                 :: allow_initpheno !! are we allowed to declare the beginning of the 
+                                                                                !! growing season? (true/false) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: time_hum_min    !! time elapsed since strongest moisture 
+                                                                                !! availability (days) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: moiavail_month  !! "monthly" moisture availability (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: moiavail_week   !! "weekly" moisture availability (0-1, unitless)
+
+    !
+    !! 0.2 Output variables
+    !
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves    !! signal to start putting leaves on (true/false)
+
+    !
+    !! 0.3 Modified variables
+    !
+
+    !
+    !! 0.4 Local variables
+    !
+    REAL(r_std)                                              :: moiavail_always                 !! critical moisture availability - 
+                                                                                                !! set for tree or grass 
+                                                                                                !! (0-1, unitless)
+    INTEGER(i_std)                                           :: i                               !! index (unitless)
+
+!_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering moi'
+
+    !
+    !! 1. Initializations
+    !
+
+    !
+    !! 1.1 first call - outputs the name of onset model and the moisture availability 
+    !!     parameters for tree and grass
+    !
+
+    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):', moiavail_always_tree
+       WRITE(numout,*) '         grasses (::moiavail_always_grass):', moiavail_always_grass
+
+       firstcall_moi = .FALSE.
+
+    ENDIF
+
+    !
+    !! 1.2 initialize output
+    !
+
+    begin_leaves(:,j) = .FALSE.
+
+    !
+    !! 1.3 check the critical value ::hum_min_time is definded. If not, stop
+    !
+
+    IF ( hum_min_time(j) .EQ. undef ) THEN
+
+       WRITE(numout,*) 'moi: hum_min_time is undefined for PFT (::j) ',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    !
+    !! 1.4 set the critical monthly moisture availability above which we always detect the beginning of the
+    !!     growing season - set as the moisture availability for trees or grass.
+    !
+
+    IF ( is_tree(j) ) THEN
+       moiavail_always = moiavail_always_tree
+    ELSE
+       moiavail_always = moiavail_always_grass
+    ENDIF
+
+    !
+    !! 2. Check if biometeorological conditions are favourable for leaf growth.
+    !! The 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
+          
+          !! 2.1 Determine if growing season should start (if so, ::begin_leaves set to TRUE).
+          !!     The favorable season starts if the moisture minimum (::time_hum_min) was a sufficiently long 
+          !!     time ago, i.e. greater than the threshold specified by the parameter ::hum_min_time 
+          !!     and if the "monthly" moisture availability is lower than the "weekly"
+          !!     availability (indicating that soil moisture is increasing).
+          !!     OR if the monthly moisture availability is high enough (i.e. above the threshold value 
+          !!     ::moiavail_always), initiate the growing season if this has not happened yet.
+
+          IF  ( ( ( moiavail_week(i,j) .GT. moiavail_month(i,j) ) .AND. &
+!!$               ( biomass(i,j,ileaf,icarbon) .LT. min_stomate) .AND. &
+               ( time_hum_min(i,j) .GT. 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 ! end loop over grid points
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving moi'
+
+  END SUBROUTINE pheno_moi
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : pheno_humgdd
+!!
+!>\BRIEF          The 'humgdd' onset model initiates leaf onset based on mixed conditions of 
+!!                temperature and moisture availability criteria. 
+!!                Currently no PFTs are assigned to this onset model. 
+!!
+!! DESCRIPTION  : In this model the Growing Degree Day (GDD) model (Chuine, 2000) is combined 
+!!                with the 'hum' onset model (::pheno_hum), which has previously been described,
+!!                in order to account for dependence on both temperature and moisture conditions 
+!!                in warmer climates. \n. 
+!!                The GDD model specifies that daily temperatures above a threshold of -5  
+!!                degrees C are summed, minus this threshold, giving the GDD, starting from 
+!!                the beginning of the dormancy period (::time_lowgpp>0), i.e. since the leaves 
+!!                were lost. \n.
+!!                The dormancy time-length is represented by the variable 
+!!                ::time_lowgpp, which is calculated in ::stomate_season. It is increased by 
+!!                the stomate time step when the weekly GPP is lower than a threshold. Otherwise
+!!                it is set to zero. \n
+!!                Leaf onset begins when the a PFT-dependent GDD-threshold is reached.
+!!                In addition there are temperature and moisture conditions.
+!!                The temperature condition specifies that the monthly temperature has to be 
+!!                higher than a constant threshold (::t_always) OR
+!!                the weekly temperature is higher than the monthly temperature.
+!!                There has to be at least some moisture. The moisture condition 
+!!                is exactly the same as the 'hum' onset model (::pheno_hum), which has already
+!!                been described. \n
+!!                The GDD (::gdd_m5_dormance) is calculated in ::stomate_season. GDD is set to 
+!!                undef if beginning of the growing season detected, i.e. when there is GPP 
+!!                (::time_lowgpp>0).
+!!                The parameter ::t_always is defined as 10 degrees C in this subroutine, 
+!!                as are the parameters ::moisture_avail_tree and ::moisture_avail_grass 
+!!                (set to 1 and 0.6 respectively), which are used in the moisture condition 
+!!                (see ::pheno_moi onset model description). \n
+!!                The PFT-dependent GDD threshold (::gdd_crit) is calculated as in the onset 
+!!                model ::pheno_humgdd, using the equation:
+!!                \latexonly
+!!                \input{phenology_hummoigdd_gddcrit_eqn4.tex}
+!!                \endlatexonly
+!!                \n
+!!                The three GDDcrit parameters (::gdd(j,*)) are set for each PFT in 
+!!                ::stomate_data, and three tables defining each of the three critical GDD
+!!                parameters for each PFT is given in ::gdd_crit1_tab, ::gdd_crit2_tab and 
+!!                ::gdd_crit3_tab in ::stomate_constants. \n
+!!                The ::pheno_humgdd subroutine is called in the subroutine ::phenology. 
+!!
+!! RECENT CHANGES: None
+!!                
+!! MAIN OUTPUT VARIABLES: ::begin_leaves - specifies whether leaf growth can start
+!!
+!! REFERENCE(S) : 
+!! - Botta, A., N. Viovy, P. Ciais, P. Friedlingstein and P. Monfray (2000), 
+!! A global prognostic scheme of leaf onset using satellite data,
+!! Global Change Biology, 207, 337-347.
+!! - Chuine, I (2000), A unified model for the budburst of trees, Journal of 
+!! Theoretical Biology, 207, 337-347.
+!! - Krinner, G., N. Viovy, N. de Noblet-Ducoudre, J. Ogee, J. Polcher, P. 
+!! Friedlingstein, P. Ciais, S. Sitch and I.C. Prentice (2005), A dynamic global
+!! vegetation model for studies of the coupled atmosphere-biosphere system, Global
+!! Biogeochemical Cycles, 19, doi:10.1029/2003GB002199.
+!!
+!! FLOWCHART    : 
+!! \latexonly
+!! \includegraphics[scale = 1]{pheno_humgdd.png}
+!! \endlatexonly
+!! \n             
+!_ ================================================================================================================================
+
+  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. Variable and parameter declaration
+    !
+
+    !
+    !! 0.1 Input variables
+    !
+    INTEGER(i_std), INTENT(in)                               :: npts                    !! Domain size - number of grid cells 
+                                                                                        !! (unitless) 
+    INTEGER(i_std), INTENT(in)                               :: j                       !! PFT index (unitless)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                 :: PFTpresent              !! PFT exists (true/false)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                 :: allow_initpheno         !! are we allowed to declare the beginning 
+                                                                                        !! of the growing season? (true/false) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: gdd                     !! growing degree days, calculated since 
+                                                                                        !! leaves have fallen (C) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: maxmoiavail_lastyear    !! last year's maximum moisture 
+                                                                                        !! availability (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: minmoiavail_lastyear    !! last year's minimum moisture 
+                                                                                        !! availability (0-1, unitless)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: tlong_ref               !! "long term" 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month               !! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week                !! "weekly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: moiavail_week           !! "weekly" moisture availability 
+                                                                                        !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: moiavail_month          !! "monthly" moisture availability 
+                                                                                        !! (0-1, unitless)
+
+    !
+    !! 0.2 Output variables
+    !
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves            !! signal to start putting leaves on 
+                                                                                        !! (true/false) 
+
+    !
+    !! 0.3 Modified variables
+    !
+
+    !
+    !! 0.4 Local variables
+    !
+    REAL(r_std)                                              :: moiavail_always                 !! critical moisture availability - 
+                                                                                                !! set for tree or grass 
+                                                                                                !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: moiavail_crit                   !! critical moisture availability 
+                                                                                                !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: tl                              !! long term temperature (C)
+    REAL(r_std), DIMENSION(npts)                             :: gdd_crit                        !! critical GDD (C)
+    INTEGER(i_std)                                           :: i                               !! index (unitless)
+
+!_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering humgdd'
+
+    !
+    !! 1. Initializations
+    !
+
+    !
+    !! 1.1 first call - outputs the name of the onset model, the values of the  
+    !!     moisture availability parameters for tree and grass, and the value of the 
+    !!     critical monthly temperature.
+    !
+
+    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): ', moiavail_always_tree
+       WRITE(numout,*) '         grasses (::moiavail_always_grass): ', 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 critical values ::gdd and ::pheno_crit_hum_frac are defined.
+    !!     If not, stop.
+    !
+
+    IF ( ANY(pheno_gdd_crit(j,:) .EQ. undef) ) THEN
+
+       WRITE(numout,*) 'humgdd: pheno_gdd_crit is undefined for PFT (::j) ',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    IF ( hum_frac(j) .EQ. undef ) THEN
+
+       WRITE(numout,*) 'humgdd: hum_frac is undefined for PFT (::j) ',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    !
+    !! 1.4 set the critical moisture availability above which we always detect the beginning of the
+    !!     growing season - set as the moisture availability for trees or grass.
+    !
+
+    IF ( is_tree(j) ) THEN
+       moiavail_always = moiavail_always_tree
+    ELSE
+       moiavail_always = moiavail_always_grass
+    ENDIF
+
+    !
+    !! 2. Check if biometeorological conditions are favourable for leaf growth.
+    !!   The 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
+
+          !! 2.1 Calculate the critical weekly moisture availability: depends linearly on the last year 
+          !! minimum and maximum moisture availabilities, and on the parameter ::hum_frac.,
+          !! (as in the ::pheno_hum model), as per the equation:
+
+          moiavail_crit(i) = minmoiavail_lastyear(i,j) + hum_frac(j) * &
+               ( maxmoiavail_lastyear(i,j) - minmoiavail_lastyear(i,j) )
+
+          !! 2.2 Calculate the critical GDD (::gdd_crit), which is a function of the PFT-dependent 
+          !!     critical GDD and the "long term" 2 meter air temperatures.  
+
+          tl(i) =  tlong_ref(i) - ZeroCelsius
+          gdd_crit(i) = pheno_gdd_crit(j,1) + tl(i)*pheno_gdd_crit(j,2) + &
+               tl(i)*tl(i)*pheno_gdd_crit(j,3)
+
+          !!Added to make use of the optimised phenology parameters of Natasha MacBean
+          !!In ORCHIS, a multiplicative factor (opti_kpheno_crit) was optimised in stead of ggd_crit
+          gdd_crit(i) = gdd_crit(i)*opti_kpheno_crit(j)
+          
+          !! 2.3 Determine if the growing season should start (if so, ::begin_leaves set to TRUE).
+          !!     - Has the critical gdd been reached and is the temperature increasing?
+          !!     - Is there at least some humidity/moisture availability?
+          !!     This occurs if the critical gdd (::gdd_crit) has been reached 
+          !!     AND that is temperature increasing, which is true either if the monthly
+          !!     temperature being higher than the threshold ::t_always, OR if the weekly
+          !!     temperature is higher than the monthly, 
+          !!     AND finally that there is sufficient moisture availability, which is 
+          !!     the same condition as for the ::pheno_hum onset model.
+
+          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 ! End loop over grid points
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving humgdd'
+
+  END SUBROUTINE pheno_humgdd
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : pheno_moigdd
+!!
+!>\BRIEF          The 'moigdd' onset model initiates leaf onset based on mixed temperature 
+!!                and moisture availability criteria.
+!!                Currently PFTs 10 - 13 (C3 and C4 grass, and C3 and C4 agriculture) 
+!!                are assigned to this model. 
+!!
+!! DESCRIPTION  : This onset model combines the GDD model (Chuine, 2000), as described for 
+!!                the 'humgdd' onset model (::pheno_humgdd), and the 'moi' model, in order 
+!!                to account for dependence on both temperature and moisture conditions in
+!!                warmer climates. \n
+!!                Leaf onset begins when the a PFT-dependent GDD threshold is reached.
+!!                In addition there are temperature and moisture conditions.
+!!                The temperature condition specifies that the monthly temperature has to be 
+!!                higher than a constant threshold (::t_always) OR
+!!                the weekly temperature is higher than the monthly temperature.
+!!                There has to be at least some moisture. The moisture condition 
+!!                is exactly the same as the 'moi' onset model (::pheno_moi), which has
+!!                already been described. \n
+!!                GDD is set to undef if beginning of the growing season detected.
+!!                As in the ::pheno_humgdd model, the parameter ::t_always is defined as 
+!!                10 degrees C in this subroutine, as are the parameters ::moisture_avail_tree
+!!                and ::moisture_avail_grass (set to 1 and 0.6 respectively), which are used
+!!                in the moisture condition (see ::pheno_moi onset model description). \n
+!!                The PFT-dependent GDD threshold (::gdd_crit) is calculated as in the onset 
+!!                model ::pheno_humgdd, using the equation:
+!!                \latexonly
+!!                \input{phenology_hummoigdd_gddcrit_eqn4.tex}
+!!                \endlatexonly
+!!                \n
+!!                where i and j are the grid cell and PFT respectively.
+!!                The three GDDcrit parameters (::gdd(j,*)) are set for each PFT in 
+!!                ::stomate_data, and three tables defining each of the three critical GDD
+!!                parameters for each PFT is given in ::gdd_crit1_tab, ::gdd_crit2_tab and 
+!!                ::gdd_crit3_tab in ::stomate_constants. \n
+!!                The ::pheno_moigdd subroutine is called in the subroutine ::phenology. 
+!!
+!! RECENT CHANGE(S): None
+!!                
+!! MAIN OUTPUT VARIABLE(S): ::begin_leaves - specifies whether leaf growth can start
+!!
+!! REFERENCE(S) : 
+!! - Botta, A., N. Viovy, P. Ciais, P. Friedlingstein and P. Monfray (2000), 
+!! A global prognostic scheme of leaf onset using satellite data,
+!! Global Change Biology, 207, 337-347.
+!! - Chuine, I (2000), A unified model for the budburst of trees, Journal of 
+!! Theoretical Biology, 207, 337-347.
+!! - Krinner, G., N. Viovy, N. de Noblet-Ducoudre, J. Ogee, J. Polcher, P. 
+!! Friedlingstein, P. Ciais, S. Sitch and I.C. Prentice (2005), A dynamic global
+!! vegetation model for studies of the coupled atmosphere-biosphere system, Global
+!! Biogeochemical Cycles, 19, doi:10.1029/2003GB002199.
+!!
+!! FLOWCHART    : 
+!! \latexonly
+!! \includegraphics[scale = 1]{pheno_moigdd.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  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. Variable and parameter declaration
+    !
+
+    !
+    !! 0.1 Input variables
+    !
+    INTEGER(i_std), INTENT(in)                               :: npts            !! Domain size - number of grid cells (unitless)
+    INTEGER(i_std), INTENT(in)                               :: j               !! PFT index (unitless)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                 :: PFTpresent      !! PFT exists (true/false)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                 :: allow_initpheno !! are we allowed to decalre the beginning of the 
+                                                                                !! growing season? (true/false) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: gdd             !! growing degree days, calculated since leaves 
+                                                                                !! have fallen (C) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: time_hum_min    !! time elapsed since strongest moisture 
+                                                                                !! availability (days) 
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: tlong_ref       !! "long term" 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month       !! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week        !! "weekly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: moiavail_week   !! "weekly" moisture availability (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: moiavail_month  !! "monthly" moisture availability (0-1, unitless)
+
+    !
+    !! 0.2 Output variables
+    !
+
+    !
+    !! 0.3 Modified variables
+    !
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves    !! signal to start putting leaves on (true/false)
+
+    !
+    !! 0.4 Local variables
+    !
+    REAL(r_std)                                              :: moiavail_always                 !! critical moisture availability - 
+                                                                                                !! set for tree or grass 
+                                                                                                !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                             :: tl                              !! long term temperature (C)
+    REAL(r_std), DIMENSION(npts)                             :: gdd_crit                        !! critical GDD (C)
+    INTEGER(i_std)                                           :: i                               !! index (unitless)
+
+!_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering moigdd'
+
+    !! 1. Initializations
+
+    !! 1.1 first call
+    !! Outputs the name of the onset model, the values of the  
+    !! moisture availability parameters for tree and grass, and the value of the 
+    !! critical monthly temperature.
+    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) :', moiavail_always_tree
+       WRITE(numout,*) '         grasses (::moiavail_always_grass) :', moiavail_always_grass
+       WRITE(numout,*) '   > monthly temp. above which temp. tendency doesn''t matter (::t_always): ', &
+            t_always
+
+       firstcall_moigdd = .FALSE.
+
+    ENDIF
+
+    !! 1.2 initialize output
+    begin_leaves(:,j) = .FALSE.
+
+    !! 1.3 check the critical values ::gdd and ::pheno_crit_hum_min_time are defined.
+    !! If not, stop.
+    IF ( ANY(pheno_gdd_crit(j,:) .EQ. undef) ) THEN
+
+       WRITE(numout,*) 'moigdd: pheno_gdd_crit is undefined for PFT',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    IF ( hum_min_time(j) .EQ. undef ) THEN
+
+       WRITE(numout,*) 'moigdd: hum_min_time is undefined for PFT',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    !! 1.4 set the critical moisture availability above which we always detect the beginning of the
+    !! growing season - set as the moisture availability for trees or grass
+    IF ( is_tree(j) ) THEN
+
+       moiavail_always = moiavail_always_tree
+
+    ELSE
+
+       moiavail_always = moiavail_always_grass
+
+    ENDIF
+
+    !+++TEMP+++
+    IF (ld_pheno .AND. j.EQ.test_pft) THEN
+       WRITE(numout,*) 'phenology PFTpresent, ', j, PFTpresent(:,j)
+       WRITE(numout,*) 'phenology allow_initpheno, ', allow_initpheno(:,j)
+       WRITE(numout,*) 'phenology gdd, ', gdd(:,j)
+    ENDIF
+    !++++++++++
+
+
+    !! 2. Check if biometeorological conditions are favourable for leaf growth.
+    !! The PFT has to be there, the 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
+          
+          !! 2.1 Calculate the critical GDD (::gdd_crit), which is a function of the PFT-dependent 
+          !! critical GDD and the "long term" 2 meter air temperatures 
+          tl(i) = tlong_ref(i) - ZeroCelsius
+          gdd_crit(i) = pheno_gdd_crit(j,1) + tl(i)*pheno_gdd_crit(j,2) + &
+               tl(i)*tl(i)*pheno_gdd_crit(j,3)
+
+          !!Added to make use of the optimised phenology parameters of Natasha MacBean
+          !!In ORCHIS, a multiplicative factor (opti_kpheno_crit) was optimised in stead of ggd_crit
+          gdd_crit(i) = gdd_crit(i)*opti_kpheno_crit(j)
+
+           !+++TEMP+++
+          IF (ld_pheno .AND. j.EQ.test_pft) THEN
+             WRITE(numout,*) 'phenology gdd_crit, ', gdd_crit(:)
+             WRITE(numout,*) 'phenology t2m_week, ', t2m_week(:)
+             WRITE(numout,*) 'phenology t2m_month, ', t2m_month(:)
+             WRITE(numout,*) 'phenology t_always, ', t_always
+             WRITE(numout,*) 'phenology time_hum_min, ', time_hum_min(:,j)
+             WRITE(numout,*) 'phenology hum_min_time, ', hum_min_time(j)
+             WRITE(numout,*) 'phenology moiavail_week, ', moiavail_week(:,j)
+             WRITE(numout,*) 'phenology moiavail_month, ', moiavail_month(:,j) 
+             WRITE(numout,*) 'phenology moiavail_always, ', moiavail_always
+             WRITE(numout,*) 'phenology, is_temperate, ', is_temperate(j)
+             WRITE(numout,*) 'phenology, is_boreal, ', is_boreal(j)
+          ENDIF
+          !++++++++++
+
+          !! 2.2 Determine if the growing season should start (if so, ::begin_leaves set to TRUE).
+          !! This occurs if the critical gdd (::gdd_crit) has been reached 
+          !! AND that is temperature increasing, which is true either if the monthly
+          !! temperature being higher than the threshold ::t_always, OR if the weekly
+          !! temperature is higher than the monthly, 
+          !! AND finally that there is sufficient moisture availability, which is 
+          !! the same condition as for the ::pheno_moi onset model.
+     
+          !+++CHECK+++
+!!$          t_always = 283
+          IF ( ( is_temperate(j) ) .AND. &
+               ( gdd(i,j) .GE. gdd_crit(i) ) .AND. &
+               ( ( t2m_week(i) .GT. t2m_month(i) ) .OR. &
+               ( t2m_month(i) .GT. 283 ) ) .AND. &
+               ( moiavail_month(i,j) .GE. moiavail_always ) )   THEN
+!!$            ( time_hum_min(i,j) .GT. hum_min_time(j) .OR. &
+!!$               ( moiavail_week(i,j) .GT. moiavail_month(i,j) .OR. &
+
+             begin_leaves(i,j) = .TRUE.
+             
+
+             !+++TEMP+++
+             IF (ld_pheno .AND. j.EQ.test_pft) THEN
+                WRITE(numout,*) 'phenology updated begin_leaves, ', begin_leaves(:,j)
+             ENDIF
+             !++++++++++
+
+          ENDIF
+          !++++++++++++
+
+          !+++CHECK+++
+!!$          t_always = 279
+          IF ( ( is_boreal(j) ) .AND. &
+               ( gdd(i,j) .GE. gdd_crit(i) ) .AND. &
+               ( ( t2m_week(i) .GT. t2m_month(i) ) .OR. &
+               ( t2m_month(i) .GT. 279 ) ) .AND. &
+               ( moiavail_month(i,j) .GE. moiavail_always ) )  THEN
+!!$    ( ( time_hum_min(i,j) .GT. hum_min_time(j) ) .OR. &
+
+             begin_leaves(i,j) = .TRUE.
+             
+
+             !+++TEMP+++
+             IF (ld_pheno .AND. j.EQ.test_pft) THEN
+                WRITE(numout,*) 'phenology updated begin_leaves, ', begin_leaves(:,j)
+             ENDIF
+             !++++++++++
+
+          ENDIF
+          !++++++++++++
+
+       ENDIF        ! PFT there and start of growing season allowed
+
+    ENDDO
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving moigdd'
+
+  END SUBROUTINE pheno_moigdd
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : pheno_ncdgdd
+!!
+!>\BRIEF          The Number of Chilling Days - Growing Degree Day (NCD-GDD) model initiates 
+!!                leaf onset if a certain relationship between the number of chilling days (NCD) 
+!!                since leaves were lost, and the growing degree days (GDD) since midwinter, is 
+!!                fulfilled. 
+!!                Currently PFT 6 (Temperate Broad-leaved Summergreen) and PFT 8 (Boreal Broad-
+!!                leaved Summergreen) are assigned to this model.
+!! 
+!! DESCRIPTION  : Experiments have shown that some
+!!                species have a "chilling" requirement, i.e. their physiology needs cold 
+!!                temperatures to trigger the mechanism that will allow the following budburst 
+!!                (e.g. Orlandi et al., 2004). 
+!!                An increase in chilling days, defined as a day with a daily mean air
+!!                temperature below a PFT-dependent threshold, reduces a plant's GDD demand 
+!!                (Cannell and Smith, 1986; Murray et al., (1989); Botta et al., 2000).
+!!                The GDD threshold therefore decreases as NCD 
+!!                increases, using the following empirical negative explonential law:
+!!                \latexonly
+!!                \input{phenology_ncdgdd_gddmin_eqn5.tex}
+!!                \endlatexonly
+!!                \n
+!!                The constants used have been calibrated against data CHECK FOR REFERENCE OR PERSON WHO DID UPDATE.
+!!                Leaf onset begins if the GDD is higher than the calculated minimum GDD
+!!                (dependent upon NCD) AND if the weekly temperature is higher than the monthly 
+!!                temperature. This is to ensure the temperature is increasing. \n
+!!                The dormancy time-length is represented by the variable 
+!!                ::time_lowgpp, which is calculated in ::stomate_season. It is increased by 
+!!                the stomate time step when the weekly GPP is lower than a threshold. Otherwise
+!!                it is set to zero. \n
+!!                The NCD (::ncd_dormance) is calculated in ::stomate_season as  
+!!                the number of days with a temperature below a PFT-dependent constant threshold
+!!                (::ncdgdd_temp), starting from the beginning of the dormancy period
+!!                (::time_lowgpp>0), i.e. since the leaves were lost. \n
+!!                The growing degree day sum of the temperatures higher than 
+!!                ::ncdgdd_temp (GDD) since midwinter (::gdd_midwinter) 
+!!                is also calculated in ::stomate_season.
+!!                Midwinter is detected if the monthly temperature is lower than the weekly
+!!                temperature AND  the monthly temperature is lower than the long-term
+!!                temperature. ::gdd_minter is therefore set to 0 at the beginning of midwinter
+!!                and increased with each temperature greater than the PFT-dependent threshold.
+!!                When midsummer is detected (the opposite of the above conditions), 
+!!                ::gdd_midwinter is set to undef.
+!!                CHECK! WHEN TO START OF DORMANCY BEEN MODIFIED FROM BOTTA- ADD IN?
+!!                The ::pheno_ncdgdd subroutine is called in the subroutine ::phenology. 
+!!
+!! RECENT CHANGE(S): None
+!!                
+!! MAIN OUTPUT VARIABLE(S): ::begin_leaves - specifies whether leaf growth can start
+!!
+!! REFERENCE(S) :
+!! - Botta, A., N. Viovy, P. Ciais, P. Friedlingstein and P. Monfray (2000), 
+!! A global prognostic scheme of leaf onset using satellite data,
+!! Global Change Biology, 207, 337-347.
+!! - Cannell, M.J.R. and R.I. Smith (1986), Climatic warming, spring budburst and
+!! frost damage on trees, Journal of Applied Ecology, 23, 177-191.
+!! - Krinner, G., N. Viovy, N. de Noblet-Ducoudre, J. Ogee, J. Polcher, P. 
+!! Friedlingstein, P. Ciais, S. Sitch and I.C. Prentice (2005), A dynamic global
+!! vegetation model for studies of the coupled atmosphere-biosphere system, Global
+!! Biogeochemical Cycles, 19, doi:10.1029/2003GB002199.
+!! - Murray, M.B., G.R. Cannell and R.I. Smith (1989), Date of budburst of fifteen 
+!! tree species in Britain following climatic warming, Journal of Applied Ecology,
+!! 26, 693-700.
+!! - Orlandi, F., H. Garcia-Mozo, L.V. Ezquerra, B. Romano, E. Dominquez, C. Galan,
+!! and M. Fornaciari (2004), Phenological olive chilling requirements in Umbria
+!! (Italy) and Andalusia (Spain), Plant Biosystems, 138, 111-116. 
+!!
+!! FLOWCHART    : 
+!! \latexonly
+!! \includegraphics[scale = 1]{pheno_ncdgdd.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE pheno_ncdgdd (npts, j, PFTpresent, allow_initpheno, &
+       ncd_dormance, gdd_midwinter, &
+       t2m_month, t2m_week, begin_leaves)
+
+    !
+    !! 0. Variable and parameter declaration
+    !
+
+    !
+    !! 0.1 Input variables
+    !
+    INTEGER(i_std), INTENT(in)                               :: npts            !! Domain size - number of grid cells (unitless)
+    INTEGER(i_std), INTENT(in)                               :: j               !! PFT index (unitless)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                 :: PFTpresent      !! PFT exists (true/false)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                 :: allow_initpheno !! are we allowed to declare the beginning of the 
+                                                                                !! growing season? (true/false) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: ncd_dormance    !! number of chilling days since leaves were lost 
+                                                                                !! (days) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)          :: gdd_midwinter   !! growing degree days since midwinter (C)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month       !! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week        !! "weekly" 2-meter temperatures (K)
+
+    !
+    !! 0.2 Output variables
+    !
+
+    !
+    !! 0.3 Modified variables
+    !
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves    !! signal to start putting leaves on (true/false)
+
+    !
+    !! 0.4 Local variables
+    !
+    INTEGER(i_std)                                           :: i               !! index (unitless)
+    REAL(r_std)                                              :: gdd_min         !! critical gdd (C)
+
+!_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering ncdgdd'
+
+    !! 1. Initializations
+ 
+    !! 1.1 initialize output
+    begin_leaves(:,j) = .FALSE.
+
+    !! 1.2 check the critical value ::ncdgdd_temp is defined.
+    !! If not, stop.
+    IF ( ncdgdd_temp(j) .EQ. undef ) THEN
+
+       WRITE(numout,*) 'ncdgdd: ncdgdd_temp is undefined for PFT (::j) ',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    !! 2. Check if biometeorological conditions are favourable for leaf growth.    
+    !!    PFT has to be there and start of growing season must be allowed.
+    DO i = 1, npts ! loop over grid points
+
+       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
+            ( gdd_midwinter(i,j) .NE. undef ) .AND. &
+            ( ncd_dormance(i,j) .NE. undef )) THEN
+
+          !! 2.1 Calculate the critical gdd, which is related to ::ncd_dormance
+          !! using an empirical negative exponential law as described above.
+          !! kpheno_crit was added to make use of the optimised phenology parameters of Natasha MacBean
+          !! In ORCHIS, a multiplicative factor (opti_kpheno_crit) was optimised in stead of ggd_crit
+          gdd_min = ( gddncd_ref / exp(gddncd_curve*ncd_dormance(i,j)) - gddncd_offset) * opti_kpheno_crit(j) 
+          
+          !! 2.2 Determine if the growing season should start (if so, ::begin_leaves set to TRUE).
+          !! This occurs if the critical GDD been reached AND the temperatures are increasing.
+          !! If the growing season has started, ::gdd_midwinter is set to "undef". 
+          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 ! end loop over grid points
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving ncdgdd'
+
+  END SUBROUTINE pheno_ncdgdd
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : pheno_ngd
+!!
+!>\BRIEF          The Number of Growing Days (NGD) leaf onset model initiates leaf onset if the NGD, 
+!!                defined as the number of days with temperature above a constant threshold, 
+!!                exceeds a critical value.
+!!                Currently PFT 9 (Boreal Leedleleaf Summergreen) is assigned to this model. 
+!!
+!! DESCRIPTION    +++CHECK+++
+!!                Description without dormance period include drormance (see ncdgdd)
+!!                The NGD model is a variant of the GDD model. The model was proposed by Botta et
+!!                al. (2000) for boreal and arctic biomes, and is designed to estimate 
+!!                leaf onset after the end of soil frost. 
+!!                The NDG (::ngd_minus5) is the number of days with a daily mean air 
+!!                temperature of greater than -5 degrees C, 
+!!                starting from the beginning of the dormancy period (i.e. time since the leaves 
+!!                were lost/GPP below a certain threshold).
+!!                Leaf onset begins if the NGD is higher than the PFT-dependent constant threshold, 
+!!                ::ngd,  AND if the weekly temperature is higher than the monthly 
+!!                temperature. \n
+!!                The dormancy time-length is represented by the variable 
+!!                ::time_lowgpp, which is calculated in ::stomate_season. It is increased by 
+!!                the stomate time step when the weekly GPP is lower than a threshold. Otherwise
+!!                it is set to zero. \n
+!!                ::ngd_minus5 is also calculated in ::stomate_season. It is initialised at the
+!!                beginning of the dormancy period (::time_lowgpp>0), and increased by the 
+!!                stomate time step when the temperature > -5 degrees C. \n
+!!                ::ngd is set for each PFT in ::stomate_data, and a 
+!!                table defining the minimum NGD for each PFT is given in ::ngd_crit_tab
+!!                in ::stomate_constants. \n
+!!                The ::pheno_ngd subroutine is called in the subroutine ::phenology.      
+!!
+!! RECENT CHANGE(S): None
+!!                
+!! MAIN OUTPUT VARIABLE(S): ::begin_leaves - specifies whether leaf growth can start
+!!
+!! REFERENCE(S) : 
+!! - Botta, A., N. Viovy, P. Ciais, P. Friedlingstein and P. Monfray (2000), 
+!! A global prognostic scheme of leaf onset using satellite data,
+!! Global Change Biology, 207, 337-347. 
+!! - Krinner, G., N. Viovy, N. de Noblet-Ducoudre, J. Ogee, J. Polcher, P. 
+!! Friedlingstein, P. Ciais, S. Sitch and I.C. Prentice (2005), A dynamic global
+!! vegetation model for studies of the coupled atmosphere-biosphere system, Global
+!! Biogeochemical Cycles, 19, doi:10.1029/2003GB002199.
+!!
+!! FLOWCHART    : 
+!! \latexonly
+!! \includegraphics[scale = 1]{pheno_ngd.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+   SUBROUTINE pheno_ngd (npts, j, PFTpresent, allow_initpheno, ncd_dormance, &
+        ngd_minus5, t2m_month, t2m_week, begin_leaves)
+
+   
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+    
+    INTEGER(i_std), INTENT(in)                               :: npts            !! Domain size - number of grid cells (unitless)
+    INTEGER(i_std), INTENT(in)                               :: j               !! PFT index (unitless)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                 :: PFTpresent      !! PFT exists (true/false)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                 :: allow_initpheno !! are we allowed to declare the beginning of the 
+                                                                                !! growing season? (true/false) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: ncd_dormance    !! number of chilling days since leaves were lost 
+                                                                                !! (days) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)          :: ngd_minus5      !! growing degree days since midwinter (C)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month       !! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week        !! "weekly" 2-meter temperatures (K)
+
+
+    !! 0.2 Output variables
+
+    !! 0.3 Modified variables
+   
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves    !! signal to start putting leaves on (true/false)
+
+  
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                           :: i               !! index (unitless)
+    REAL(r_std)                                              :: gdd_min         !! critical gdd (C)
+
+!_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering ngd'
+
+    !! 1. Initializations
+  
+    !! 1.1 initialize output
+    begin_leaves(:,j) = .FALSE.
+
+    !! 1.2 check the critical value ::ngd_crit is defined.
+    !  If not, stop.
+    IF ( ngd_crit(j) .EQ. undef ) THEN
+
+       WRITE(numout,*) 'ngd: ngd_crit is undefined for PFT (::j) ',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    !+++TEMP+++
+    IF (ld_pheno .AND. j.EQ.test_pft) THEN
+       WRITE(numout,*) 'phenology PFTpresent, ', j, PFTpresent(:,j)
+       WRITE(numout,*) 'phenology allow_initpheno, ', allow_initpheno(:,j)
+       WRITE(numout,*) 'phenology ngd, ', ngd_minus5(:,j)
+       WRITE(numout,*) 'phenology ngd_crit, ',ngd_crit(j) 
+       WRITE(numout,*) 'phenology ncd_dormance, ', ncd_dormance(:,j)
+       WRITE(numout,*) 'phenology ngd_min_dormance, ',ngd_min_dormance
+       WRITE(numout,*) 'phenology begin_leaves, ', begin_leaves(:,j)
+       WRITE(numout,*) 'phenology t2m_week, ', t2m_week(:)
+       WRITE(numout,*) 'phenology ncdgdd_temp, ', ncdgdd_temp(j)+ZeroCelsius
+       WRITE(numout,*) 'phenology t2m_month, ', t2m_month(:)
+    ENDIF
+    !++++++++++
+    
+
+    !! 2. Check if biometeorological conditions are favourable for leaf growth.    
+    !!    PFT has to be there and start of growing season must be allowed.
+    
+
+    DO i = 1, npts ! loop over grid points
+
+       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
+            ( ngd_minus5(i,j) .NE. undef ) .AND. &
+            ( ncd_dormance(i,j) .NE. undef )) THEN
+          
+          !! 2.1 Determine if the growing season should start 
+          !  (if so, ::begin_leaves set to TRUE). This occurs if the critical GDD 
+          !  been reached AND the temperatures are increasing. If the growing season 
+          !  has started, ::gdd_midwinter is set to "undef". 
+
+          IF ( ( ngd_minus5(i,j) .GE. ngd_crit(j)*opti_kpheno_crit(j) ) .AND. &
+               ( ( ncd_dormance(i,j) .GE. ngd_min_dormance) .OR. &
+               ( t2m_week(i) .GT. ncdgdd_temp(j)+ZeroCelsius) ) .AND. &
+               ( t2m_week(i) .GT. t2m_month(i) ) ) THEN
+
+             begin_leaves(i,j) = .TRUE.
+             ngd_minus5(i,j) = undef
+
+             !+++TEMP+++
+             IF (ld_pheno .AND. j.EQ.test_pft) THEN
+                WRITE(numout,*) 'phenology updated begin_leaves, ', begin_leaves(i,j)
+             ENDIF
+             !++++++++++
+
+          ENDIF
+
+       ENDIF        ! PFT there and start of growing season allowed
+
+    ENDDO ! end loop over grid points
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving ngd'
+
+  END SUBROUTINE pheno_ngd
+
+!+++THE ORGINAL PHENOLOGY CODE++++
+! Note that ngd was not reset when begin_leaves was true. The begin leaves conditions
+! could be triggered several times per year. Furthermore, their is no forced dormance
+! period. This approach may have been OK in Siberia but it seems suboptimal for the DGVM
+! or even when prescribing larch (the only PFT with this phenology model) outside of 
+! Siberia but still witin its growing range i.e. the mountains of Europe and N-America.
+
+
+!!$  SUBROUTINE pheno_ngd (npts, j, PFTpresent, allow_initpheno, ngd, &
+!!$       t2m_month, t2m_week, begin_leaves)
+!!$
+!!$    !
+!!$    !! 0. Variable and parameter declaration
+!!$    !
+!!$
+!!$    !
+!!$    !! 0.1 Input variables
+!!$    !
+!!$    INTEGER(i_std), INTENT(in)                               :: npts            !! Domain size - number of grid cells (unitless)
+!!$    INTEGER(i_std), INTENT(in)                               :: j               !! PFT index (unitless)
+!!$    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                 :: PFTpresent      !! PFT exists (true/false)
+!!$    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                 :: allow_initpheno !! are we allowed to declare the beginning of the 
+!!$                                                                                !! growing season? (true/false) 
+!!$    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: ngd             !! growing degree days (C)
+!!$    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month       !! "monthly" 2-meter temperatures (K)
+!!$    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week        !! "weekly" 2-meter temperatures (K)
+!!$
+!!$    !
+!!$    !! 0.2 Output variables
+!!$    !
+!!$
+!!$    !
+!!$    !! 0.3 Modified variables
+!!$    !
+!!$    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves    !! signal to start putting leaves on (true/false)
+!!$
+!!$    !
+!!$    !! 0.4 Local variables
+!!$    !
+!!$    INTEGER(i_std)                                           :: i               !! index (unitless)
+!!$
+!!$    !! =========================================================================
+!!$
+!!$    IF (bavard.GE.2) WRITE(numout,*) 'Entering ngd'
+!!$
+!!$    !
+!!$    !! 1. Initializations
+!!$    !
+!!$
+!!$    !
+!!$    !! 1.1 initialize output
+!!$    !
+!!$
+!!$    begin_leaves(:,j) = .FALSE.
+!!$
+!!$    !
+!!$    !! 1.2 check the critical value ::ngd_crit is defined.
+!!$    !!     If not, stop.
+!!$    !
+!!$
+!!$    IF ( ngd_crit(j) .EQ. undef ) THEN
+!!$
+!!$       WRITE(numout,*) 'ngd: ngd_crit is undefined for PFT (::j) ',j
+!!$       WRITE(numout,*) 'We stop.'
+!!$       STOP
+!!$
+!!$    ENDIF
+!!$
+!!$    !
+!!$    !! 2. Check if biometeorological conditions are favourable for leaf growth.
+!!$    !!    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
+!!$
+!!$          !! 2.1 Determine if the growing season should start (if so, ::begin_leaves set to TRUE).
+!!$          !!     This occurs if the critical NGD has been reached AND are temperatures increasing.
+!!$
+!!$          IF ( ( ngd(i,j) .GE. ngd_crit(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 ! end loop over grid points
+!!$
+!!$    IF (bavard.GE.2) WRITE(numout,*) 'Leaving ngd'
+!!$
+!!$  END SUBROUTINE pheno_ngd
+
+END MODULE stomate_phenology
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_prescribe.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_prescribe.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_prescribe.f90	(revision 7236)
@@ -0,0 +1,1353 @@
+! =================================================================================================================================
+! MODULE       : stomate_prescribe
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         Initialize and update density, height, basal area and crown area. For the resource
+!                limited allocation and the allometric-based allocation
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	:
+!!
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_stomate/stomate_prescribe.f90 $
+!! $Date: 2013-01-04 16:50:56 +0100 (Fri, 04 Jan 2013) $
+!! $Revision: 1126 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE stomate_prescribe
+
+  ! modules used:
+
+  USE ioipsl_para
+  USE stomate_data
+  USE pft_parameters
+  USE function_library,    ONLY: calculate_c0_alloc
+  USE constantes
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC prescribe_diagnostic, prescribe_prognostic, prescribe_clear
+
+    ! first call
+  LOGICAL, SAVE                                      :: firstcall = .TRUE.
+!$OMP THREADPRIVATE(firstcall)
+
+CONTAINS
+
+
+! =================================================================================================================================
+!! SUBROUTINE   : prescribe_clear
+!!
+!>\BRIEF        : Set the firstcall flag back to .TRUE. to prepare for the next simulation.
+!_=================================================================================================================================
+
+  SUBROUTINE prescribe_clear
+    firstcall=.TRUE.
+  END SUBROUTINE prescribe_clear
+
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : prescribe_diagnostic
+!!
+!>\BRIEF         Works only with static vegetation and agricultural PFT. Initialize biomass,
+!!               density, crown area in the first call and update them in the following calls.
+!!
+!! DESCRIPTION (functional, design, flags): \n
+!! This module works only with static vegetation and agricultural PFT. In the first call, initialize 
+!! density of individuals, biomass, crown area, and leaf age distribution to some reasonable value. 
+!! In the following calls, these variables are updated.
+!!
+!! To fulfill these purposes, relationships from the pipe model are used:
+!! \latexonly 
+!!     \input{prescribe1.tex}
+!!     \input{prescribe2.tex}
+!! \endlatexonly
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLES(S): ::ind, ::cn_ind, ::leaf_frac
+!!
+!! REFERENCES   :
+!! - Krinner, G., N. Viovy, et al. (2005). "A dynamic global vegetation model 
+!!   for studies of the coupled atmosphere-biosphere system." Global 
+!!   Biogeochemical Cycles 19: GB1015, doi:1010.1029/2003GB002199.
+!! - Sitch, S., B. Smith, et al. (2003), Evaluation of ecosystem dynamics,
+!!   plant geography and terrestrial carbon cycling in the LPJ dynamic 
+!!   global vegetation model, Global Change Biology, 9, 161-185.
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+ SUBROUTINE prescribe_diagnostic (npts, veget_max, dt, PFTpresent, everywhere, &
+               when_growthinit, biomass, leaf_frac, ind, cn_ind, &
+               co2_to_bm)
+
+
+ !! 0. Parameters and variables declaration
+
+   !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                           :: npts            !! Domain size (unitless)
+    REAL(r_std), INTENT(in)                              :: dt              !! time step (dt_days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)         :: veget_max       !! "maximal" coverage fraction of a PFT 
+                                                                            !! (LAI -> infinity) on ground. 
+                                                                            !! (unitless;0-1)
+    !! 0.2 Output variables 
+
+    !! 0.3 Modified variables
+
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)          :: PFTpresent      !! PFT present (0 or 1)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)      :: everywhere      !! is the PFT everywhere in the grid box or 
+                                                                            !! very localized (after its introduction)
+                                                                            !! (unitless;0-1)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)      :: when_growthinit !! how many days ago was the beginning of 
+                                                                            !! the growing season (days)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                           INTENT(inout) :: biomass         !! biomass @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), &
+                                           INTENT(inout) :: leaf_frac       !! fraction of leaves in leaf age 
+                                                                            !! class (unitless;0-1)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)      :: ind             !! density of individuals 
+                                                                            !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)      :: cn_ind          !! crown area per individual 
+                                                                            !! @tex $(m^{2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)      :: co2_to_bm       !! co2 taken up by carbohydrate 
+                                                                            !! reserve at the beginning of the
+                                                                            !! growing season @tex (gC.m^{-2}dt^{-1})$ @endtex 
+
+    !! 0.4 Local variables
+
+    REAL(r_std), DIMENSION(npts)                         :: dia             !! stem diameter (m)
+    REAL(r_std), DIMENSION(npts,nelements)               :: woodmass        !! woodmass @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nelements)               :: woodmass_ind    !! woodmass of an individual 
+                                                                            !! @tex $(gC.tree^{-1})$ @endtex    
+    INTEGER(i_std)                                       :: i,j             !! index (unitless)
+
+!_ ================================================================================================================================
+
+ !! 1. Calculations at every call of the routine
+
+    DO j = 2,nvm
+
+      ! only when the DGVM is not activated or agricultural PFT.
+      IF ( ( .NOT. control%ok_dgvm .AND. control%ok_constant_mortality ) .OR. ( .NOT. natural(j) ) ) THEN
+
+        !! 1.1 Update crown area
+        cn_ind(:,j) = zero
+
+        IF ( is_tree(j) ) THEN
+
+          !! 1.1.1 Trees
+          dia(:) = zero
+          DO i = 1, npts ! loop over grid points
+
+            IF ( veget_max(i,j) .GT. zero ) THEN
+
+              !! 1.1.1.1 calculate wood mass on an area basis, which include sapwood and heartwood aboveground and belowground.
+              woodmass(i,icarbon) = (biomass(i,j,isapabove,icarbon) + biomass(i,j,isapbelow,icarbon) + &
+                   biomass(i,j,iheartabove,icarbon) + biomass(i,j,iheartbelow,icarbon)) * veget_max(i,j)  
+
+              IF ( woodmass(i,icarbon) .GT. min_stomate ) THEN
+
+                !! 1.1.1.2 calculate critical individual density
+                !?? the logic for 1.1.3 and 1.1.2 is strange, it should be the case that first to calculate critical woodmass 
+                !??per individual, then calculate critical density.
+                ! how to derive the following equation:
+                ! first, TreeHeight=pipe_tune2 * Diameter^{pipe_tune3}
+                ! we assume the tree is an ideal cylinder, so it volume is: 
+                ! Volume = pi*(Dia/2)^2*Height = pi/4 * Dia * pipe_tune2*Dia^{pipe_tune3} 
+                !        = pi/4 * pipe_tune2 * Dia^{2+pipe_tune3}
+                ! last, the woodmass_per_individual = pipe_density * Volume = pipe_density*pi/4.*pipe_tune2 * Dia^{2+pipe_tune3}             
+                ind(i,j) = woodmass(i,icarbon) / &
+                           ( pipe_density(j)*pi/4.*pipe_tune2(j) * maxdia(j)**(2.+pipe_tune3(j)) )
+
+
+                !! 1.1.1.3 individual biomass corresponding to this critical density of individuals
+                woodmass_ind(i,icarbon) = woodmass(i,icarbon) / ind(i,j)
+
+                !! 1.1.1.4 calculate stem diameter per individual tree
+                dia(i) = ( woodmass_ind(i,icarbon) / ( pipe_density(j) * pi/4. * pipe_tune2(j) ) ) ** &
+                         ( un / ( 2. + pipe_tune3(j) ) )
+
+                !! 1.1.1.5 calculate provisional tree crown area for per individual tree
+                !  equation: CrownArea=pipe_tune1 * Diameter^{1.6}
+                cn_ind(i,j) = pipe_tune1(j) * MIN( maxdia(j), dia(i) ) ** pipe_tune_exp_coeff(j)
+
+                !! 1.1.1.6 If total tree crown area for this tree PFT exceeds its veget_max, tree density is recalculated.
+                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(j) * (woodmass(i,icarbon)/(pipe_density(j)*pi/4.*pipe_tune2(j))) &
+                        &     **(pipe_tune_exp_coeff(j)/(2.+pipe_tune3(j))) ) ) &
+                        &     ** (1./(1.-(pipe_tune_exp_coeff(j)/(2.+pipe_tune3(j)))))
+                   woodmass_ind(i,icarbon) = woodmass(i,icarbon) / ind(i,j)
+                   dia(i) = ( woodmass_ind(i,icarbon) / ( pipe_density(j) * pi/4. * pipe_tune2(j) ) ) ** &
+                        &     ( un / ( 2. + pipe_tune3(j) ) )
+                   cn_ind(i,j) = pipe_tune1(j) * MIN( maxdia(j), dia(i) ) ** pipe_tune_exp_coeff(j)
+
+                ENDIF
+
+              ELSE ! woodmass=0  => impose some value
+
+                dia(:) = maxdia(j)
+                cn_ind(i,j) = pipe_tune1(j) * MIN( maxdia(j), dia(i) ) ** pipe_tune_exp_coeff(j)
+
+              ENDIF ! IF ( woodmass .GT. min_stomate )
+
+            ENDIF    ! veget_max .GT. 0.
+
+          ENDDO      ! loop over grid points
+
+        !! 1.2 grasses: crown area always set to 1m**2
+        ELSE
+
+          WHERE ( veget_max(:,j) .GT. zero )
+
+            cn_ind(:,j) = un
+
+          ENDWHERE
+
+        ENDIF   !IF ( is_tree(j) )
+     
+        !! 1.3 density of individuals
+        WHERE ( veget_max(:,j) .GT. zero )
+
+          ind(:,j) = veget_max(:,j) / cn_ind(:,j)  
+
+        ELSEWHERE
+
+          ind(:,j) = zero
+
+        ENDWHERE
+
+      ENDIF     ! IF ( ( .NOT. control%ok_dgvm .AND. control%ok_constant_mortality ) .OR. ( .NOT. natural(j) ) )
+
+    ENDDO       ! loop over PFTs
+
+
+ !! 2. If it's the first call for this module, 
+
+    IF (( firstcall ) .AND. (TRIM(stom_restname_in) == 'NONE')) THEN
+
+      ! impose some biomass if zero and PFT prescribed
+      WRITE(numout,*) 'prescribe:'
+      WRITE(numout,*) '   > Imposing initial biomass for prescribed trees, '// &
+                      'initial reserve mass for prescribed grasses.'
+      WRITE(numout,*) '   > Declaring prescribed PFTs present.'
+
+      DO j = 2,nvm ! loop over PFTs
+
+        DO i = 1, npts ! loop over grid points
+
+          ! is vegetation static or PFT agricultural?
+          ! Static vegetation or agricultural PFT
+          IF ( ( .NOT. control%ok_dgvm ) .OR. &
+               ( ( .NOT. natural(j) ) .AND. ( veget_max(i,j) .GT. min_stomate ) ) ) THEN
+
+            
+            !! 2.1 if tree biomass is extremely small, prescribe the biomass by assuming they have sapling biomass, 
+            !! which is a constant in the model then set all the leaf age as 1.
+            !! if tree PFT and biomass too small, prescribe the biomass to a value.
+            IF ( is_tree(j) .AND. ( veget_max(i,j) .GT. min_stomate ) .AND. &
+                 ( SUM( biomass(i,j,:,icarbon) ) .LE. min_stomate ) ) THEN
+
+               !!? here the code is redundant, as "veget_max(i,j) .GT. min_stomate" is already met in the above if 
+               !!? condition.
+               IF (veget_max(i,j) .GT. min_stomate) THEN
+
+                  biomass(i,j,:,:) = (bm_sapl_rescale * bm_sapl_old(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_model(j) .NE. 'none' ) THEN
+
+                biomass(i,j,ileaf,icarbon) = zero
+                leaf_frac(i,j,1) = zero
+
+              ENDIF
+
+              co2_to_bm(i,j) = co2_to_bm(i,j) + ( SUM(biomass(i,j,:,icarbon))  / dt )
+
+            ENDIF
+
+            !! 2.2 for grasses, set only the carbon reserve pool to "sapling" carbon reserve pool.
+            !!     and set all leaf age to 1.
+            IF ( ( .NOT. is_tree(j) ) .AND. ( veget_max(i,j) .GT. min_stomate ) .AND. &
+                 ( SUM( biomass(i,j,:,icarbon) ) .LE. min_stomate ) ) THEN
+
+              !+++++ CHECK MJM ++++++
+               ! bm_sapl will also be a function of the circumference class...just using the first class right now
+               biomass(i,j,icarbres,:) = bm_sapl_old(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
+
+              co2_to_bm(i,j) = co2_to_bm(i,j) + ( biomass(i,j,icarbres,icarbon)  / dt )
+            
+            ENDIF
+
+            !! 2.3 declare all PFTs with positive veget_max as 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 ! loop over grid points
+
+      ENDDO ! loop over PFTs
+
+      firstcall = .FALSE.
+
+    ENDIF
+
+  END SUBROUTINE prescribe_diagnostic
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : prescribe_prognostic
+!!
+!>\BRIEF         Works only with static vegetation and agricultural PFT. Initialize biomass,
+!!               density, presence in the first call and update them in the following.
+!!
+!! DESCRIPTION (functional, design, flags): \n
+!! This module works only with static vegetation and agricultural PFT.
+!! In the first call, initialize density of individuals, biomass,
+!! and leaf age distribution to some reasonable value. In the following calls,
+!! these variables are updated.
+!!
+!! To fulfill these purposes, pipe model are used:
+!! \latexonly 
+!!     \input{prescribe1.tex}
+!!     \input{prescribe2.tex}
+!! \endlatexonly
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLES(S): ::ind, ::cn_ind, ::leaf_frac
+!!
+!! REFERENCES   :
+!! - Krinner, G., N. Viovy, et al. (2005). "A dynamic global vegetation model 
+!!   for studies of the coupled atmosphere-biosphere system." Global 
+!!   Biogeochemical Cycles 19: GB1015, doi:1010.1029/2003GB002199.
+!! - Sitch, S., B. Smith, et al. (2003), Evaluation of ecosystem dynamics,
+!!   plant geography and terrestrial carbon cycling in the LPJ dynamic 
+!!   global vegetation model, Global Change Biology, 9, 161-185.
+!! - McDowell, N., Barnard, H., Bond, B.J., Hinckley, T., Hubbard, R.M., Ishii, 
+!!   H., KÃ¶stner, B., Magnani, F. Marshall, J.D., Meinzer, F.C., Phillips, N., 
+!!   Ryan, M.G., Whitehead D. 2002. The relationship between tree height and leaf 
+!!   area: sapwood area ratio. Oecologia, 132:12â20.
+!! - Novick, K., Oren, R., Stoy, P., Juang, F.-Y., Siqueira, M., Katul, G. 2009. 
+!!   The relationship between reference canopy conductance and simplified hydraulic 
+!!   architecture. Advances in water resources 32, 809-819. 
+!!
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+ SUBROUTINE prescribe_prognostic (npts, veget_max, veget, dt, PFTpresent, &
+               everywhere, when_growthinit, biomass, leaf_frac, &
+               ind, circ_class_n, circ_class_biomass, co2_to_bm, &
+               forest_managed, KF, &
+               senescence, age, npp_longterm, lm_lastyearmax, &
+               tau_eff_leaf, tau_eff_sap, tau_eff_root, k_latosa_adapt)
+
+!! 0. Parameters and variables declaration
+
+   !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                        :: npts              !! Domain size (unitless)
+    INTEGER(i_std), DIMENSION (:,:), INTENT(in)       :: forest_managed    !! forest management flag
+    REAL(r_std), INTENT(in)                           :: dt                !! time step (dt_days)   
+    REAL(r_std), DIMENSION(:,:), INTENT(in)           :: veget_max         !! "maximal" coverage fraction of a PFT 
+                                                                           !! (LAI -> infinity) on ground. May sum to
+                                                                           !! less than unity if the pixel has
+                                                                           !! nobio area. (unitless; 0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)           :: veget             !! Fraction of vegetation type including 
+                                                                           !! non-biological fraction (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)           :: tau_eff_root      !! Effective root turnover time that accounts
+                                                                           !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)           :: tau_eff_sap       !! Effective sapwood turnover time that accounts
+                                                                           !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)           :: tau_eff_leaf      !! Effective leaf turnover time that accounts
+                                                                           !! waterstress (days)
+
+    !! 0.2 Output variables
+ 
+   
+    !! 0.3 Modified variables
+
+    LOGICAL, DIMENSION(:,:), INTENT(inout)            :: PFTpresent         !! PFT present (0 or 1)
+    LOGICAL, DIMENSION(:,:), INTENT(inout)            :: senescence         !! Flag for setting senescence stage (only 
+                                                                            !! for deciduous trees)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: everywhere         !! is the PFT everywhere in the grid box or 
+                                                                            !! very localized (after its introduction) (?)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: when_growthinit    !! how many days ago was the beginning of 
+                                                                            !! the growing season (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: ind                !! Density of individuals at the stand level 
+                                                                            !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: npp_longterm       !! "long term" net primary productivity
+                                                                            !! @tex ($gC m^{-2} year^{-1}$) @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: age                !! mean age (years)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: lm_lastyearmax     !! last year's maximum leaf mass for each PFT 
+                                                                            !! @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)      :: circ_class_n       !! Number of individuals in each circ class
+                                                                            !! @tex $(ind m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)    :: biomass            !! Stand level biomass 
+                                                                            !! tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout)  :: circ_class_biomass !! Biomass components of the model tree  
+                                                                            !! within a circumference class
+                                                                            !! class @tex $(g C ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: co2_to_bm          !! CO2 taken from the atmosphere to get C
+                                                                            !! to create the seedlings 
+                                                                            !!  @tex (gC.m^{-2}dt^{-1})$ @endtex  
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)      :: leaf_frac          !! fraction of leaves in leaf age 
+                                                                            !! class (unitless;0-1)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: KF                 !! Scaling factor to convert sapwood mass
+                                                                            !! into leaf mass (m) - this variable is 
+                                                                            !! passed to other routines
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)        :: k_latosa_adapt     !! Leaf to sapwood area adapted for long 
+                                                                            !! term water stress (m)
+  
+
+    !! 0.4 Local variables
+
+    REAL(r_std), DIMENSION(npts,nvm)                   :: c0_alloc           !! Root to sapwood tradeoff parameter
+    INTEGER(i_std)                                     :: ipts, ivm, ipar    !! index (unitless)
+    INTEGER(i_std)                                     :: icir, iele, imbc   !! index (unitless)
+    INTEGER(i_std)                                     :: deb,fin, imaxt     !! index (unitless)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements)  :: sync_biomass       !! Temporary stand level biomass 
+                                                                             !! @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                   :: sync_ind           !! Temporary density of individuals at the 
+                                                                             !! stand level @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                   :: k_latosa           !! Height dependent base value to calculate 
+                                                                             !! KF (-) 
+    REAL(r_std), DIMENSION(nvm,ncirc,nparts,nelements) :: bm_sapl            !! Sapling biomass for the functional 
+                                                                             !! allocation with a dimension for the 
+                                                                             !! circumference classes
+                                                                             !! @tex $(gC.ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                   :: LF                 !! Scaling factor to convert sapwood mass
+                                                                             !! into root mass (unitless)
+    REAL(r_std), DIMENSION(npts,nvm)                   :: lstress_fac        !! Light stress factor, based on total
+                                                                             !! transmitted light (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,nvm,ncirc)             :: circ_class         !! circumference of individual trees
+    REAL(r_std)                                        :: lambda             !! lambda of the truncated exponential 
+                                                                             !! distribution of initial diameters 
+                                                                             !! (1/cm**2). Parameterized based on Dhote 
+                                                                             !! (2003): lambda = sqrt(2)/Dg and  
+                                                                             !! Dginit = 1 cm. 
+    REAL(r_std)                                        :: p_max              !! Cumulated probability level at which the 
+                                                                             !! exponential distribution truncated 
+                                                                             !! (dimensionless, 0-1) 
+    REAL(r_std),DIMENSION(ncirc)                       :: circ_ij0           !! Circumference of all individual trees  
+    REAL(r_std),DIMENSION(ncirc)                       :: height_ij0         !! Height of each Circumference of all 
+                                                                             !! individual trees  
+                                                                             !! for 1 ha at gridpoint i and for PFT j  
+                                                                             !! (m). As above, 0 is before thinning 
+    REAL(r_std), DIMENSION(nparts)                     :: bm_init            !! Biomass needed to initiate the next 
+                                                                             !! planting @tex $(gC m^{-2})$ @endtex 
+    REAL(r_std), DIMENSION(ncirc)                      :: nb_trees_i         !! Number of trees in each twentith 
+                                                                             !! circumference quantile of the 
+                                                                             !! distribution (ind) 
+    REAL(r_std)                                        :: excedent           !! Number of trees after truncation to be 
+                                                                             !! reallocated to smaller quantiles of the 
+                                                                             !! distribution (ind) 
+    REAL(r_std)                                        :: max_circ_init      !! Maximum initial circumferences of the 
+                                                                             !! truncated exponential distribution (cm) 
+    REAL(r_std), DIMENSION(ncirc)                      :: ave_tree_height    !! The height of the ideal tree in each
+                                                                             !! circumference class of the 
+                                                                             !! distribution (ind)...not saved since
+                                                                             !! it should only be used for prescribing
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements) :: check_intern       !! Contains the components of the internal
+                                                                             !! mass balance chech for this routine
+                                                                             !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)         :: closure_intern     !! Check closure of internal mass balance
+                                                                             !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)         :: pool_start         !! Start and end pool of this routine 
+                                                                             !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)         :: pool_end           !! Start and end pool of this routine 
+                                                                             !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std)                                        :: delta_KF           !! Difference between new and old estimate 
+                                                                             !! of KF while iterating
+    REAL(r_std)                                        :: min_height_init           
+    REAL(r_std)                                        :: max_height_init           
+    REAL(r_std)                                        :: sapwood_density
+    REAL(r_std)                                        :: dia_init           
+    REAL(r_std)                                        :: wood_init                    
+    REAL(r_std), DIMENSION(ncirc)                      :: height_dist  
+    INTEGER(i_std)                                     :: iloop
+
+    !++++ temp ++++
+!!$    REAL(r_std), DIMENSION(npts,nvm,ncirc)             :: height,dia,cn       !! Tree height calculated from allometric 
+!!$                                                                              !! relationships (m) 
+        
+!_ ================================================================================================================================
+
+ !! 1. Initialize biomass at first call
+
+    !! 1.1.1 Initialize check for mass balance closure
+    !  The mass balance is calculated at the end of this routine
+    !  in section 4
+    !  Initial biomass pool
+    pool_start(:,:,:) = zero
+    DO ipar = 1,nparts
+       DO iele = 1,nelements
+          pool_start(:,:,iele) = pool_start(:,:,iele) + &
+               (biomass(:,:,ipar,iele) * veget_max(:,:))
+       ENDDO
+    ENDDO
+
+   ! co2_to_bm is has as intent inout, the variable accumulates
+   ! carbon over the course of a day. Use the difference between
+   ! start and the end of this routine
+   check_intern(:,:,iatm2land,icarbon) = - un * co2_to_bm(:,:) * veget_max(:,:) * dt
+
+   ! Prescribe was taken out of the first call loop. Because of the firstcall here, 
+   ! nothing was done when the vegetation was killed in lpj_gap and the vegetation
+   ! thus stayed dead forever.  We want it to regrow.  So instead, let's loop over 
+   ! every point and PFT.  If there is supposed to be vegetation here (according to 
+   ! veget_max) but there isn't (according to ind), then we grow it.
+   DO ivm = 2,nvm ! Loop over PFTs
+
+      DO ipts = 1, npts ! Loop over pixels
+
+         ! We are supposed to have vegetation, but we don't have any: prescribe some.
+         IF((veget_max(ipts,ivm) .GT. min_stomate) .AND. (ind(ipts,ivm) .LE. min_stomate))THEN
+
+            ! Initilaize tree level variables
+            circ_class_n(ipts,ivm,:) = zero
+            biomass(ipts,ivm,:,:) = zero
+            circ_class_biomass(ipts,ivm,:,:,:) = zero
+
+            ! Write output
+            IF (ld_presc) THEN
+               WRITE(numout,*) 'Prescribe (stomate_prescribe.f90):'
+               WRITE(numout,*) '   > Imposing initial biomass for prescribed trees, '// &
+                    'initial reserve mass for prescribed grasses.'
+               WRITE(numout,*) '   > Declaring prescribed PFTs present.'
+               WRITE(numout,*) '   > Grid point: ',ipts,' PFT Type: ',ivm
+            ENDIF
+
+            !! 2. Calculate the vegetation characteristics of a newly established vegetation
+
+            !! 2.1 Stress factors
+
+            ! Note that light and water stress have an opposite effect on KF. Waterstress 
+            ! will decrease KF because more C should be allocated to the roots. Light 
+            ! stress will increase KF because more C should be allocated to the leaves.
+
+            ! We will need the c0_alloc, it only depends on PFT and the effective 
+            ! longiveties
+            c0_alloc(ipts,ivm) = calculate_c0_alloc(ipts, ivm, tau_eff_root(ipts,ivm), &
+                 tau_eff_sap(ipts,ivm))
+
+            ! Lightstress varies from 0 to 1 and is calculated from the canopy structure (veget)
+            ! Given that there is no vegetation at this point, the lightstress cannot be calculated 
+            ! and is set to 1. However as soon as we grow a canopy it will experience light stress
+            ! and so KF should be adjusted. If this is not done, we can't prescribe tall vegetation
+            ! which is a useful feature to speed up optimisation and testing. We will have iterate
+            ! over light stress and KF to prescribe vegetation that is in balance with its 
+            ! light environment. 
+            lstress_fac(ipts,ivm) = un
+
+            ! Initial vegetation has to be prescribed only when the vegetation is static
+            IF ( ( .NOT. control%ok_dgvm ) .AND. &
+                 ( veget_max(ipts,ivm) .GT. min_stomate ) )  THEN
+
+               !! 2.2 Initialize woody PFT's 
+               !      Use veget_max to check whether the PFT is present. If the PFT is present but it has no
+               !      biomass, prescribe its biomass (gC m-{2}).
+               IF ( is_tree(ivm) .AND. &
+                    ( veget_max(ipts,ivm) .GT. min_stomate ) .AND. &
+                    ( SUM( biomass(ipts,ivm,:,icarbon) ) .LE. min_stomate ) ) THEN
+
+                  ! PFT is present so it needs to be initialized 
+                  IF (veget_max(ipts,ivm) .GT. min_stomate) THEN
+
+                     ! The forest stand starts with the number of individuals as prescribed in constantes_mtc.f90
+                     ! This number is defined per hectare whereas these calculations are per m2
+                     ind(ipts,ivm) = nmaxtrees(ivm) * ha_to_m2   
+
+                     !! 2.3 Initialize height distribution
+                     !  Initializing height distribution...I've taken this from the circumference initilization of Valentin
+                     !  we want ncirc bins between height_init_min and height_init_max
+                     lambda = SQRT(2.0_r_std)/pi 
+                     min_height_init = height_init_min(ivm)
+                     max_height_init = height_init_max(ivm)
+                     p_max = 100./nmaxtrees(ivm)
+                     height_dist(:) = zero
+
+                     !! 2.4 Calculate height distribution
+
+                     !! 2.4.1 Height distribution of a high stand
+                     !  Deterministic initial distribution following a truncated exponential law 
+                     !  if they are coppices, we handle this differently
+
+                     !++++ CHECK+++++
+                     ! I am treating SRC the same way as everything else for now.
+                     !IF (forest_managed(ipts,ivm) .NE. ifm_src) THEN
+                     nb_trees_i(:) = 0
+
+                     ! The distribution is truncated when P(X>max_circ_init)<p_max
+                     ! The circumference distribution is divided into ncirc quantiles of equal height range. 
+                     ! A integer number of trees is 
+                     ! allocated to each quantile according to the truncated exponential distribution.
+                     DO icir = 1,ncirc ! loop over circumference quantiles
+
+                        nb_trees_i(icir) = NINT(nmaxtrees(ivm)*&
+                             (EXP(-lambda*max_height_init*(icir-1)/ncirc)-EXP(-lambda*max_height_init*icir/ncirc)))
+                        ! this array is going to be used to create the sapling for this class so that we can create 
+                        ! the total amount of biomass
+                        ! in this class...after this we will always calculate the height/circ/diam/whatever 
+                        ! from the biomass in the class
+                        ave_tree_height(icir)=min_height_init+(REAL(icir,r_std)-0.5_r_std)*&
+                             (max_height_init-min_height_init)/REAL(ncirc,r_std)
+
+                        ! I am changing this so that our lowest class is min_height_init and our biggest class
+                        ! is max_height_init.  With this change, we can use the same code the redistribute
+                        ! the trees if the biomass in one of our height classes is equal to zero later on due to mortality or
+                        ! thinning.
+                        !+++ This caused some strange behavior, so change it back for now.
+                        !                        ave_tree_height(icir)=min_height_init+REAL(icir-1,r_std)/REAL(ncirc-1,r_std)*&
+                        !                             (max_height_init-min_height_init)
+
+                     ENDDO
+
+                     excedent = REAL(nmaxtrees(ivm) - SUM(nb_trees_i))
+                     nb_trees_i = nb_trees_i + FLOOR(excedent/ncirc)
+                     nb_trees_i(1) = nb_trees_i(1) + NINT(excedent)-ncirc*FLOOR(excedent/ncirc)
+
+                     IF (ld_presc) THEN
+                        WRITE(numout,*)"min initial height ",min_height_init,'max initial height ',max_height_init
+                        WRITE(numout,*)'nb_trees_i',nb_trees_i
+                     ENDIF
+
+!                     ENDIF ! check FM type
+
+                     ! we need to store the number of trees that we have per square meter for each circumference class
+                     circ_class_n(ipts,ivm,:) = REAL(nb_trees_i(:),r_std) * ha_to_m2 
+
+                     !! 2.4.2 Circumference distribution of a coppice
+                     ! I'm not see why this should be any different than a standard prescribe.
+                     ! Ideally, the plantings should be stems 20-25 cm long stuck into the soil,
+                     ! but the allocation scheme will have the same issues with this that it does
+                     ! with planting a small sapling, i.e. it won't like it.  The stems do not
+                     ! follow standard allocation rules.  Then again, neither do coppices.
+
+!!$                     IF (forest_managed(ipts,ivm) == ifm_src) THEN
+!!$                        WRITE(numout,*) '!********* Problem with SRC ******'
+!!$                        STOP
+!!$                     ENDIF
+
+                     !! 2.5 Allocation factors
+                     !  Sapwood to root ratio
+                     !  Following Magnani et al. 2000 "In order to decreases hydraulic resistance,
+                     !  the investment of carbon in fine roots or sapwood yields to the plant very
+                     !  different returns, both because of different hydraulic conductivities and 
+                     !  because of the strong impact of plant height on shoot resistance. On the 
+                     !  other hand, fine roots and sapwood have markedly different longevities and 
+                     !  the cost of production, discounted for turnover, will differ accordingly.
+                     !  Optimal growth under hydraulic constraints requires that the ratio of marginal 
+                     !  hydraulic returns to marginal annual cost for carbon investment in either roots 
+                     !  or sapwood be the same (Bloom, Chapin & Mooney 1985; Case & Fair 1989). This
+                     !  is formalized in equation (13) and further derived to obtain equation (17) 
+                     !  in Magnani et al 2000. The latter is implemented here.
+                     !  Pipe_density is given in gC/m-3, convert to kg/m-3. And apply equation (17) 
+                     !  in Magnani et al 2000. Note that c0_alloc was calculated at the start of this 
+                     !  routine. The calculation itself is done in function_library
+                     
+                     ! Calculate leaf area to sapwood area
+                     ! To be consistent with the hydraulic limitations and pipe theory,
+                     ! k_latosa is calculated from equation (18) in Magnani et al.
+                     ! To do so, total hydraulic resistance and tree height need to known. This
+                     ! poses a problem as the resistance depends on the leaf area and the leaf 
+                     ! area on the resistance. There is no independent equation and equations 12
+                     ! and 18 depend on each other and substitution would be circular. Hence 
+                     ! prescribed k_latosa values were obtained from observational records 
+                     ! and are given in mtc_parameters.f90. 
+
+                     ! The relationship between height and k_latosa as reported in McDowell 
+                     ! et al 2002 and Novick et al 2009 is implemented to adjust k_latosa for 
+                     ! the height of the stand. This did NOT result in a realistic model behavior 
+                     !!$ k_latosa(ipts,ivm) = wstress_fac(ipts,ivm) * &
+                     !!$    (k_latosa_max(ivm) - (latosa_height(ivm) * &
+                     !!$    (SUM( nb_trees_i(:) * ave_tree_height(:) ) / SUM( nb_trees_i(:) ))))
+
+                     ! Alternatively, k_latosa is also reported to be a function of diameter 
+                     ! (i.e. stand thinning, Simonin et al 2006, Tree Physiology, 26:493-503).
+                     ! Here the relationship with thinning was interpreted as a realtionship with
+                     ! light stress. Note that light stress cannot be calculated at this time in
+                     ! the model because there is no canopy (that's why we are in prescribe!) and
+                     ! so there is no lightstress. lstress was therefore set to one (see above).
+                     ! We prefered this redundancy in the code because it makes it clear that
+                     ! k_latosa is calculated in the same way in prescribe.f90 and growth_fun_all.f90
+                     ! +++CHECK+++
+                     ! How do we want to deal with waterstress
+!!$                     k_latosa(ipts,ivm) = k_latosa_min(ivm) + &
+!!$                          (wstress_fac(ipts,ivm) * lstress_fac(ipts,ivm) * &
+!!$                          (k_latosa_max(ivm)-k_latosa_min(ivm)))
+!!$                     k_latosa(ipts,ivm) = wstress_fac(ipts,ivm) * (k_latosa_min(ivm) + &
+!!$                          (lstress_fac(ipts,ivm) * &
+!!$                          (k_latosa_max(ivm)-k_latosa_min(ivm))))
+                     k_latosa(ipts,ivm) = (k_latosa_adapt(ipts,ivm) + &
+                            (lstress_fac(ipts,ivm) * &
+                          (k_latosa_max(ivm)-k_latosa_min(ivm))))
+                     ! ++++++++++++
+                     
+
+                     ! Also k_latosa has been reported to be a function of CO2 concentration 
+                     ! (Atwell et al. 2003, Tree Physiology, 23:13-21 and Pakati et al. 2000, 
+                     ! Global Change Biology, 6:889-897). This effect is not accounted for in 
+                     ! the current code
+
+                     ! Calculate conversion coefficient for sapwood area to leaf area 
+                     ! (1) The scaling parameter between leaf and sapwood mass is derived from
+                     ! LA_ind = k_latosa * SA_ind, where LA_ind = leaf area of an individual, SA_ind is the 
+                     ! sapwood area of an individual and k_latosa a pipe-model parameter
+                     ! (2) LA_ind = Cl * sla
+                     ! (3) Cs = SA_ind * height * wooddensity * tree_ff
+                     ! Substitute (2) and (3) in (1)
+                     ! Cl = Cs * k1 / (wooddensity * sla * tree_ff * height)
+                     ! Cl = Cs*KF/height, where KF is in (m)
+                     ! KF is passed to the allocation routine and it is saved in the restart file.
+                     KF(ipts,ivm) = k_latosa(ipts,ivm) / ( sla(ivm) * pipe_density(ivm) * tree_ff(ivm))
+                     
+                     ! Initialize delta_KF to get the DO WHILE started
+                     delta_KF = un
+
+                     iloop=0
+                     DO WHILE (delta_KF .GT. max_delta_KF)
+
+                        !  If there is a WHILE loop, there always needs to be a check on the number
+                        ! of loops to make sure we don't get stuck in an infinite loop.  This
+                        ! number is completely arbitrary.
+                        iloop=iloop+1
+                        IF(iloop > 1000)THEN
+                           WRITE(numout,*) 'Taking too long to converge the delta_KF loop in prescribe!'
+                           WRITE(numout,*) 'iloop,delta_KF,max_delta_KF,ivm,ipts: ',&
+                                iloop,delta_KF,max_delta_KF,ivm,ipts
+                           STOP
+                        ENDIF
+
+                        !! 2.6 Create saplings for each height class
+                        !  Now we create the saplings for each class, based on the height
+                        DO icir = 1,ncirc
+                           
+                           ! The assumption we make is that we plant trees of 2 to 3 years old rather than 
+                           ! growing trees from seeds. The allometric relationship between height and 
+                           ! diameter is derived from mature tree and likely unrealistic for saplings. 
+                           ! The height of the saplings is prescribed and determines the reserves which are 
+                           ! especially important for deciduous species which need to survive on their 
+                           ! reserves for the first year (new phenology scheme requires annual mean values
+                           ! to get started) 
+                           dia_init = ( ave_tree_height(icir) / pipe_tune2(ivm) ) ** ( 1. / pipe_tune3(ivm) )
+                           wood_init = ( ave_tree_height(icir) * pi / 4. * (dia_init) ** 2. ) * &
+                                pipe_density(ivm) * tree_ff(ivm)
+                           
+                           ! The woody biomass is contained in four components. Thus, wood_init = isapabove + 
+                           ! isapbelow + iheartabove + iheartbelow. Given that isapbelow = isapbelow and 
+                           ! iheartabove = iheartbelow =  bm_sapl_heartabove*isapabove. If bm_sapl_heartbelow = 
+                           ! bm_sapl_heartabove = 0.2, then isapabove = wood_init/2.4
+                           bm_sapl(ivm,icir,isapabove,icarbon) = wood_init / (2. + bm_sapl_heartabove + bm_sapl_heartbelow) 
+                           bm_sapl(ivm,icir,isapbelow,icarbon) = bm_sapl(ivm,icir,isapabove,icarbon)
+                           bm_sapl(ivm,icir,iheartabove,icarbon) =  bm_sapl_heartabove * bm_sapl(ivm,icir,isapabove,icarbon)
+                           bm_sapl(ivm,icir,iheartbelow,icarbon) =  bm_sapl_heartbelow * bm_sapl(ivm,icir,isapbelow,icarbon)          
+                           
+                           ! Use the allometric relationships to calculate initial leaf and root mass 
+                           bm_sapl(ivm,icir,ileaf,icarbon) = ( bm_sapl(ivm,icir,isapabove,icarbon) + &
+                                bm_sapl(ivm,icir,isapbelow,icarbon) ) * KF(ipts,ivm) /  ave_tree_height(icir) 
+                           !+++CHECK+++
+                           !How do we want to deal with water stress? wstress is accounted for through c0
+!!$                           bm_sapl(ivm,icir,iroot,icarbon) = bm_sapl(ivm,icir,ileaf,icarbon) / ( KF(ipts,ivm) * c0_alloc(ivm) )
+                           bm_sapl(ivm,icir,iroot,icarbon) = bm_sapl(ivm,icir,ileaf,icarbon) / &
+                                ( KF(ipts,ivm) * c0_alloc(ipts,ivm) )
+                           !+++++++++++
+                           
+                           ! Write initial values
+                           IF (ld_presc) THEN 
+                              WRITE(numout,*) ' Circumference class: ',icir,' PFT type: ',ivm
+                              WRITE(numout,*) '       root to sapwood tradeoff p :', c0_alloc(ipts,ivm)
+                              WRITE(numout,*) 'height_init, dia_init, wood_init, ', &
+                                   ave_tree_height(icir) , dia_init, wood_init
+                              WRITE(numout,*) 'pipe_density, ',pipe_density(ivm)
+                           ENDIF
+                           
+                           !++++++ CHECK ++++++
+                           ! The carbohydrate reserves do not seem to be set before this line.  This
+                           ! is a problem since it then uses an unitililized value.  Therefore, I
+                           ! will initilize it.
+                           ! Should this really be zero? If so the code below is nonesensical and icarbres
+                           ! could be omitted. nonesensical code = 2 * (bm_sapl(ivm,icir,icarbres,icarbon) + &
+                           !        bm_sapl(ivm,icir,ileaf,icarbon) + bm_sapl(ivm,icir,iroot,icarbon))
+                           bm_sapl(ivm,icir,icarbres,icarbon)=zero
+                           !++++++++++++++++++
+                           
+                           ! Pools that are defined in the same way for trees and grasses      
+                           bm_sapl(ivm,icir,ifruit,icarbon) = zero
+                           bm_sapl(ivm,icir,ilabile,icarbon) = labile_to_total * (bm_sapl(ivm,icir,ileaf,icarbon) + &
+                                fcn_root(ivm) * bm_sapl(ivm,icir,iroot,icarbon) + fcn_wood(ivm) * &
+                                (bm_sapl(ivm,icir,isapabove,icarbon) + bm_sapl(ivm,icir,isapbelow,icarbon) + &
+                                bm_sapl(ivm,icir,icarbres,icarbon)))
+                           
+                           ! Avoid deciduous PFTs to have leaves out at establishment
+                           ! Whether the saplings have leaves or don't have leaves the first year doesn't really matter
+                           ! Either the approach is correct in the northern hemisphere or in the southern hemisphere. Note
+                           ! that the resource limitation approach starts with the sapling having leaves.
+                           ! Anyhow, a spin-up is needed to avoid issues with the initial conditions
+                           IF ( pheno_type(ivm) .NE. 1 ) THEN
+                              
+                              ! Not evergreen. Deciduous PFTs now need to survive an extra year before bud burst. To 
+                              ! ensure survival there are several options: (a) either the height of the initial 
+                              ! vegetation is increased (this results in more reserves) or (b) the reserves could be
+                              ! increased. The second option may result in numerical issues further down
+                              ! the code as the optimal reserve level is calculated from the other biomass pools.
+                              ! Also some initial tests showed that higher results simply resulted in more respiration.
+                              ! Use taller trees to start with.
+                              bm_sapl(ivm,icir,icarbres,icarbon) = (bm_sapl(ivm,icir,icarbres,icarbon) + &
+                                   bm_sapl(ivm,icir,ileaf,icarbon) + bm_sapl(ivm,icir,iroot,icarbon))
+                              bm_sapl(ivm,icir,ileaf,icarbon) = zero
+                              bm_sapl(ivm,icir,iroot,icarbon) = zero
+
+                              ! When deciduous trees have no leaves they are senescent
+                              senescence(ipts,ivm) = .TRUE.
+                              
+                           ELSE
+                              
+                              ! Initilize carbohydrate reserves for evergreen PFTs
+                              bm_sapl(ivm,icir,icarbres,icarbon) = zero
+
+                              ! Evergreen trees never go into senescence
+                              senescence(ipts,ivm) = .FALSE.
+                              
+                           ENDIF
+                           
+                           IF (ld_presc) THEN
+                              WRITE(numout,*) '       sapling biomass (gC):',icir,ivm,ipts
+                              WRITE(numout,*) '         leaves: (::bm_sapl(ivm,icir,ileaf,icarbon))',&
+                                   bm_sapl(ivm,icir,ileaf,icarbon)
+                              WRITE(numout,*) '         sap above ground: (::bm_sapl(ivm,icir,ispabove,icarbon)):',&
+                                   bm_sapl(ivm,icir,isapabove,icarbon)
+                              WRITE(numout,*) '         sap below ground: (::bm_sapl(ivm,icir,isapbelow,icarbon))',&
+                                   bm_sapl(ivm,icir,isapbelow,icarbon)
+                              WRITE(numout,*) '         heartwood above ground: (::bm_sapl(ivm,icir,iheartabove,icarbon))',&
+                                   bm_sapl(ivm,icir,iheartabove,icarbon)
+                              WRITE(numout,*) '         heartwood below ground: (::bm_sapl(ivm,icir,iheartbelow,icarbon))',&
+                                   bm_sapl(ivm,icir,iheartbelow,icarbon)
+                              WRITE(numout,*) '         roots: (::bm_sapl(ivm,icir,iroot,icarbon))',&
+                                   bm_sapl(ivm,icir,iroot,icarbon)
+                              WRITE(numout,*) '         fruits: (::bm_sapl(ivm,icir,ifruit,icarbon))',&
+                                   bm_sapl(ivm,icir,ifruit,icarbon)
+                              WRITE(numout,*) '         carbohydrate reserve: (::bm_sapl(ivm,icir,icarbres,icarbon))',&
+                                   bm_sapl(ivm,icir,icarbres,icarbon)
+                              WRITE(numout,*) '         labile reserve: (::bm_sapl(ivm,icir,ilabile,icarbon))',&
+                                   bm_sapl(ivm,icir,ilabile,icarbon)
+                           ENDIF
+                           
+                        ENDDO
+                        
+                        IF (ld_presc) THEN
+                           WRITE(numout,*)'Initial distribution, method 2',ivm
+                           WRITE(numout,*)'Average trees height (m): ',ave_tree_height(:)
+                           WRITE(numout,*) 'lambda',lambda,'nmaxtrees(ivm)',nmaxtrees(ivm)
+                        ENDIF
+                        
+                        !! 2.7 Determine the biomass in each circumference class.
+                        !  I do this based on the biomass in each sapling and the number of trees in each
+                        !  circumference class...we need the biomass in an average tree
+                        DO icir=1,ncirc
+                           
+                           circ_class_biomass(ipts,ivm,icir,:,icarbon) = bm_sapl(ivm,icir,:,icarbon)
+                           
+                        ENDDO
+
+                        ! Now the total biomass is just a sum over all of these
+                        DO ipar = 1,nparts
+                           
+                           biomass(ipts,ivm,ipar,icarbon)= &
+                                SUM(circ_class_biomass(ipts,ivm,:,ipar,icarbon)*circ_class_n(ipts,ivm,:))
+
+                        ENDDO
+
+                        ! The light stress should be calculated making use of Pgap so it accounts for LAI
+                        ! crown dimensions and tree distribution. However, this would be computationally 
+                        ! expensive so we just use a first order estimate based on light attenuation model 
+                        ! by Lambert-Beer. When LAI is low, a lot of light reaches the forest floor and so
+                        ! KF should increase to make use of the available light by growing leaves
+                        lstress_fac = exp(-biomass(ipts,ivm,ileaf,icarbon) * sla(ivm) * 0.5)
+                        delta_KF = ABS (KF(ipts,ivm) - ((k_latosa_adapt(ipts,ivm) + &
+                          (lstress_fac(ipts,ivm) * (k_latosa_max(ivm)-k_latosa_min(ivm))))) / &
+                          ( sla(ivm) * tree_ff(ivm) * pipe_density(ivm) ))
+                        KF(ipts,ivm) = ((k_latosa_adapt(ipts,ivm) + &
+                          (lstress_fac(ipts,ivm) * &
+                          (k_latosa_max(ivm)-k_latosa_min(ivm)))) / &
+                          ( sla(ivm) * tree_ff(ivm) * pipe_density(ivm) ))
+
+                        IF(ld_presc)THEN
+                           WRITE(numout,*) 'prescribe delta_KF, ', delta_KF
+                           WRITE(numout,*) 'prescribe lstress, ', lstress_fac
+                        ENDIF
+                     END DO
+
+                     IF (ld_presc) THEN
+                        WRITE(numout,*)'Initial biomass distribution'
+                        DO icir=1,ncirc
+                           WRITE(numout,*) circ_class_biomass(ipts,ivm,icir,:,icarbon),circ_class_n(ipts,ivm,icir)
+                        ENDDO
+                        WRITE(numout,*)'End initial biomass distribution',SUM(circ_class_n(ipts,ivm,:))
+                        WRITE(numout,*)"biomass(ipts,ivm,:,icarbon)",biomass(ipts,ivm,:,icarbon)
+                     END IF
+
+                     IF (ivm .EQ. test_pft .AND. ld_presc) THEN
+                        WRITE(numout,*) 'Check prescribe'
+                        WRITE(numout,*) 'stomate_prescribe::init circ_class_n  ',&
+                             ipts,ivm,circ_class_n(ipts,ivm,:)
+                        DO ipar = 1,nparts
+                           WRITE(numout,*) 'biomass vs circ_class_biomass (gC m-2), ',&
+                                ipts,ivm,ipar,biomass(ipts,ivm,ipar,icarbon), &
+                                SUM(circ_class_biomass(ipts,ivm,:,ipar,icarbon)*circ_class_n(ipts,ivm,:))
+                           WRITE(numout,*) 'stomate_prescribe::init biomass  ',&
+                                ipts,ivm,circ_class_biomass(ipts,ivm,:,ipar,icarbon)
+                        ENDDO
+                     ENDIF
+
+                  ! PFT is not present
+                  ELSE
+
+                     ! At the tree level
+                     circ_class_n(ipts,ivm,:) = zero
+                     circ_class_biomass(ipts,ivm,:,:,icarbon) = zero
+
+                     ! At the stand level
+                     biomass(ipts,ivm,:,icarbon) = zero
+                     ind(ipts,ivm) = zero
+
+                  ENDIF
+
+                  ! Set leaf age classes, all leaves are current year leaves
+                  leaf_frac(ipts,ivm,:) = zero
+                  leaf_frac(ipts,ivm,1) = un
+
+                  !+++CHECK+++
+                  ! Set time since last beginning of growing season but only
+                  ! for the first day of the whole simulation. When the model
+                  ! is initialized when_growthinit is set to undef. In subsequent
+                  ! time steps it should have a value. For trees without phenology
+                  ! the growing season starts at the moment the PFT is prescribed
+                  IF (when_growthinit(ipts,ivm) .EQ. undef) THEN
+                     when_growthinit(ipts,ivm) = 200
+                  ENDIF
+                  !+++++++++++
+
+                  ! Seasonal trees have no leaves at beginning
+                  ! Saplings of evergreen trees have a leaf mass on day 1 and mass in the other components
+                  ! saplings of deciduous trees have no leaves on day 1 but mass in the other components.
+                  IF ( pheno_model(ivm) .NE. 'none' ) THEN
+
+                     ! Add the carbon from the leaves to the reserve pool
+                     biomass(ipts,ivm,icarbres,icarbon) = biomass(ipts,ivm,icarbres,icarbon) + biomass(ipts,ivm,ileaf,icarbon)
+                     biomass(ipts,ivm,ileaf,icarbon) = zero
+                     leaf_frac(ipts,ivm,1) = zero
+
+                     !+++CHECK+++
+                     ! Set time since last beginning of growing season but only
+                     ! for the first day of the whole simulation. When the model
+                     ! is initialized when_growthinit is set to undef. In subsequent
+                     ! time steps it should have a value. The phenology module 
+                     ! prevents leaf onset soon after senescence, by setting 
+                     ! ::when_growthinit to a value, leaf offset 
+                     ! will occur at the first opportunity 
+!!$                     when_growthinit(ipts,ivm) = large_value
+                     IF (when_growthinit(ipts,ivm) .EQ. undef) THEN
+                        when_growthinit(ipts,ivm) = 200
+                     ENDIF
+                     !++++++++++++
+
+                     ! Redundant, flag has already been set. When there are no leaves, the tree is in senescence
+                     senescence(ipts,ivm) = .TRUE.
+
+                  ENDIF ! pheno_model(ivm)
+
+                  ! The biomass to build the saplings is taken from the atmosphere, keep track of
+                  ! amount to calculate the C-balance closure
+                  co2_to_bm(ipts,ivm) = co2_to_bm(ipts,ivm) + ( SUM(biomass(ipts,ivm,:,icarbon))  / dt )          
+
+               ENDIF ! tree(ivm)
+
+               !! 2.8 Initialize grassy PFTs
+               !! Use veget_max to check whether the PFT is present. If the PFT is present but it 
+               !! has no biomass, prescribe its biomass (gC m-{2}). It is assumed that at day 1 
+               !! grasses have all their biomass in the reserve pool. The criteria exclude crops.
+               !! Crops are no longer prescribed but planted the day that begin_leaves is true.    
+               
+               !+++TEMP+++
+               IF(ld_presc .AND. test_pft == ivm)THEN
+                  WRITE(numout,*) 'prescribe - total biomass, ',SUM(biomass(ipts,ivm,:,icarbon))
+               ENDIF
+               !++++++++++
+
+               IF ( ( .NOT. is_tree(ivm) ) .AND. &
+                    ( natural(ivm) ) .AND. &
+                    ( veget_max(ipts,ivm) .GT. min_stomate ) .AND. &
+                    ( SUM( biomass(ipts,ivm,:,icarbon) ) .LE. min_stomate ) ) THEN
+
+                  !+++TEMP+++
+                  IF(ld_presc .AND. test_pft == ivm)THEN
+                     WRITE(numout,*) 'We will prescribe a new vegetation, the old one died'
+                  ENDIF
+                  !++++++++++
+
+                  ! For grasses we assume that an individual grass is 1 m2 of grass. This is set
+                  ! in nmaxtrees in pft_parameters.f90. It could be set to another value but 
+                  ! with the current code this should not have any meaning. The grassland
+                  ! does not necessarily covers the whole 1 m2 so adjust for the canopy cover
+                  ind(ipts,ivm) = nmaxtrees(ivm) * ha_to_m2 * canopy_cover(ivm)
+
+                  ! now we generate the size of a single grass sapling...this was all taken from
+                  ! stomate_data.f90...we do not deal with circumference classes for grasses
+                  ! and crops, but we want to keep the arrays the same as for the trees so
+                  ! we put the sapling information into the first circumference class
+                
+                  !+++CHECK+++
+                  ! Calculate the sapwood to leaf mass in a similar way as has been done for trees.
+                  ! For trees this approach had been justified by observations. For grasses such
+                  ! justification is not supported by observations but we didn't try to find it.
+                  ! Needs more work by someone interested in grasses. There might be a more elegant
+                  ! solution making use of a well observed parameter. 
+!!$                  k_latosa(ipts,ivm) = k_latosa_min(ivm) + &
+!!$                       (wstress_fac(ipts,ivm) * lstress_fac(ipts,ivm) * &
+!!$                       (k_latosa_max(ivm)-k_latosa_min(ivm)))
+!!$                  k_latosa(ipts,ivm) = wstress_fac(ipts,ivm) * (k_latosa_min(ivm) + &
+!!$                       (lstress_fac(ipts,ivm) * &
+!!$                       (k_latosa_max(ivm)-k_latosa_min(ivm))))
+                  k_latosa(ipts,ivm) = (k_latosa_adapt(ipts,ivm) + &
+                       (lstress_fac(ipts,ivm) * &
+                       (k_latosa_max(ivm)-k_latosa_min(ivm))))
+
+                  ! The mass of the structural carbon relates to the mass of the leaves through
+                  ! a prescribed parameter ::k_latosa
+                  KF(ipts,ivm) = k_latosa(ipts,ivm)
+                  !+++++++++++
+
+                  ! Calculate leaf to root area    
+                  LF(ipts,ivm) = c0_alloc(ipts,ivm) * KF(ipts,ivm)
+
+                  !---TEMP---
+                  IF(ld_presc .AND. test_pft == ivm)THEN
+                     WRITE(numout,*) 'KF, ', k_latosa(ipts,ivm), KF(ipts,ivm)
+                     WRITE(numout,*) 'LF, c0_alloc, ', c0_alloc(ipts,ivm) * KF(ipts,ivm), &
+                       c0_alloc(ipts,ivm)
+                  ENDIF
+                  !----------
+
+                  ! initialize everything to make sure there are not random values floating around
+                  ! for ncirc != 1
+                  bm_sapl(ivm,:,:,icarbon) = val_exp
+
+                  ! Similar as for trees, the initial height of the vegetation was defined 
+                  bm_sapl(ivm,1,ileaf,icarbon) = height_init_min(ivm) / lai_to_height(ivm) / sla(ivm)
+
+                  ! Use allometric relationships to define the root mass based on leaf mass. Some 
+                  ! sapwood mass is needed to store the reserves. An arbitrairy fraction of 5% was
+                  ! used 
+                  bm_sapl(ivm,1,iroot,icarbon) = bm_sapl(ivm,1,ileaf,icarbon) / LF(ipts,ivm)
+                  bm_sapl(ivm,1,isapabove,icarbon) = bm_sapl(ivm,1,ileaf,icarbon) / KF(ipts,ivm)
+
+                  ! Some of the biomass components that exist for trees are undefined for grasses
+                  bm_sapl(ivm,1,isapbelow,icarbon) = zero
+                  bm_sapl(ivm,1,iheartabove,icarbon) = zero
+                  bm_sapl(ivm,1,iheartbelow,icarbon) = zero
+                  bm_sapl(ivm,1,ifruit,icarbon) = zero
+                  bm_sapl(ivm,1,icarbres,icarbon) = zero
+
+                  ! Pools that are defined in the same way for trees and grasses      
+                  bm_sapl(ivm,1,ilabile,icarbon) = labile_to_total * (bm_sapl(ivm,1,ileaf,icarbon) + &
+                       fcn_root(ivm) * bm_sapl(ivm,1,iroot,icarbon) + fcn_wood(ivm) * &
+                       (bm_sapl(ivm,1,isapabove,icarbon) + bm_sapl(ivm,1,isapbelow,icarbon) + &
+                       bm_sapl(ivm,1,icarbres,icarbon)))
+
+                  ! Avoid deciduous PFTs to have leaves out at establishment
+                  ! Whether the saplings have leaves or don't have leaves the first year doesn't really matter
+                  ! Either the approach is correct in the northern hemisphere or in the southern hemisphere. Note
+                  ! that the resource limitation approach starts with the sapling having leaves.
+                  ! Anyhow, a spin-up is needed to avoid issues with the initial conditions
+                  IF ( pheno_type(ivm) .NE. 1 ) THEN
+
+                     ! Not evergreen. Deciduous PFTs now need to survive an extra year before bud burst. To 
+                     ! ensure survival there are several options: (a) either the height of the initial 
+                     ! vegetation is increased (this results in more reserves) or (b) the reserves could be
+                     ! increased. The second option may result in result in numerical issues further down
+                     ! the code as the optimal reserve level is calculated from the other biomass pools
+                     bm_sapl(ivm,1,icarbres,icarbon) = bm_sapl(ivm,1,icarbres,icarbon) + bm_sapl(ivm,1,ileaf,icarbon) + &
+                          bm_sapl(ivm,1,iroot,icarbon)
+                     bm_sapl(ivm,1,ileaf,icarbon) = zero
+                     bm_sapl(ivm,1,iroot,icarbon) = zero
+
+                     ! When there are no leaves, the crop/grass is in senescence
+                     senescence(ipts,ivm) = .TRUE.
+
+                  ELSE
+
+                     ! Initilize carbohydrate reserves for evergreen PFTs
+                     bm_sapl(ivm,1,icarbres,icarbon) = zero 
+
+                     ! Evergreen plants never go into senescence
+                     senescence(ipts,ivm) = .FALSE.
+
+                  ENDIF
+
+                  IF (ld_presc) THEN
+                     WRITE(numout,*) '       sapling biomass (gC):',1,ivm,ipts
+                     WRITE(numout,*) '         leaves: (::bm_sapl(ivm,1,ileaf,icarbon))',&
+                          bm_sapl(ivm,1,ileaf,icarbon)
+                     WRITE(numout,*) '         sap above ground: (::bm_sapl(ivm,1,ispabove,icarbon)):',&
+                          bm_sapl(ivm,1,isapabove,icarbon)
+                     WRITE(numout,*) '         sap below ground: (::bm_sapl(ivm,1,isapbelow,icarbon))',&
+                          bm_sapl(ivm,1,isapbelow,icarbon)
+                     WRITE(numout,*) '         heartwood above ground: (::bm_sapl(ivm,1,iheartabove,icarbon))',&
+                          bm_sapl(ivm,1,iheartabove,icarbon)
+                     WRITE(numout,*) '         heartwood below ground: (::bm_sapl(ivm,1,iheartbelow,icarbon))',&
+                          bm_sapl(ivm,1,iheartbelow,icarbon)
+                     WRITE(numout,*) '         roots: (::bm_sapl(ivm,1,iroot,icarbon))',&
+                          bm_sapl(ivm,1,iroot,icarbon)
+                     WRITE(numout,*) '         fruits: (::bm_sapl(ivm,1,ifruit,icarbon))',&
+                          bm_sapl(ivm,1,ifruit,icarbon)
+                     WRITE(numout,*) '         carbohydrate reserve: (::bm_sapl(ivm,1,icarbres,icarbon))',&
+                          bm_sapl(ivm,1,icarbres,icarbon)
+                     WRITE(numout,*) '         labile reserve: (::bm_sapl(ivm,1,ilabile,icarbon))',&
+                          bm_sapl(ivm,1,ilabile,icarbon)
+                  ENDIF
+
+                  ! Write initial values
+                  IF (ld_presc) THEN
+                     WRITE(numout,*) '       root to sapwood tradeoff (LF) : ', c0_alloc(ipts,ivm)
+                     WRITE(numout,*) '       grass sapling biomass: ',bm_sapl(ivm,1,:,icarbon)
+                  ENDIF
+
+                  ! Initial biomass (g C m-2)
+                  biomass(ipts,ivm,:,icarbon) = bm_sapl(ivm,1,:,icarbon) * ind(ipts,ivm)
+                  IF (ld_presc) THEN 
+                     WRITE(numout,*) 'bm_grass, prescribe, ', biomass(ipts,ivm,:,icarbon)
+                  ENDIF
+
+                  ! Synchronize biomass and circ_class_biomass (gC tree-1). This 
+                  ! allows to more easily check the mass balance closure
+                  circ_class_biomass(ipts,ivm,1,:,icarbon) = bm_sapl(ivm,1,:,icarbon)
+                  circ_class_n(ipts,ivm,1) = ind(ipts,ivm)
+
+                  ! Set leaf age classes -> all leaves will be current year leaves
+                  leaf_frac(ipts,ivm,:) = zero
+                  leaf_frac(ipts,ivm,1) = un
+
+                  ! Set time since last beginning of growing season but only
+                  ! for the first day of the whole simulation. When the model
+                  ! is initialized when_growthinit is set to undef. In subsequent
+                  ! time steps it should have a value.
+!!$                  when_growthinit(ipts,ivm) = large_value
+                  IF (when_growthinit(ipts,ivm) .EQ. undef) THEN
+                     when_growthinit(ipts,ivm) = 200
+                  ENDIF
+
+                  ! The biomass to build the saplings is taken from the atmosphere, keep track of
+                  ! amount to calculate the C-balance closure
+                  co2_to_bm(ipts,ivm) = co2_to_bm(ipts,ivm) + ( SUM(biomass(ipts,ivm,:,icarbon))  / dt )
+
+               ELSEIF (.NOT. natural(ivm)) THEN
+
+                  ! Initialize croplands - else leaves_begin will never become true
+                  ! Set time since last beginning of growing season but only
+                  ! for the first day of the whole simulation. When the model
+                  ! is initialized when_growthinit is set to undef. In subsequent
+                  ! time steps it should have a value.
+                  IF (when_growthinit(ipts,ivm) .EQ. undef) THEN
+                     when_growthinit(ipts,ivm) = 200
+                  ENDIF
+
+               ENDIF ! .NOT. tree(ivm)
+
+               !! 2.3 Declare PFT present 
+               !! Now that the PFT has biomass it should be declared 'present'
+               !! everywhere in that grid box. Assign some additional properties
+               PFTpresent(ipts,ivm) = .TRUE.
+               everywhere(ipts,ivm) = un
+               age(ipts,ivm) = zero
+               npp_longterm(ipts,ivm) = npp_longterm_init
+               lm_lastyearmax(ipts,ivm) = zero
+
+            ENDIF   ! not control%ok_dgvm  or agricultural
+
+         ENDIF ! IF (veget_max .GT. zero .AND. ind .EQ. zero)
+
+      ENDDO ! loop over pixels
+
+   ENDDO ! loop over PFTs
+
+ !! 3. Scynchronize biomass and circ_class_biomass 
+   
+   ! For trees both biomass and circ_class_biomass are recorded. Where biomass
+   ! contains the stand level biomass of the different components (gC m-2), 
+   ! circ_class_biomass contains the biomass of a model tree in each circumference
+   ! class (gC tree-1). When multiplied with the number of trees in each circumference
+   ! class (::circ_class_n), biomass and circ_class_biomass should be identical.
+   ! This has been checked in all routines where biomass is calculated and at the
+   ! daily level consistency between both variables is maintained. However, due
+   ! to precision issues and the fact tha biomass and circ_class_biomass are 
+   ! cumulative variables, the difference between both variables accumulates to 
+   ! 0.00001 at the annual level. To avoid propagation of the precision error
+   ! both variables are synchronized daily.
+
+   ! Initialze the variables for the synchronisation
+   sync_ind(:,:) = zero
+   sync_biomass(:,:,:,:) = zero
+
+   ! Synchronize
+   DO ivm = 1,nvm
+
+      IF (is_tree(ivm)) THEN
+
+         DO icir = 1,ncirc
+
+            ! Temporary stand density 
+            sync_ind(:,ivm) = sync_ind(:,ivm) + circ_class_n(:,ivm,icir)
+
+            DO iele = 1,nelements
+
+               ! Temporary biomass
+               DO ipar = 1,nparts
+
+                  sync_biomass(:,ivm,ipar,iele) = sync_biomass(:,ivm,ipar,iele) + &
+                       circ_class_n(:,ivm,icir) * circ_class_biomass(:,ivm,icir,ipar,iele)
+
+               ENDDO ! nparts
+
+            ENDDO ! nelements
+
+         ENDDO ! ncirc
+
+         ! Synchronize stand density 
+         DO ipts = 1,npts
+
+            DO iele = 1,nelements
+
+               IF (ivm .EQ. test_pft .AND. ABS(sync_ind(ipts,ivm) - ind(ipts,ivm)) .GT. min_stomate ) THEN
+
+                  IF (ld_presc) THEN
+                     WRITE(numout,*) 'Divergence of density between ::ind and ::circ_class_n'
+                     WRITE(numout,*) 'This problem has been identified in stomate_prescribe but could'
+                     WRITE(numout,*) 'be caused in any routine calculating stand density'
+                  ENDIF
+
+               ELSE
+
+                  ind(ipts,ivm) = sync_ind(ipts,ivm)
+
+               ENDIF
+
+               ! Synchronize biomass
+               IF (ld_presc .AND. ivm .EQ. test_pft)THEN
+                  IF( SUM(biomass(ipts,ivm,:,iele)) .NE. zero)THEN
+                     IF( SUM( ABS(sync_biomass(ipts,ivm,:,iele) - biomass(ipts,ivm,:,iele) ) ) / &
+                          SUM(biomass(ipts,ivm,:,iele)) .GT. 0.0001 ) THEN
+
+                        WRITE(numout,*) 'Divergence of biomass between ::biomass and ::circ_class_biomass'
+                        WRITE(numout,*) 'This problem has been identified in stomate_prescribe but could'
+                        WRITE(numout,*) 'caused in any routine calculating biomass components'
+                        WRITE(numout,*) '% divergence', ivm, &
+                             SUM( ABS(sync_biomass(ipts,ivm,:,iele) - biomass(ipts,ivm,:,iele) ) ) / &
+                             SUM(biomass(ipts,ivm,:,iele)), &
+                             SUM(sync_biomass(ipts,ivm,:,iele)), SUM(biomass(ipts,ivm,:,iele))
+                     ENDIF
+                  ENDIF
+               ENDIF
+
+               biomass(ipts,ivm,:,iele) = sync_biomass(ipts,ivm,:,iele)
+
+
+            ENDDO ! nelements
+
+         ENDDO ! npts
+
+      ENDIF ! is_tree
+
+   ENDDO ! # PFT's
+
+ !! 4. Calculate components of the mass balance
+
+   !! 4.1 Calculate final biomass
+   pool_end(:,:,:) = zero 
+   DO ipar = 1,nparts
+      DO iele = 1,nelements
+         pool_end(:,:,iele) = pool_end(:,:,iele) + &
+              (biomass(:,:,ipar,iele) * veget_max(:,:))
+      ENDDO
+   ENDDO
+
+   !! 4.2 Calculate mass balance
+   check_intern(:,:,iatm2land,icarbon) = check_intern(:,:,iatm2land,icarbon) + &
+        co2_to_bm(:,:) * veget_max(:,:) * dt
+   check_intern(:,:,iland2atm,icarbon) = -un * zero
+   check_intern(:,:,ilat2out,icarbon) = zero
+   check_intern(:,:,ilat2in,icarbon) = -un * zero
+   check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - pool_start(:,:,icarbon))
+   closure_intern = zero
+   DO imbc = 1,nmbcomp
+      closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + check_intern(:,:,imbc,icarbon)
+   ENDDO
+
+   !! 4.3 Write outcome
+   DO ipts=1,npts
+      DO ivm=1,nvm
+         IF(ABS(closure_intern(ipts,ivm,icarbon)) .LE. min_stomate)THEN
+            IF (ld_massbal) WRITE(numout,*) 'Mass balance closure in prescribe_prognostic'
+         ELSE
+            WRITE(numout,*) 'Error: mass balance is not closed in prescribe_prognostic'
+            WRITE(numout,*) '   ipts,ivm; ', ipts,ivm
+            WRITE(numout,*) '   Difference is, ', closure_intern(ipts,ivm,icarbon)
+            WRITE(numout,*) '   pool_end,pool_start: ', pool_end(ipts,ivm,icarbon), pool_start(ipts,ivm,icarbon)
+            WRITE(numout,*) '   check_intern,co2_to_bm,pool_end,veget_max: ', &
+                 check_intern(ipts,ivm,iatm2land,icarbon),co2_to_bm(ipts,ivm), veget_max(ipts,ivm)
+            IF(ld_stop)THEN
+               CALL ipslerr_p (3,'prescribe_prognostic', 'Mass balance error.','','')
+            ENDIF
+         ENDIF
+      ENDDO
+   ENDDO
+   
+
+   END SUBROUTINE prescribe_prognostic
+
+END MODULE stomate_prescribe
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_resp.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_resp.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_resp.f90	(revision 7236)
@@ -0,0 +1,604 @@
+! =================================================================================================================================
+! MODULE           : stomate_resp
+!
+! CONTACT          : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE          : IPSL (2006)
+!                  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF           Calculates maintenance respiration for different plant components
+!!
+!!\n DESCRIPTION   : None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	   :
+!!- McCree KJ. An equation for the respiration of white clover plants grown under controlled conditions. 
+!! In: Setlik I, editor. Prediction and measurement of photosynthetic productivity. Wageningen, The Netherlands: 
+!! Pudoc; 1970. p. 221-229.
+!! - Krinner G, Viovy N, de Noblet-Ducoudre N, Ogee J, Polcher J, Friedlingstein P,
+!! Ciais P, Sitch S, Prentice I C (2005) A dynamic global vegetation model for studies
+!! of the coupled atmosphere-biosphere system. Global Biogeochemical Cycles, 19, GB1015,
+!! doi: 10.1029/2003GB002199.\n
+!! Ruimy A., Dedieu G., Saugier B. (1996), TURC: A diagnostic model
+!! of continental gross primary productivity and net primary productivity,
+!! Global Biogeochemical Cycles, 10, 269-285.\n
+
+!! SVN :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_stomate/stomate_resp.f90 $
+!! $Date: 2014-02-13 19:02:34 +0100 (Thu, 13 Feb 2014) $
+!! $Revision: 1905 $
+!! \n
+!_ ================================================================================================================================
+ 
+MODULE stomate_resp
+
+  ! modules used:
+  USE stomate_data
+  USE pft_parameters
+  USE constantes  
+  USE constantes_soil
+  USE function_library, ONLY : biomass_to_lai
+
+  IMPLICIT NONE
+
+  ! private & public routines
+  PRIVATE
+  PUBLIC maint_respiration,maint_respiration_clear
+
+  LOGICAL, SAVE                                              :: firstcall = .TRUE.                 !! first call
+!$OMP THREADPRIVATE(firstcall)
+
+  CONTAINS
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: maint_respiration_clear
+!!
+!>\BRIEF        : Set the flag ::firstcall to .TRUE. and as such activate section 
+!!                1.1 of the subroutine maint_respiration (see below).
+!_ ================================================================================================================================
+
+  SUBROUTINE maint_respiration_clear
+    firstcall=.TRUE.
+  END SUBROUTINE maint_respiration_clear
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	: maint_respiration
+!!
+!>\BRIEF         Calculate PFT maintenance respiration of each living plant part by 
+!! multiplying the biomass of plant part by maintenance respiration coefficient which
+!! depends on long term mean annual temperature. PFT maintenance respiration is carbon flux 
+!! with the units @tex $(gC.m^{-2}dt^{-1})$ @endtex, and the convention is from plants to the 
+!! atmosphere.
+!!
+!! DESCRIPTION : The maintenance respiration of each plant part for each PFT is the biomass of the plant 
+!! part multiplied by maintenance respiration coefficient. The biomass allocation to different 
+!! plant parts is done in routine stomate_alloc.f90. The maintenance respiration coefficient is 
+!! calculated in this routine.\n
+!!
+!! The maintenance respiration coefficient is the fraction of biomass that is lost during 
+!! each time step, which increases linearly with temperature (2-meter air temperature for aboveground plant
+!! tissues; root-zone temperature for below-ground tissues). Air temperature is an input forcing variable. 
+!! Root-zone temperature is a convolution of root and soil temperature profiles and also calculated 
+!! in this routine.\n
+!!
+!! The calculation of maintenance respiration coefficient (fraction of biomass respired) depends linearly
+!! on temperature:
+!! - the relevant temperature for different plant parts (air temperature or root-zone temperature)\n
+!! - intercept: prescribed maintenance respiration coefficients at 0 Degree Celsius for 
+!!   different plant parts for each PFT in routine stomate_constants.f90\n
+!! - slope: calculated with a quadratic polynomial with the multi-annual mean air temperature 
+!! (the constants are in routine stomate_constants.f90) as follows\n 
+!!    \latexonly
+!!      \input{resp3.tex} 
+!!    \endlatexonly
+!!   Where, maint_resp_slope1, maint_resp_slope2, maint_resp_slope3 are constant in stomate_constants.f90.
+!!   Then coeff_maint is calculated as follows:\n
+!!    \latexonly
+!!      \input{resp4.tex} 
+!!    \endlatexonly  
+!! If the calculation result is negative, maintenance respiration coefficient will take the value 0.
+!! Therefore the maintenance respiration will also be 0.\n
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): PFT maintenance respiration of different plant parts (::resp_maint_part_radia)
+!!
+!! REFERENCE(S)	:
+!! McCree KJ. An equation for the respiration of white clover plants grown under controlled conditions. In: 
+!! Setlik I, editor. Prediction and measurement of photosynthetic productivity. Wageningen, 
+!! The Netherlands: Pudoc; 1970. p. 221-229.
+!! Krinner G, Viovy N, de Noblet-Ducoudre N, Ogee J, Polcher J, Friedlingstein P,
+!! Ciais P, Sitch S, Prentice I C (2005) A dynamic global vegetation model for studies
+!! of the coupled atmosphere-biosphere system. Global Biogeochemical Cycles, 19, GB1015,
+!! doi: 10.1029/2003GB002199.\n
+!! Ruimy A., Dedieu G., Saugier B. (1996), TURC: A diagnostic model
+!! of continental gross primary productivity and net primary productivity,
+!! Global Biogeochemical Cycles, 10, 269-285.\n
+!! FLOWCHART    : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE maint_respiration (npts, dt, t2m, tlong_ref, &
+       stempdiag, gpp, gpp_week, lab_fac, &
+       veget_max, rprof, biomass, resp_maint_part_radia, &
+       circ_class_n, circ_class_biomass)
+
+!! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+
+    INTEGER(i_std), INTENT(in)                      :: npts         !! Domain size - number of grid cells (unitless)
+    REAL(r_std), INTENT(in)                         :: dt           !! Time step of the simulations (seconds)
+    REAL(r_std), DIMENSION(:), INTENT(in)           :: t2m          !! 2 meter air temperature - forcing variable (K)
+    REAL(r_std), DIMENSION(:), INTENT(in)           :: tlong_ref    !! Long term annual mean 2 meter reference air temperatures 
+                                                                    !! calculated in stomate_season.f90 (K)
+    REAL(r_std), DIMENSION(:,:), INTENT (in)        :: stempdiag    !! Soil temperature of each soil layer (K)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)         :: gpp          !! Gross primary production per day per unit PFT
+                                                                    !! @tex $ (gC m^{-2} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(in)         :: gpp_week     !! Weekly mean gross primary production per day per unit PFT
+                                                                    !! @tex $ (gC m^{-2} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(in)         :: veget_max    !! PFT "maximal" coverage fraction of a PFT (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)         :: rprof        !! PFT root depth as calculated in stomate.f90 from parameter 
+                                                                    !! humcste which is root profile for different PFTs 
+                                                                    !! in slowproc.f90 (m)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)         :: lab_fac      !! Activity of labile pool (??UNITS??)
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)       :: circ_class_n !! Number of individuals in each circ class
+                                                                    !! @tex $(ind m^{-2})$ @endtex
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(:,:,:), INTENT(out)      :: resp_maint_part_radia !! PFT maintenance respiration of different
+                                                                    !! plant parts @tex $(gC.m^{-2}dt^{-1} )$ @endtex
+
+    !! 0.3 Modified variables
+    
+    REAL(r_std), DIMENSION(:,:,:,:),  INTENT(inout) :: biomass      !! PFT total biomass calculated in stomate_alloc.f90 
+                                                                    !! @tex $(gC.m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout):: circ_class_biomass !! Biomass components of the model tree  
+                                                                    !! within a circumference class
+                                                                    !! class @tex $(g C ind^{-1})$ @endtex
+    !! 0.4 Local variables
+
+    REAL(r_std), DIMENSION(npts,nvm)        :: lai                  !! PFT leaf area index @tex $(m^2 m^{-2})$ @endtex
+    INTEGER(i_std)                          :: ipts,ivm,ipar,ibdl   !! Indeces (unitless)
+
+!    REAL(r_std), SAVE, DIMENSION(0:nbdl)    :: z_soil               !! Variable to store depth of the different soil layers (m)
+
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)                :: z_soil !! Soil levels (m)
+!$OMP THREADPRIVATE(z_soil)
+
+    REAL(r_std), DIMENSION(npts,nvm)        :: t_root               !! PFT root temperature (convolution of root and soil 
+                                                                    !! temperature profiles) (K)
+    REAL(r_std), DIMENSION(npts,nvm,nparts) :: coeff_maint          !! PFT maintenance respiration coefficients of different 
+                                                                    !! plant compartments at 0 deg C 
+                                                                    !! @tex $(g.g^{-1}dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nparts)     :: t_maint_radia        !! Temperature which is pertinent for maintenance respiration, 
+                                                                    !! which is air/root temperature for above/below-ground 
+                                                                    !! compartments (K) 
+    REAL(r_std), DIMENSION(nvm,nparts)      :: fcn                  !! C/N ratio in tissue (unitless)
+    REAL(r_std), DIMENSION(npts,nvm)        :: resp_maint_demand    !! Rate of maintanance respiration
+                                                                    !! @tex $(gC.dt^{-1})$ @endtex 
+    REAL(r_std), DIMENSION(npts,nvm)        :: resp_maint_supply    !! Rate of growth respiration
+                                                                    !! @tex $(gC.dt^{-1})$ @endtex                                  
+    REAL(r_std), DIMENSION(npts,nvm)        :: resp_maint           !! Effective rate of maintanance respiration
+                                                                    !! @tex $(gC.dt^{-1})$ @endtex   
+    REAL(r_std), DIMENSION(npts)            :: gtemp                !! Temperature response of respiration in the 
+                                                                    !! Lloyd-Taylor Model (K)
+    REAL(r_std), DIMENSION(npts)            :: tl                   !! Long term reference temperature in degrees Celcius 
+                                                                    !! (= tlong_ref - 273.15) (C)
+    REAL(r_std), DIMENSION(npts)            :: slope                !! slope of the temperature dependence of maintenance 
+                                                                    !! respiration coefficient (1/K)
+    REAL(r_std), DIMENSION(npts)            :: rpc                  !! Scaling factor for integrating vertical soil 
+                                                                    !! profiles (unitless)
+    REAL(r_std), DIMENSION(nvm)             :: coeff_maint_temp     !! PFT maintenance respiration coefficients of different 
+                                                                    !! plant compartments at 0 deg C 
+                                                                    !! @tex $(g.g^{-1}dt^{-1})$ @endtex
+    REAL(r_std)                             :: deficit              !! Calculate maintenance respiration based on 
+                                                                    !! tissue pools (or labile pool size) (??UNIT??)
+    REAL(r_std)                             :: limit_cn             !! Calculate maintenance respiration based on 
+                                                                    !! tissue pools (or labile pool size) (??UNIT??)
+    REAL(r_std)                             :: temp_share           !! Temporary variable to store the share
+                                                                    !! of biomass of each circumference class
+                                                                    !! to the total biomass            
+    REAL(r_std)                             :: temp_class_biomass   !! Biomass across parts for a single circ
+                                                                    !! class @tex $(gC m^{-2})$ @endtex
+    REAL(r_std)                             :: temp_total_biomass   !! Biomass across parts and circ classes
+                                                                    !! @tex $(gC m^{-2})$ @endtex
+    REAL(r_std)                             :: temp                 !! generic temporary variable 
+
+   !! 0.5 Externalize
+   REAL(r_std), PARAMETER                   :: gtemp_ref=1.6        !! Correction factor for respiration calculation, 
+                                                                    !! since ORCHIDEE maintenance respiration rates
+                                                                    !! refer to zero degrees but Lloyd and Taylor assumes 
+                                                                    !! base temperature of 10 degrees (unitless)
+! tzjwb
+   INTEGER(i_std)                                              :: ier !! Error handling
+       
+!_ ================================================================================================================================
+    
+    
+    IF (bavard.GE.4) WRITE(numout,*) 'Entering maintenance respiration'
+   
+ !! 1. Initializations
+    
+    IF ( firstcall ) THEN
+
+       !! 1.1. Soil levels (first call only)
+       !       Set the depth of the different soil layers (number of layers: nbdl) 
+       !       previously calculated as variable diaglev in routines sechiba.f90 and slowproc.f90
+
+! tzjwb
+       ALLOCATE(z_soil(0:nbdl), stat=ier)
+       IF ( ier /= 0 ) CALL ipslerr_p(3,'stomate_resp','Pb in allocate of z_soil','','')
+
+       z_soil(0) = zero
+       z_soil(1:nbdl) = diaglev(1:nbdl)
+
+       ! Set first call to false for all subsequent calls 
+       firstcall = .FALSE.
+
+    ENDIF
+
+    
+    !! 1.2. Calculate root temperature
+    !       Calculate root temperature as the convolution of root and soil temperature profiles
+    DO ivm = 2,nvm ! Loop over # PFTs
+
+       !! 1.2.1 Calculate rpc
+       !  - rpc is an integration constant to make the integral over the root profile is equal 'one', 
+       !    calculated as follows:\n
+       !  \latexonly
+       !    \input{resp1.tex} 
+       !  \endlatexonly
+       rpc(:) = un / ( un - EXP( -z_soil(nbdl) / rprof(:,ivm) ) )
+
+       !! 1.2.2 Calculate root temperature
+       !        - Integrate root profile temperature (K) over soil layers (number of layers = nbdl)
+       !          with rpc and soil temperature (K) of each soil layer as follows:\n
+       !        \latexonly
+       !          \input{resp2.tex} 
+       !        \endlatexonly
+       !        Where, stempdiag is diagnostic temperature profile of soil (K)\n
+       t_root(:,ivm) = zero
+
+       DO ibdl = 1, nbdl ! Loop over # soil layers
+
+          t_root(:,ivm) = &
+               t_root(:,ivm) + stempdiag(:,ibdl) * rpc(:) * &
+               ( EXP( -z_soil(ibdl-1)/rprof(:,ivm) ) - EXP( -z_soil(ibdl)/rprof(:,ivm) ) )
+
+       ENDDO ! Loop over # soil layers
+
+    ENDDO ! Loop over # PFTs
+
+ !! 2. Define maintenance respiration coefficients
+
+    DO ivm = 2,nvm ! Loop over # PFTs
+
+       !! 2.1 Temperature for maintenanace respiration
+       !      Temperature which is used to calculate maintenance respiration for different plant compartments
+       !      (above- and belowground)\n
+       !      - for aboveground parts, we use 2-meter air temperature, t2m\n
+       !      - for belowground parts, we use root temperature calculated in section 1.2 of this subroutine\n
+       
+       ! 2.1.1 Aboveground biomass
+       t_maint_radia(:,ileaf) = t2m(:)
+       t_maint_radia(:,isapabove) = t2m(:)
+       t_maint_radia(:,ifruit) = t2m(:)
+
+       ! 2.1.2 Belowground biomass
+       t_maint_radia(:,isapbelow) = t_root(:,ivm)
+       t_maint_radia(:,iroot) = t_root(:,ivm)
+
+       !! 2.1.3 Heartwood biomass
+       !  Heartwood does does not respire (coeff_maint_zero is set to zero). 
+       !  Any temperature could have been set  
+       !  [code cleaning: set t(heartwood) to undef to 'undef']
+
+       t_maint_radia(:,iheartbelow) = t_root(:,ivm)
+       t_maint_radia(:,iheartabove) = t2m(:)
+
+       !! 2.1.4 Reserve biomass
+       !  Use aboveground temperature for trees and belowground temeperature for grasses
+       IF ( is_tree(ivm) ) THEN
+
+          t_maint_radia(:,icarbres) = t2m(:)
+
+       ELSE
+
+          t_maint_radia(:,icarbres) = t_root(:,ivm)
+
+       ENDIF
+
+       !! 2.1.5 Labile biomass pool
+       !  Use aboveground temperature for the labile biomass pool
+       t_maint_radia(:,ilabile) = t2m(:)
+       
+       !! 2.2 Calculate maintenance respiration coefficients (coeff_maint)
+       !  Maintenance respiration is a fraction of biomass defined by the coefficient 
+       !  coeff_maint [Mc Cree, 1969]. Coeff_maint is defined through a linear relationship of temperature [Ruimy et al, 1996]
+       !  which slope is the coefficient 'slope' and which intercept is 'coeff_maint_zero'.
+       !  - Coeff_maint_zero is defined in stomate_data to cm_zero_plantpartname
+       !  - Slope is calculated here through a second-degree polynomial [Krinner et al, 2005] 
+       !  equation that makes it dependent on the long term temperature (to represent adaptation
+       !  of the ecosystem to long term temperature).
+       !   \latexonly
+       !    \input{resp3.tex} 
+       !   \endlatexonly
+       !  Where, maint_resp_slope1, maint_resp_slope2, maint_resp_slope3 are constant in stomate_constants.f90.
+       !  Then coeff_maint is calculated as follows:\n
+       !   \latexonly
+       !    \input{resp4.tex} 
+       !   \endlatexonly
+       !  If the calculation result is negative, coeff_maint will take the value 0.\n	
+       tl(:) = tlong_ref(:) - ZeroCelsius
+       slope(:) = maint_resp_slope(ivm,1) + tl(:) * maint_resp_slope(ivm,2) + &
+            tl(:)*tl(:) * maint_resp_slope(ivm,3)  !maint_resp_slope(ivm,1)=0.20
+
+       DO ipar = 1, nparts ! Loop over # plant parts
+
+          ! Resource-based allocation       
+          IF ( .NOT.control%ok_functional_allocation ) THEN
+
+            coeff_maint(:,ivm,ipar) = MAX( (coeff_maint_zero(ivm,ipar)*dt/one_day) * &
+                 ( un + slope(:) * (t_maint_radia(:,ipar)-ZeroCelsius) ), zero ) 
+
+         ! Allometric-based allocation    
+         ELSE
+
+            !+++CHECK+++
+            ! The original code refers to the Sitch et al 2003 as the source of the equations and parameters 
+            ! for modelling maintenance respiration. The equations below are consistent with the paper. The 
+            ! parameter setting for coeff_maint is in the range of 0.066 to 0.011 as reported in the paper but
+            ! exact values are not given. Although, the principle of a climate correction for coeff_maint is 
+            ! mentioned in Sitch et al 2003, the reduction factors themselves were not given. As it appears 
+            ! now this block of code pretends much more knowledge then we actually have. Rather than using a 
+            ! baseline coeff_maint that is later corrected for the climate region, the parameter values for 
+            ! coeff_maint could be simply prescribed and made pft-specific.
+            ! Further down in the code C/N ratios are used to constrain respiration. The C/N ratios were reset 
+            ! to the values presented in Sitch et al 2003 but still seem on the low side. If pft-specific 
+            ! values are to be used, changes in respiration could be compensated for by changing 
+            ! coeff_maint_init. Given Vicca et al 2012 (Ecology Letters) an NPP/GPP ratio of 0.5 is 'universal' 
+            ! for forests given a sufficient nutrient supply and strictly defining NPP as solely its biomass 
+            ! components (thus excluding VOC, exudation and subsidies to myccorrhizae as is the case in ORCHIDEE).
+            ! Unless observation based values are available for coeff_maint_init, these values could be adjusted
+            ! within the range of 0.066 to 0.011 to obtain an NPP/GPP of 0.5 in the absence of nutrient 
+            ! limitations. 
+               
+            ! LPJ respiration factors based on Sitch et al. 2003 - first part of the calculation
+            IF ( ipar.EQ.ileaf .OR. ipar.EQ.iroot .OR. ipar.EQ.ifruit .OR. &
+                 ipar.EQ.isapabove .OR. ipar.EQ.isapbelow .OR. ipar.EQ.ilabile) THEN
+               
+               ! Sonke uses
+               !coeff_maint(:,ivm,ipar) = 0.0548
+
+               ! The Sitch et al 2003 paper gives a value of 0.066 (Table 3) and 0.011 for tropical systems
+               !coeff_maint(:,ivm,ipar) = 0.066
+ 
+               ! Use an effective PFT-specific value - this value has been optimized
+               ! to reproduce observed NPP/GPP ratios
+               coeff_maint(:,ivm,ipar) = coeff_maint_init(ivm)
+
+            ! heartwood and reserves pool   
+            ELSE
+
+               coeff_maint(:,ivm,ipar) = zero
+
+            ENDIF
+
+            !+++BEGIN+DELETE+++
+            ! Correction for climate region.
+            ! [remove hard coding]
+            ! Respiration rates for tropical forests
+            !IF ( ivm.LE.3 ) THEN
+               
+               ! Sonke uses
+               ! coeff_maint(:,ivm,ipar) = coeff_maint(:,ivm,ipar)*0.33
+     
+               ! The Sitch et al 2003 paper
+               !coeff_maint(:,ivm,ipar) = coeff_maint(:,ivm,ipar)/6.
+
+            ! Respiration rates for tropical grass and crops
+            !ELSEIF ( ivm.EQ.11 .OR. ivm.EQ.13 ) THEN
+               
+               ! Sonke uses
+               !coeff_maint(:,ivm,ipar) = coeff_maint(:,ivm,ipar)*0.5
+               
+               ! The Sitch et al 2003 paper
+               !coeff_maint(:,ivm,ipar) = coeff_maint(:,ivm,ipar) / 6.
+ 
+            ! Respiration rates for boreal and temperate PFTs
+            !ELSE
+
+               ! Sonke uses 
+               ! coeff_maint(:,ivm,ipar) = coeff_maint(:,ivm,ipar)*0.7
+               
+               ! The Sitch et al 2003 paper - value should not be adjusted
+               !coeff_maint(:,ivm,ipar) = coeff_maint(:,ivm,ipar)
+               !coeff_maint(:,ivm,ipar) = coeff_maint(:,ivm,ipar)*0.5
+
+            !ENDIF
+            !+++END+DELETE+++
+
+         ENDIF ! .NOT.control%ok_functional_allocation
+
+       ENDDO ! Loop over # plant parts
+     
+        
+       !+++OCN-code+++
+!$       ! Calculate lai
+!$       lai(:,ivm) = biomass(:,ivm,ileaf,icarbon) * sla(ivm)
+
+!$       ! Leaf respiration for photosynthesis according to Friend et al. as in Zaehle et al.
+!$       ! Leaf respiration is calculated in diffuco.f90
+!$       IF ( control%ok_cexchange ) THEN
+!$          coeff_maint_leaf(:,ivm,:) = zero
+       
+!$       ! Leaf respiration for the standard ORCHIDEE photosynthesis
+!$       ELSE
+!$          WHERE ( (biomass(:,ivm,ileaf,icarbon) .GT. min_stomate) .AND. (lai(:,ivm) .GT. min_stomate) ) 
+!$           
+!$             coeff_maint_leaf(:,ivm,1) = coeff_maint_zero(ivm,ileaf) * biomass(:,ivm,ileaf,icarbon) * & 
+!$                  ( maint_resp_min_vmax*lai(:,ivm) + maint_resp_coeff*(un-exp(-ext_coeff(ivm)*lai(:,ivm))) ) &
+!$                  / lai(:,ivm) / one_day
+!$           
+!$             coeff_maint_leaf(:,ivm,2) = slope(:)
+!$           
+!$          ELSEWHERE
+             
+!$              coeff_maint_leaf(:,ivm,1) = zero
+!$              coeff_maint_leaf(:,ivm,2) = zero
+             
+!$          ENDWHERE
+         
+!$       ENDIF ! control%ok_cexchange
+       !++++++++++
+
+    ENDDO ! Loop over # PFTs
+       
+
+ !! 3. Calculate maintenance respiration
+
+    ! Resource-based allocation
+    IF ( .NOT.control%ok_functional_allocation ) THEN
+
+       ! The maintenance respiration @tex $(gC.m^{-2}dt^{-1})$ @endtex of each plant compartment for each PFT is 
+       ! the biomass @tex $(gC.m^{-2})$ @endtex of the plant part multiplied by maintenance respiration 
+       ! coefficient @tex $(g.g^{-1}dt^{-1})$ @endtex, except that the maintenance respiration of leaves is 
+       ! corrected by leaf area index (LAI) as follows:\n
+       ! \latexonly     
+       !   \input{resp5.tex} 
+       ! \endlatexonly
+    
+       ! ibare_sechiba = 1, which means the there is only bare soil but not any PFT, consequently no LAI and
+       ! no  maintenance respiration
+       lai(:,ibare_sechiba) = zero
+       resp_maint_part_radia(:,ibare_sechiba,:) = zero
+    
+       ! 3.1 Maintenance respiration of the different plant parts
+       DO ivm = 2,nvm ! Loop over # PFTs
+          
+          ! Calculate lai
+          DO ipts = 1,npts
+
+             lai(ipts,ivm) = biomass_to_lai(biomass(ipts,ivm,ileaf,icarbon),ivm)
+
+          ENDDO
+
+       DO ipar = 1, nparts ! Loop over # plant parts
+
+             ! Leaf respiration: depends on leaf mass and LAI 
+             IF ( ipar .EQ. ileaf ) THEN
+
+                WHERE ( (biomass(:,ivm,ileaf,icarbon).GT.min_stomate) .AND. (lai(:,ivm).GT.min_stomate) )
+
+                   ! Maintenance respiration is calculated as a fraction of biomass as defined by coeff_maint 
+                   ! and is adjusted for the nitrogen effect through a third factor depending on LAI. The 
+                   ! hypothesis here is that the vcmax (i.e. the nitrogen distribution) in the canopy decreases 
+                   ! exponentially with LAI following the Beer-Lambert law with an asymptote defining the 
+                   ! minimum of the function at 30% of the LAI. The 1.4 parameter is an integration constant.
+                   ! This method is also used in diffuco_trans_co2 2.4.1 for scaling vmax based on nitrogen 
+                   ! reduction in the canopy.
+                   resp_maint_part_radia(:,ivm,ipar) = coeff_maint(:,ivm,ipar) * biomass(:,ivm,ipar,icarbon) * &
+                        ( maint_resp_min_vmax*lai(:,ivm) + maint_resp_coeff*(un - exp(-ext_coeff(ivm)*lai(:,ivm))) ) / lai(:,ivm)
+
+                ELSEWHERE
+
+                   resp_maint_part_radia(:,ivm,ileaf) = zero
+
+                ENDWHERE
+
+             ! All other components
+             ELSE
+
+                ! All components except ileaves and ilabile
+                IF ( ipar.NE.ilabile ) THEN
+
+                   resp_maint_part_radia(:,ivm,ipar) = coeff_maint(:,ivm,ipar) * biomass(:,ivm,ipar,icarbon)
+
+                ! Respiration for ilabile
+                ELSE
+
+                   resp_maint_part_radia(:,ivm,ilabile) = zero
+
+                ENDIF !ipar.NE.ilabile
+
+             ENDIF !ipar.EQ.ileaf
+
+          ENDDO ! Loop over # plant parts
+
+       ENDDO ! Loop over # PFTs
+
+    ! Allometric-based allocation
+    ELSE
+!WRITE(*,*) "tzjeval allom" 
+       ! In the allometric based allocation scheme, maintentance respiration is calculated 
+       ! the minimum of supply and demand
+       resp_maint_part_radia(:,:,:) = zero
+      
+       DO ivm = 2,nvm ! Loop over # PFTs
+
+          ! Demand based respiration
+          resp_maint_demand(:,ivm) = 0.0
+
+          DO ipar = 1, nparts ! Loop over # plant parts  
+            
+             ! LPJ respiration factors based on Sitch et al. 2003 - second part of the calculation
+             ! Temperature response, LLoyd and Taylor, 1994. E0 = 308.56 comes from the paper of 
+             ! Lloyd and Taylor but was fitted for soil respiration which only partly consists of
+             ! authotrophic (root) respiration.   
+             WHERE(t_maint_radia(:,ipar)-ZeroCelsius.GT.-46.01)
+
+                gtemp(:) = dt/one_day * & 
+                    EXP(308.56*(1.0/56.02-1.0/(t_maint_radia(:,ipar)-ZeroCelsius+46.02)))
+
+             ! No gtemp below -46.01 degrees Celsius
+             ELSEWHERE
+
+                gtemp(:) = 0.0
+
+             ENDWHERE           
+            
+             ! Calculate the limiting C/N ratio
+             IF ( ipar.EQ.ileaf ) THEN
+
+                limit_cn = cn_leaf_prescribed(ivm)
+
+             ELSEIF ( ipar.EQ.iroot .OR. ipar.EQ.ifruit ) THEN
+
+                limit_cn = cn_leaf_prescribed(ivm)/fcn_root(ivm)
+
+             ELSEIF ( ipar.EQ.isapabove .OR. ipar.EQ.isapbelow ) THEN
+
+                limit_cn = cn_leaf_prescribed(ivm)/fcn_wood(ivm)
+
+             ELSE
+
+                limit_cn = cn_leaf_prescribed(ivm)
+
+             ENDIF
+            
+             !---TEMP---
+             !IF (ivm.EQ.test_pft) THEN  
+             !   WRITE(numout,*) 'limit - ipar, temp output,', ipar, limit_cn
+             !ENDIF
+             !----------
+
+             resp_maint_part_radia(:,ivm,ipar) = coeff_maint(:,ivm,ipar) * gtemp(:) * & 
+                    biomass(:,ivm,ipar,icarbon) / limit_cn
+             resp_maint_demand(:,ivm) = resp_maint_demand(:,ivm) + resp_maint_part_radia(:,ivm,ipar)
+
+          ENDDO ! Loop over # plant parts
+
+       ENDDO ! Loop over # PFTs
+   
+    ENDIF ! .NOT.control%ok_functional_allocation
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving maintenance respiration'
+
+  END SUBROUTINE maint_respiration
+
+END MODULE stomate_resp
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_season.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_season.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_season.f90	(revision 7236)
@@ -0,0 +1,1623 @@
+! =================================================================================================================================
+! MODULE        : stomate_season
+!
+! CONTACT       : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE       : IPSL (2006). This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       This module calculates long-term meteorological parameters from daily temperatures
+!! and precipitations (essentially for phenology). 
+!!      
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! SVN          :
+!! $HeadURL$ 
+!! $Date$
+!! $Revision$
+!! \n
+!_ =================================================================================================================================
+
+MODULE stomate_season
+
+  ! modules used:
+  USE xios_orchidee
+  USE ioipsl_para
+  USE stomate_data
+  USE constantes
+  USE constantes_soil
+  USE pft_parameters 
+  USE solar
+  USE grid
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC season,season_clear
+
+  LOGICAL, SAVE                                          :: firstcall = .TRUE.  !! first call (true/false)
+!$OMP THREADPRIVATE(firstcall)
+
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE   : season_clear
+!!
+!>\BRIEF          Flag setting 
+!!
+!! DESCRIPTION  : This subroutine sets flags ::firstcall, to .TRUE., and therefore activates   
+!!                section 1.1 of the ::season subroutine which writes messages to the output. \n
+!!                This subroutine is called at the end of the subroutine ::stomate_clear, in the 
+!!                module ::stomate.
+!!
+!! RECENT CHANGE(S):None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::firstcall
+!!
+!! REFERENCE(S)  : None 
+!!
+!! FLOWCHART     : None
+!! \n             
+!_ =================================================================================================================================
+
+  SUBROUTINE season_clear
+    firstcall=.TRUE.
+  END SUBROUTINE season_clear
+
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : season
+!!
+!>\BRIEF          This subroutine calculates many of the long-term biometeorological variables
+!!                needed in the phenology subroutines and in the calculation of long-term vegetation
+!!                dynamics in the LPJ DGVM. 
+!!
+!! DESCRIPTION    This subroutine is called by the module ::stomate before LPJ, and mainly deals  
+!!                with the calculation of long-term meteorological variables, carbon fluxes and 
+!!                vegetation-related variables that are used to calculate vegetation dynamics 
+!!                in the stomate modules relating to the phenology and to the longer-term 
+!!                changes in vegetation type and fractional cover in the LPJ DGVM modules. \n
+!!                In sections 2 to 5, longer-term meteorological variables are calculated. The
+!!                long-term moisture availabilities are used in the leaf onset and senescence
+!!                phenological models ::stomate_phenology and ::stomate_turnover that require
+!!                a moisture condition. The long term temperatures are also required for phenology
+!!                but in addition they are used in calculations of C flux and the presence and
+!!                establishment of vegetation patterns on a longer timescale in the LPJ DGVM modules.
+!!                Finally the monthly soil humidity/relative soil moisture is used in the C
+!!                allocation module ::stomate_alloc. \n
+!!                Sections 12 to 14 also calculate long-term variables of C fluxes, including NPP,
+!!                turnover and GPP. The first two are used to calculate long-term vegetation 
+!!                dynamics and land cover change in the LPJ DVGM modules. The weekly GPP is used
+!!                to determine the dormancy onset and time-length, as described below. \n
+!!                The long-term variables described above are are used in certain vegetation
+!!                dynamics processes in order to maintain consistency with the basic hypotheses of the 
+!!                parameterisations of LPJ, which operates on a one year time step (Krinner et al., 2005).
+!!                In order to reduce the computer memory requirements, short-term variables (e.g. daily
+!!                temperatures) are not stored for averaging over a longer period. Instead
+!!                the long-term variables (e.g. monthly temperature) are calculated at each time step
+!!                using a linear relaxation method, following the equation:
+!!                \latexonly
+!!                \input{season_lin_relax_eqn1.tex}
+!!                \endlatexonly
+!!                \n 
+!!                The long-term variables are therefore updated on a daily basis. This method allows for 
+!!                smooth temporal variation of the long-term variables which are used to calculate 
+!!                vegetation dynamics (Krinner et al., 2005). \n
+!!                Sections 6 to 11 calculate the variables required for to determine leaf onset in
+!!                the module ::stomate_phenology. 
+!!                These include :
+!!                - the dormance onset and time-length, when GPP is below a certain threshold \n
+!!                - the growing degree days (GDD), which is the sum of daily temperatures greater than
+!!                -5 degrees C, either since the onset of the dormancy period, or since midwinter \n
+!!                - the number of chilling days, which is the number of days with a daily temperature
+!!                lower than a PFT-dependent threshold since the beginning of the dormancy period \n
+!!                - the number of growing days, which is the the number of days with a temperature
+!!                greater than -5 degrees C since the onset of the dormancy period \n
+!!                - the time since the minimum moisture availability in the dormancy period. \n
+!!                These variables are used to determine the conditions needed for the start of the
+!!                leaf growing season. The specific models to which they correspond are given below. \n
+!!                Sections 15 to 20 are used to update the maximum/minimum or the sum of various 
+!!                meteorological and biological variables during the year that are required for
+!!                calculating either leaf onset or longer-term vegetation dynamics the following year. \n
+!!                At the end of the year, these variables are updated from "thisyear" to "lastyear", 
+!!                in Section 21 of this subroutine, for use the following year. \n
+!!                Finally the probably amount of herbivore consumption is calculated in Section 22,
+!!                following McNaughton et al. (1989).
+!!
+!! RECENT CHANGE(S): None
+!!                
+!! MAIN OUTPUT VARIABLE(S): :: herbivores,
+!!                        :: 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 
+!!      
+!! REFERENCES   : 
+!! - Krinner, G., N. Viovy, N. de Noblet-Ducoudre, J. Ogee, J. Polcher, P. 
+!! Friedlingstein, P. Ciais, S. Sitch and I.C. Prentice (2005), A dynamic global
+!! vegetation model for studies of the coupled atmosphere-biosphere system, Global
+!! Biogeochemical Cycles, 19, doi:10.1029/2003GB002199.
+!! - McNaughton, S.J., M. Oesterheld, D.A. Frank and K.J. Williams (1989), 
+!! Ecosystem-level patterns of primary productivity and herbivory in terrestrial
+!! habitats, Nature, 341, 142-144.
+!!                       
+!! FLOWCHART    : 
+!! \latexonly
+!! \includegraphics[scale = 1]{season_flowchart_part1.png}
+!! \includegraphics[scale = 1]{season_flowchart_part2.png}
+!! \includegraphics[scale = 1]{season_flowchart_part3.png}
+!! \endlatexonly
+!! \n   
+!_ =================================================================================================================================
+
+  SUBROUTINE season (npts, dt, EndOfYear, veget, veget_max, &
+       moiavail_daily, t2m_daily, tsoil_daily, soilhum_daily, lalo,  &
+       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, fpc_max, &
+       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, gdd_init_date , & 
+       gdd_from_growthinit, herbivores, moiavail_growingseason, rue_longterm, &
+       vir_moiavail_daily, vir_moiavail_growingseason)
+
+    !
+    !! 0. Variable and parameter declaration
+    !
+
+    !
+    !! 0.1 Input variables
+    !
+    INTEGER(i_std), INTENT(in)                             :: npts              !! Domain size - number of grid cells (unitless)
+    REAL(r_std), INTENT(in)                                :: dt                !! time step in days (dt_days)
+    LOGICAL, INTENT(in)                                    :: EndOfYear         !! update yearly variables? (true/false)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: veget             !! coverage fraction of a PFT. Here: fraction of 
+                                                                                !! total ground. (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: veget_max         !! "maximal" coverage fraction of a PFT (for LAI -> 
+                                                                                !! infinity) (0-1, unitless)Here: fraction of 
+                                                                                !! total ground. 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: moiavail_daily    !! Daily moisture availability (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: vir_moiavail_daily!! Virtual daily moisture availability (0-1, unitless)
+                                                                                !! to be used under specific conditions in LCC
+    REAL(r_std), DIMENSION(npts), INTENT(in)               :: t2m_daily         !! Daily 2 meter temperature (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)          :: tsoil_daily       !! Daily soil temperature (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)          :: soilhum_daily     !! Daily soil humidity (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)             :: lalo              !!  array of lat/lon
+    REAL(r_std), DIMENSION(npts), INTENT(in)               :: precip_daily      !! Daily mean precipitation @tex ($mm day^{-1}$) 
+                                                                                !! @endtex 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: npp_daily         !! daily net primary productivity @tex ($gC m^{-2} 
+                                                                                !! day^{-1}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(in) :: biomass     !! biomass @tex ($gC m^{-2} of ground$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(in) :: turnover_daily  !! Turnover rates @tex ($gC m^{-2} day^{-1}$) 
+                                                                                !! @endtex 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: gpp_daily         !! daily gross primary productivity  
+                                                                                !! (Here: @tex $gC m^{-2} of total ground 
+                                                                                !! day^{-1}$) @endtex 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: when_growthinit   !! how many days ago was the beginning of the 
+                                                                                !! growing season (days)
+
+
+    !
+    !! 0.2 Output variables 
+    ! (diagnostic)
+    !
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)          :: herbivores        !! time constant of probability of a leaf to be 
+                                                                                !! eaten by a herbivore (days) 
+
+    !
+    !! 0.3 Modified variables
+    !
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: maxmoiavail_lastyear      !! last year's maximum moisture 
+                                                                                        !! availability (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: maxmoiavail_thisyear      !! this year's maximum moisture 
+                                                                                        !! availability (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: minmoiavail_lastyear      !! last year's minimum moisture 
+                                                                                        !! availability (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: minmoiavail_thisyear      !! this year's minimum moisture 
+                                                                                        !! availability (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: maxgppweek_lastyear       !! last year's maximum weekly GPP 
+                                                                                        !! @tex ($gC m^{-2} week^{-1}$) @endtex 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: maxgppweek_thisyear       !! this year's maximum weekly GPP 
+                                                                                        !! @tex ($gC m^{-2} week^{-1}$) @endtex 
+    REAL(r_std), DIMENSION(npts), INTENT(inout)            :: gdd0_lastyear             !! last year's annual GDD0 (C)
+    REAL(r_std), DIMENSION(npts), INTENT(inout)            :: gdd0_thisyear             !! this year's annual GDD0 (C)
+    REAL(r_std), DIMENSION(npts), INTENT(inout)            :: precip_lastyear           !! last year's annual precipitation 
+                                                                                        !! @tex ($mm year^{-1}$) @endtex 
+    REAL(r_std), DIMENSION(npts), INTENT(inout)            :: precip_thisyear           !! this year's annual precipitation 
+                                                                                        !! @tex ($mm year^{-1}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: lm_lastyearmax            !! last year's maximum leaf mass, for each 
+                                                                                        !! PFT @tex ($gC m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: lm_thisyearmax            !! this year's maximum leaf mass, for each 
+                                                                                        !! PFT @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: maxfpc_lastyear           !! last year's maximum fpc for each PFT, on 
+                                                                                        !! ground (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: maxfpc_thisyear           !! this year's maximum fpc for each PFT, on 
+                                                                                        !! ground (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: moiavail_month            !! "monthly" moisture availability 
+                                                                                        !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: moiavail_week             !! "weekly" moisture availability 
+                                                                                        !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts), INTENT(inout)            :: t2m_longterm              !! "long term" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(inout)            :: tlong_ref                 !! "long term" reference 2-meter 
+                                                                                        !! temperatures (K) 
+    REAL(r_std), DIMENSION(npts), INTENT(inout)            :: t2m_month                 !! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(inout)            :: t2m_week                  !! "weekly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(inout)       :: tsoil_month               !! "monthly" soil temperatures (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(inout)       :: soilhum_month             !! "monthly" soil humidity (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: npp_longterm              !! "long term" net primary productivity 
+                                                                                        !! @tex ($gC m^{-2} year^{-1}$) @endtex 
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                      INTENT(inout)        :: turnover_longterm         !! "long term" turnover rate 
+                                                                                        !! @tex ($gC m^{-2} year^{-1}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: gpp_week                  !! "weekly" GPP @tex ($gC m^{-2} day^{-1}$) 
+                                                                                        !! @endtex 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: gdd_m5_dormance           !! growing degree days above threshold -5 
+                                                                                        !! deg. C (C) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: gdd_midwinter             !! growing degree days since midwinter (C)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: ncd_dormance              !! number of chilling days since leaves 
+                                                                                        !! were lost (days) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: ngd_minus5                !! number of growing days (days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: time_lowgpp               !! Duration of dormance (days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: time_hum_min              !! time elapsed since strongest moisture 
+                                                                                        !! availability (days) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: hum_min_dormance          !! minimum moisture during dormance 
+                                                                                        !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,4), INTENT(inout)          :: gdd_init_date             !! inital date for gdd count
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: gdd_from_growthinit       !! growing degree days, threshold 0 deg. C 
+                                                                                        !! since beginning of season
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: moiavail_growingseason    !! Soil moisture during growing season 
+                                                                                        !! (used for allometry&allocation)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: vir_moiavail_growingseason!! Virtual soil moisture during growing season 
+                                                                                        !! (used for allometry&allocation)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: rue_longterm              !! Longterm radiation use efficiency 
+                                                                                        !! (units?)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: fpc_max                   !! Maximum permissable fpc
+    !
+    !! 0.4 Local variables
+    !
+    INTEGER(i_std)                                          :: j                        !! indices (unitless)
+    REAL(r_std)                                             :: ncd_max                  !! maximum ncd (to avoid floating point 
+                                                                                        !! underflows) (days) 
+    REAL(r_std), DIMENSION(npts)                            :: sumfpc_nat               !! sum of natural fpcs (0-1, unitless)
+                                                                                        !! [DISPENSABLE] 
+    REAL(r_std), DIMENSION(npts,nvm)                        :: weighttot                !! weight of biomass @tex ($gC m^{-2}$) 
+                                                                                        !! @endtex 
+    REAL(r_std), DIMENSION(npts,nvm)                        :: nlflong_nat              !! natural long-term leaf NPP 
+                                                                                        !! @tex ($gC m^{-2} year^{-1}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm)                        :: green_age                !! residence time of green tissue (years)
+    REAL(r_std), DIMENSION(npts)                            :: consumption              !! herbivore consumption 
+                                                                                        !! @tex ($gC m^{-2} day^{-1}$) @endtex
+    REAL(r_std), DIMENSION(npts)                            :: fracnat                  !! fraction of each gridcell occupied by 
+                                                                                        !! natural vegetation (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                            :: solad                    !! maximal radation during current day 
+                                                                                        !! (clear sky condition)
+    REAL(r_std), DIMENSION(npts)                            :: solai                    !! maximal radation during current day
+                                                                                        !! (clear sky condition)
+    REAL(r_std), ALLOCATABLE, SAVE, DIMENSION(:)            :: cloud                    !! cloud fraction
+!$OMP THREADPRIVATE(cloud)
+
+!_ =================================================================================================================================
+    !WRITE(numout,*)'moiavail_daily enetring stomate_season', moiavail_daily(:,:)
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering season'
+
+    !
+    !! 1. Initializations
+    !! 1.1 Calculate ::ncd_max - the maximum possible NCD (number of chilling days) as:
+    !!     \latexonly
+    !!     \input{season_ncdmax_eqn2.tex}
+    !!     \endlatexonly
+    !!     \n
+    !!     where one_year is 1 year in seconds (defined in ::constantes).
+    !
+    ncd_max = ncd_max_year * one_year
+
+    IF ( firstcall ) THEN
+
+       !
+       !! 1.2 first call - output message giving the setting of the ::gppfrac_dormance,
+       !!     ::hvc1, ::hvc2 and ::leaf_frac (as a percentage) parameters which are 
+       !!     defined at the beginning of this subroutine. Also outputs the value of 
+       !!     ::ncd_max.
+       !
+
+       IF ( bavard .GE. 1 ) THEN
+
+          WRITE(numout,*) 'season: '
+          WRITE(numout,*) '   > maximum GPP/GGP_max ratio for dormance (::gppfrac_dormance) :',gppfrac_dormance !*
+          WRITE(numout,*) '   > maximum possible ncd(days) (::ncd_max) : ',ncd_max !*
+          WRITE(numout,*) '   > herbivore consumption C (gC/m2/d) as a function of NPP (gC/m2/d): (::hvc1) (::hvc2)' !*
+          WRITE(numout,*) '     C=',hvc1,' * NPP^',hvc2
+          WRITE(numout,*) '   > for herbivores, suppose that (::leaf_frac_hvc)',leaf_frac_hvc*100., &
+               '% of NPP is allocated to leaves'
+
+       ENDIF
+
+       !
+       !! 1.3 Check whether longer-term meteorological and phenology-related variables are not initialized
+       !!     to less than zero. If the following meteorological variables are less than ::min_stomate which is set 
+       !!     to 1.E-8 in ::grid, then they are set to the current daily value. If the phenology-
+       !!     related variables are less than ::min_stomate, they are set to "undef". 
+       !!     Warning messages are output in each case, and are also output if "long-term" C fluxes GPP,
+       !!     NPP and turnover are less than ::min_stomate.
+       !
+
+       !! 1.3.1 moisture availabilities (i.e. relative soil moisture, including the root soil profile):
+
+       !! 1.3.1.1 "monthly" (::moiavail_month)
+       !MM PAS PARALLELISE!!
+       ! WRITE(6,*)'moiavail_month 1 in stomate_season', moiavail_month(:,:)
+       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.3.1.2 "weekly" (::moiavail_week)
+
+       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
+       !WRITE(6,*)'moiavail_week 1 in stomate_season', moiavail_week(:,:)
+
+       !! 1.3.1.3 "growingseason"(::moiavail_growingseason)  
+
+       IF ( ABS( SUM( moiavail_growingseason(:,2:nvm) ) ) .LT. min_stomate ) THEN
+
+          ! in this case, set them it weekly moisture availability
+          WRITE(numout,*) 'Warning! We have to initialize the ''growingseason'' moisture availabilities. '
+          moiavail_growingseason(:,:) = moiavail_month(:,:)
+      ! WRITE(6,*)'moiavail_growingseason 2 in stomate_season', moiavail_growingseason(:,:)
+
+       ENDIF
+
+       IF ( ABS( SUM( vir_moiavail_growingseason(:,2:nvm) ) ) .LT. min_stomate ) THEN
+
+          ! in this case, set them it weekly moisture availability
+          WRITE(numout,*) 'Warning! We have to initialize the ''vir_growingseason'' moisture availabilities. '
+          vir_moiavail_growingseason(:,:) = vir_moiavail_daily(:,:)
+
+       ENDIF
+
+       !! 1.3.2 2-meter temperatures:
+
+       !! 1.3.2.1 "long term" (::t2m_longterm)
+
+       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.3.2.2 "monthly" (::t2m_month)
+
+       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.3.2.3 "weekly" (::2m_week)
+
+       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.3.3 "monthly" soil temperatures (::tsoil_month):
+       !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.3.4 "monthly" soil humidity (::soilhum_month):
+       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.3.5 growing degree days, threshold -5 deg C (::gdd_m5_dormance):
+       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.3.6 growing degree days since midwinter (::gdd_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.3.7 number of chilling days since leaves were lost (::ncd_dormance):
+       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.3.8 number of growing days, threshold -5 deg C (::ngd_minus5):
+       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.3.9 "long term" npp (::npp_longterm):
+       IF ( ABS( SUM( npp_longterm(:,2:nvm) ) ) .LT. min_stomate ) THEN
+          WRITE(numout,*) 'Warning! Long term NPP is initialized to 0.'
+       ENDIF
+
+       !! 1.3.10 "long term" turnover (::turnover_longterm):
+       IF ( ABS( SUM( turnover_longterm(:,2:nvm,:,:) ) ) .LT. min_stomate ) THEN
+          WRITE(numout,*) 'Warning! Long term turnover is initialized to 0.'
+       ENDIF
+
+       !! 1.3.11 "weekly" GPP (::gpp_week):
+       IF ( ABS( SUM( gpp_week(:,2:nvm) ) ) .LT. min_stomate ) THEN
+          WRITE(numout,*) 'Warning! Weekly GPP is initialized to 0.'
+       ENDIF
+
+       !! 1.3.12 minimum moisture availabilities (::minmoiavail_thisyear)
+       !!        In this case, if the minimum moisture
+       !!        is less than ::min_stomate, the variable is set to ::large_value,
+       !!        which is defined in ::stomate_constants as 1.E33_r_std:
+       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
+
+       ALLOCATE(cloud(npts))
+       cloud(:) = zero
+
+       !
+       !! 1.4 reset firstcall flag
+       !
+       firstcall = .FALSE.
+
+    ENDIF
+
+    ! determine yearly clear sky radiation
+    CALL downward_solar_flux (npts, lalo(:,1),calendar_str,julian_diff,12.,cloud,1,solad,solai)
+
+    ! determine min yearly clear sky radiation (solstice) as beginning for gdd count
+    WHERE (solad(:) .LT. gdd_init_date(:,2))
+       ! first position in matrix is the initialisation date, second
+       ! is the min solar flux obsrved until now
+       gdd_init_date(:,1)= julian_diff
+       gdd_init_date(:,2)= solad(:)
+    ENDWHERE
+
+    ! determine maximul yearly clear sky radiation as the end of gdd count
+    WHERE (solad(:) .GT. gdd_init_date(:,4))
+       ! third position in matrix is the termination date, fourth
+       ! is the max solar flux obsrved until now
+       gdd_init_date(:,3)= julian_diff
+       gdd_init_date(:,4)= solad(:)
+    ENDWHERE
+
+    !+++TEMP+++
+    IF(ld_pheno)THEN
+       WRITE(numout,*) 'phenology, julian_diff, ', julian_diff
+       WRITE(numout,*) 'phenology, gdd_init mid winter, ', gdd_init_date(:,1)
+       WRITE(numout,*) 'phenology, gdd_init mid summer, ', gdd_init_date(:,3) 
+    ENDIF
+    !++++++++++
+
+    !
+    !! NOTE: Sections 2. to 5. compute slowly-varying, "long-term" (i.e. weekly/monthly)
+    !! input variables using a linear relaxation method, following the equation:
+    !! \latexonly
+    !! \input{season_lin_relax_eqn1.tex}
+    !! \endlatexonly
+    !! \n 
+    !! as described in the introduction to this subroutine (see Krinner et al., 2005).  
+    !! The time constant in the above equation is given for each of the variables
+    !! described.
+    !
+
+    !
+    !! 2. Moisture availability (relative soil moisture, including the root profile) :
+    !!    The time constants (as in the above equation) for these calculations are 
+    !!    given by the parameters ::tau_hum_month (for the monthly
+    !!    calculation) or ::tau_hum_week (for the weekly),
+    !!    which are set in ::stomate_data to be 20 and 7 days respectively.
+    !!    If the moisture availability is less than zero, it is set to zero. 
+    !!    These variables are mostly used in the phenological leaf onset and senescence
+    !!    models in the modules ::stomate_phenology and ::stomate_turnover, 
+    !!    respectively. They are used in models which require a moisture limitation
+    !!    condition. These are the 'hum', 'moi', 'humgdd' and 'moigdd' onset models,
+    !!    and the 'mixed' and 'dry' (weekly only) senescence models. In addition,
+    !!    the weekly moisture availability is used to calculate the limitation
+    !!    on the fraction of NPP allocated to different compartments in the module
+    !!    ::stomate_alloc. 
+    !
+
+    !
+    !! 2.1 "monthly" (::moiavail_month)
+    !
+
+    moiavail_month = ( moiavail_month * ( tau_hum_month - dt ) + &
+         moiavail_daily * dt ) / tau_hum_month
+
+    DO j = 1,nvm  ! Loop over # PFTs
+       WHERE ( ABS(moiavail_month(:,j)) .LT. EPSILON(zero) )
+          moiavail_month(:,j) = zero
+       ENDWHERE
+    ENDDO
+
+    !
+    !! 2.2 "weekly" (::moiavail_week)
+    !
+
+    moiavail_week = ( moiavail_week * ( tau_hum_week - dt ) + &
+         moiavail_daily * dt ) / tau_hum_week
+   
+ 
+    DO j = 1,nvm ! Loop over # PFTs
+       WHERE ( ABS(moiavail_week(:,j)) .LT. EPSILON(zero) ) 
+          moiavail_week(:,j) = zero
+       ENDWHERE
+    ENDDO
+    ! WRITE(6,*)'CHECK:moiavail_week in stomate_season after calculation', moiavail_week(:,:)
+
+    !
+    ! 2.3 "growing season" 
+    !
+
+    
+    DO j=1,nvm
+ 
+       IF(is_tree(j))THEN 
+
+          WHERE(biomass(:,j,ileaf,icarbon).GT.min_stomate)
+            
+             ! ::moiavail_growingseason is only used to calculate wstress_fac in the allometric allocation.
+             ! It is used to account for the waterstress on KF which in turn depends on the leaf to sapwood 
+             ! ratio (::k_latosa). The plant can change this ratio at the same speed as the sapwood turnover
+             ! therefore tau_hul_growingseason depends on sapwood turnover (see pft_parameters). For trees 
+             ! KF (and indirectly LF) and for grasses LF are multiplied by wstress. Because the calculated 
+             ! values are too low for its purpose Sonke Zhaele multiply it by two in the N-branch (see 
+             ! stomate_season.f90). This approach maintains the physiological basis of KF while combining it 
+             ! with a simple multiplicative factor for water stress. Clearly after multiplication with 2, 
+             ! wstress is closer to 1 and will thus result in a KF values closer to the physiologically 
+             ! expected KF. Although the same solution could implemented here (by setting the value for
+             ! ::tune_waterstress, it is recognized that this could be improved.  
+             moiavail_growingseason(:,j) = ( moiavail_growingseason(:,j) * ( tau_hum_growingseason(j) - dt ) + & 
+                  MIN(un,tune_waterstress*moiavail_daily(:,j)) * dt ) / tau_hum_growingseason(j)
+             vir_moiavail_growingseason(:,j) = ( vir_moiavail_growingseason(:,j) * ( tau_hum_growingseason(j) - dt ) + & 
+                  MIN(un,tune_waterstress*vir_moiavail_daily(:,j)) * dt ) / tau_hum_growingseason(j)
+          ENDWHERE
+
+       ELSE 
+
+          WHERE(biomass(:,j,ileaf,icarbon).GT.min_stomate) 
+             
+             moiavail_growingseason(:,j) = ( moiavail_growingseason(:,j) * ( tau_hum_growingseason(j) - dt ) + & 
+                  MIN(un, tune_waterstress*moiavail_daily(:,j)) * dt ) / tau_hum_growingseason(j)
+             vir_moiavail_growingseason(:,j) = ( vir_moiavail_growingseason(:,j) * ( tau_hum_growingseason(j) - dt ) + & 
+                  MIN(un, tune_waterstress*vir_moiavail_daily(:,j)) * dt ) / tau_hum_growingseason(j)
+
+          ENDWHERE
+       ENDIF     
+
+    ENDDO
+
+    WHERE ( ABS(moiavail_growingseason(:,:)) .LT. EPSILON(zero) )
+  
+       moiavail_growingseason(:,:) = zero
+ 
+    ENDWHERE
+
+    WHERE ( ABS(vir_moiavail_growingseason(:,:)) .LT. EPSILON(zero) )
+  
+       vir_moiavail_growingseason(:,:) = zero
+ 
+    ENDWHERE
+
+
+    !---TEMP---
+    IF (ld_hydrolarch .OR. ld_wstress) THEN
+       WRITE(numout,*)'moiavail_daily going into growingseason',moiavail_daily(:,test_pft) 
+       WRITE(numout,*)'moiavail_growingseason in stomate_season', moiavail_growingseason(:,test_pft)
+       WRITE(numout,*)'vir_moiavail_growingseason in stomate_season', vir_moiavail_growingseason(:,test_pft)
+    ENDIF
+    !----------
+
+    !
+    !! 3. 2-meter temperatures
+    !!    The time constants for the "long-term", "monthly" and "weekly" 2-meter
+    !!    temperatures are given by the parameters ::tau_longterm, 
+    !!    ::tau_t2m_month, and ::tau_t2m_week,
+    !!    which are set in ::stomate_data to be 3 * one year (in seconds, as 
+    !!    described above) and 20 and 7 days respectively.
+    !!    If the temperature is less than zero, it is set to zero.
+    !!    In addition the "long term" temperature is written to the history file. \n
+    !!    These variables are used in many different modules of STOMATE. The 
+    !!    "long-term" temperature is used to calculate the long-term reference
+    !!    temperature which is used in many modules as described below. 
+    !!    The "monthly" and "weekly" temperature is used in the modules 
+    !!    ::stomate_phenology and ::stomate_turnover for the onset and senescence 
+    !!    phenological models which require a temperature condition. In addition
+    !!    the "monthly" temperature is used in ::lpj_constraints to determine 
+    !!    the presence and regeneration of the vegetation and in the module
+    !!    ::stomate_assimtemp to calculate photosynthesis temperatures.
+    !
+    
+    !
+    !! 3.1 "long-term" (::t2m_longterm) 
+    !
+
+    t2m_longterm = ( t2m_longterm * ( tau_longterm - dt ) + &
+         t2m_daily * dt ) / tau_longterm
+
+    WHERE ( ABS(t2m_longterm(:)) .LT. EPSILON(zero) ) 
+       t2m_longterm(:) = zero
+    ENDWHERE
+
+    CALL xios_orchidee_send_field("T2M_LONGTERM",t2m_longterm)
+
+    CALL histwrite_p (hist_id_stomate, 'T2M_LONGTERM', itime, &
+         t2m_longterm, npts, hori_index)
+    !
+    !! 3.2 "long-term reference" (::tlong_ref) 
+    !!      This variable is calculated using the "long term" 2-meter temperature 
+    !!      (::t2m_longerm) using the equation:
+    !!      \latexonly
+    !!      \input{season_t2m_long_ref_eqn3.tex}
+    !!      \endlatexonly
+    !!      \n
+    !!      This temperature is used for re-calculating PFT-specific variables 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, i.e. if the LPJ-DVM is used. It is also used in many STOMATE modules,
+    !!      including ::stomate_npp, ::stomate_resp, ::stomate_phenology, 
+    !!      and ::stomate_turnover.  
+    !
+
+!!$    IF (control%ok_dgvm) THEN
+    tlong_ref(:) = MAX( tlong_ref_min, MIN( tlong_ref_max, t2m_longterm(:) ) )
+
+    !+++TEMP+++
+    CALL histwrite_p (hist_id_stomate, 'TLONG_REF', itime, &
+         tlong_ref, npts, hori_index)
+    !++++++++++
+    
+!!$    ENDIF
+    !
+    !! 3.3 "monthly" (::t2m_month)
+    !
+
+    t2m_month = ( t2m_month * ( tau_t2m_month - dt ) + &
+         t2m_daily * dt ) / tau_t2m_month
+
+    WHERE ( ABS(t2m_month(:)) .LT. EPSILON(zero) )
+       t2m_month(:) = zero
+    ENDWHERE
+
+    !
+    !! 3.4 "weekly" (::t2m_week)
+    !
+
+    t2m_week = ( t2m_week * ( tau_t2m_week - dt ) + &
+         t2m_daily * dt ) / tau_t2m_week
+
+    WHERE ( ABS(t2m_week(:)) .LT. EPSILON(zero) )
+       t2m_week(:) = zero
+    ENDWHERE
+
+    !
+    !! 4. "monthly" soil temperatures (::tsoil_month)
+    !!    The time constant is given by the parameter ::tau_tsoil_month, 
+    !!    which is set in ::stomate_data to be 20 days.
+    !!    If the monthly soil temperature is less than zero, it is set to zero. \n
+    !!    This variable is used in the ::stomate_allocation module.
+    !
+
+    tsoil_month = ( tsoil_month * ( tau_tsoil_month - dt ) + &
+         tsoil_daily(:,:) * dt ) / tau_tsoil_month
+
+    WHERE ( ABS(tsoil_month(:,:)) .LT. EPSILON(zero) )
+       tsoil_month(:,:) = zero
+    ENDWHERE
+
+    !
+    !! 5. ''monthly'' soil humidity (or relative soil moisture - ::soilhum_month) 
+    !!    The time constant is given by the parameter ::tau_soilhum_month, 
+    !!    which is set in ::stomate_data to be 20 days.
+    !!    If the monthly soil humidity is less than zero, it is set to zero.
+    !
+
+    soilhum_month = ( soilhum_month * ( tau_soilhum_month - dt ) + &
+         soilhum_daily * dt ) / tau_soilhum_month
+
+    WHERE ( ABS(soilhum_month(:,:)) .LT. EPSILON(zero) )
+       soilhum_month(:,:) = zero
+    ENDWHERE
+
+    !
+    !! 6. Calculate the dormance time-length (::time_lowgpp).
+    !!    The dormancy time-length is increased by the stomate time step when   
+    !!    the weekly GPP is below one of two thresholds, 
+    !!    OR if the growing season started more than 2 years ago AND the amount of biomass
+    !!    in the carbohydrate reserve is 4 times as much as the leaf biomass.
+    !!    i.e. the plant is declared dormant if it is accumulating carbohydrates but not 
+    !!    using them, so that the beginning of the growing season can be detected .
+    !     This last condition was added by Nicolas Viovy.
+    !!    - NV: special case (3rd condition)
+    !!    Otherwise, set ::time_lowgpp to zero. \n
+    !!    The weekly GPP must be below either the parameter ::min_gpp_allowed, which is set at 
+    !!    the beginning of this subroutine to be 0.3gC/m^2/year, 
+    !!    OR it must be less than last year's maximum weekly GPP multiplied by the
+    !!    maximal ratio of GPP to maximum GPP (::gppfrac_dormance), which is set to 0.2 at the 
+    !!    beginning of this subroutine. \n
+    !!    This variable is used in the ::stomate_phenology module to allow the detection of the
+    !!    beginning of the vegetation growing season for different onset models.
+    !!    Each PFT is looped over.
+    !
+    !NVMODIF
+!!$    DO j = 2,nvm ! Loop over # PFTs
+!!$       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,icarbon) .GT. biomass(:,j,ileaf,icarbon)*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,icarbon) .GT. biomass(:,j,ileaf,icarbon)*4. ) ) )
+!!$       
+!!$          time_lowgpp(:,j) = time_lowgpp(:,j) + dt
+!!$          
+!!$       ELSEWHERE
+!!$          
+!!$          time_lowgpp(:,j) = zero
+!!$
+!!$       ENDWHERE
+!!$    ENDDO
+
+    !
+    !! 7. Calculate the growing degree days (GDD - ::gdd_m5_dormance).
+    !!    This variable is the GDD sum of the temperatures higher than -5 degrees C.
+    !!    It is inititalised to 0 at the beginning of the dormancy period (i.e.
+    !!    when ::time_lowgpp>0), and is set to "undef" when there is GPP 
+    !!    (::time_lowgpp=0), as it is not used during the growing season. \n 
+    !!    ::gdd_m5_dormance is further scaled by (::tau_gdd -dt / ::tau_gdd), 
+    !!    - ::tau_gdd is set to 40. in the module ::stomate_constants. \n
+    !     Nicolas Viovy - not sure why this is...
+    !!    This variable is used in the ::stomate_phenology module for the 
+    !!    'humgdd' and 'moigdd' leaf onset models. \n
+    !!    Each PFT is looped over but ::gdd_m5_dormance is only calculated for 
+    !!    those PFTs for which a critical GDD is defined, i.e. those which are 
+    !!    assigned to the 'humgdd' or 'moigdd' models. \n
+    !!    Finally if GDD sum is less than zero, then it is set to zero. 
+    !
+
+    DO j = 2,nvm ! Loop over # PFTs
+
+       IF (.NOT. natural(j)) THEN
+          ! reset counter: start of the growing season
+          WHERE ((when_growthinit(:,j) .EQ. zero))
+	     gdd_from_growthinit(:,j) = zero
+	  ENDWHERE
+          ! increase gdd counter
+          WHERE ( t2m_daily(:) .GT. (ZeroCelsius)  )
+             gdd_from_growthinit(:,j) = gdd_from_growthinit(:,j) + &
+                                 dt * ( t2m_daily(:) - (ZeroCelsius) )
+          ENDWHERE
+       ELSE
+          gdd_from_growthinit(:,j) = undef
+       ENDIF
+
+       ! 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_gdd_crit(j,:) .NE. undef) ) THEN
+
+          !
+          !! 7.1 set to zero if undefined and there is no GPP
+          !
+
+          WHERE (gdd_init_date(:,1) .EQ. julian_diff)
+
+             gdd_m5_dormance(:,j) = zero
+
+          ENDWHERE
+
+          !
+          !! 7.2 set to undef if there is GPP
+          !
+
+          WHERE ( when_growthinit(:,j) .EQ. zero )
+
+             gdd_m5_dormance(:,j) = undef
+
+          ENDWHERE
+
+          !
+          !! 7.3 normal update as described above where ::gdd_m5_dormance is defined (not set to "undef").
+          !
+
+          WHERE ( ( t2m_daily(:) .GT. ( ZeroCelsius - gdd_threshold ) ) .AND. &
+               ( gdd_m5_dormance(:,j) .NE. undef )           )
+             gdd_m5_dormance(:,j) = gdd_m5_dormance(:,j) + &
+                  dt * ( t2m_daily(:) - ( ZeroCelsius - gdd_threshold ) )
+          ENDWHERE
+
+          WHERE ( gdd_m5_dormance(:,j) .NE. undef ) 
+             gdd_m5_dormance(:,j) = gdd_m5_dormance(:,j) * &
+                  ( tau_gdd - dt ) / tau_gdd
+          ENDWHERE
+
+       ENDIF
+
+    ENDDO
+
+    !
+    !! 7.4 Set to zero if GDD is less than zero.
+
+    DO j = 2,nvm ! Loop over # PFTs
+       WHERE ( ABS(gdd_m5_dormance(:,j)) .LT. EPSILON(zero) )
+          gdd_m5_dormance(:,j) = zero
+       ENDWHERE
+    ENDDO
+
+    !
+    !! 8. Calculate the growing degree days (GDD) since midwinter (::gdd_midwinter)
+    !!    This variable represents the GDD sum of temperatures higher than a PFT-dependent
+    !!    threshold (::ncdgdd_temp), since midwinter.
+    !!    Midwinter is detected if the monthly temperature (::t2m_month) is lower than the weekly 
+    !!    temperature (::t2m_week) AND if the monthly temperature is lower than the long-term 
+    !!    temperature (t2m_longterm). These variables were calculated earlier in this subroutine. \n
+    !!    ::gdd_midwinter is initialised to 0.0 when midwinter is detected, and from then on 
+    !!    increased with each temperature greater than ::ncdgdd_temp, which is defined
+    !!    in the module ::stomate_constants. \n
+    !!    ::gdd_midwinter is set to "undef" when midsummer is detected, following the opposite
+    !!    conditions to those used to define midwinter. \n
+    !!    The variable is used in the ::stomate_phenology module for the leaf onset model 'ncdgdd'.
+    !!    Each PFT is looped over but the ::gdd_midwinter is only calculated for those
+    !!    PFTs for which a critical 'ncdgdd' temperature is defined, i.e. those which are 
+    !!    assigned to the 'ncdgdd' model. \n
+    !
+
+    DO j = 2,nvm ! Loop over # PFTs
+
+
+       ! only for PFTs for which ncdgdd_crittemp is defined
+       IF ( 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(:) )    )
+          WHERE (gdd_init_date(:,1) .EQ. julian_diff)
+
+             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(:) )    )
+!!$          WHERE (gdd_init_date(:,3) .EQ. julian_diff)
+!!$
+!!$             gdd_midwinter(:,j) = undef
+!!$
+!!$          ENDWHERE
+
+          WHERE ( when_growthinit(:,j) .EQ. zero )
+
+             gdd_midwinter(:,j) = undef
+
+          ENDWHERE
+
+          !
+          !! 8.3 normal update as described above
+          !
+
+          WHERE ( ( gdd_midwinter(:,j) .NE. undef ) .AND. &
+               ( t2m_daily(:) .GT. ncdgdd_temp(j)+ZeroCelsius ) )
+
+             gdd_midwinter(:,j) = &
+                  gdd_midwinter(:,j) + &
+                  dt * ( t2m_daily(:) - ( ncdgdd_temp(j)+ZeroCelsius ) )
+
+          ENDWHERE
+
+       ENDIF
+
+    ENDDO
+
+    !
+    !! 9. Calculate the number of chilling days (NCD) since leaves were lost (::ncd_dormance).
+    !!    This variable is initialised to 0 at the beginning of the dormancy period (::time_lowgpp>0)
+    !!    and increased by the stomate time step when the daily temperature is lower than the 
+    !!    PFT-dependent threshold ::ncdgdd_temp, which is defined for each PFT 
+    !!    in a table (::ncdgdd_temp_tab) in the module ::stomate_data. \n
+    !!    It is set to "undef" when there is GPP (::time_lowgpp=0) as it is not needed during
+    !!    the growing season. \n
+    !!    The variable is used in the ::stomate_phenology module for the leaf onset model 'ncdgdd'.
+    !!    Each PFT is looped over but the ::ncd_dormance is only calculated for those
+    !!    PFTs for which a critical 'ncdgdd' temperature is defined, i.e. those which are 
+    !!    assigned to the 'ncdgdd' model.
+    !
+
+    DO j = 2,nvm ! Loop over # PFTs
+
+       ! ncd_dormance is counted for both ncdgdd and ngd phenology models
+       IF ( (ncdgdd_temp(j) .NE. undef) .OR. &
+            (ngd_crit(j) .NE. undef) ) THEN
+
+          !! 9.1 set to zero if undefined and there is no GPP
+          WHERE (gdd_init_date(:,1) .EQ. julian_diff)
+
+             ncd_dormance(:,j) = zero
+
+          ENDWHERE
+
+          !! 9.2 set to undef if there is GPP
+          WHERE ( when_growthinit(:,j) .EQ. zero )
+
+             ncd_dormance(:,j) = undef
+
+          ENDWHERE
+
+          !! 9.3 normal update, as described above, where ::ncd_dormance is defined
+          WHERE ( ( ncd_dormance(:,j) .NE. undef ) .AND. &
+               ( t2m_daily(:) .LE. ncdgdd_temp(j)+ZeroCelsius ) )
+
+             ncd_dormance(:,j) = MIN( ncd_dormance(:,j) + dt, ncd_max )
+
+          ENDWHERE
+
+       ENDIF
+
+    ENDDO
+
+    !! 10. Calculate the number of growing days (NGD) since leaves were lost (::ngd_minus5).
+    !  This variable is initialised to 0 at the beginning of the dormancy period (::time_lowgpp>0)
+    !  and increased by the stomate time step when the daily temperature is higher than the threshold
+    !  -5 degrees C. \n    
+    !  ::ngd_minus5 is further scaled by (::tau_ngd -dt / ::tau_ngd), 
+    !  ::tau_ngd is set to 50. in the module ::stomate_constants. \n
+    !  Nicolas Viovy - not sure why this scaling is applied
+
+    !  The variable is used in the ::stomate_phenology module for the leaf onset model 'ngd'.
+    !  Each PFT is looped over.
+    !  If the NGD is less than zero, it is set to zero.
+    DO j = 2,nvm ! Loop over # PFTs
+
+       !! 10.1 Where there is GPP (i.e. ::time_lowgpp=0), set NGD to 0. 
+       !  This means that we only take into account NGDs when the leaves are off
+       WHERE (gdd_init_date(:,1) .EQ. julian_diff)
+
+          ngd_minus5(:,j) = zero
+
+       ENDWHERE
+
+       !! 10.2 normal update, as described above.
+       WHERE ( t2m_daily(:) .GT. (ZeroCelsius - gdd_threshold) )
+
+          ngd_minus5(:,j) = ngd_minus5(:,j) + dt
+
+       ENDWHERE
+
+       ! Apply the mysterious rescaling
+       ngd_minus5(:,j) = ngd_minus5(:,j) * ( tau_ngd - dt ) / tau_ngd
+
+    ENDDO
+
+    DO j = 2,nvm ! Loop over # PFTs
+
+       WHERE ( ABS(ngd_minus5(:,j)) .LT. EPSILON(zero) )
+
+          ngd_minus5(:,j) = zero
+
+       ENDWHERE
+
+    ENDDO
+
+    !
+    !! 11. Calculate the minimum humidity/relative soil moisture since dormance began (::hum_min_dormance) 
+    !!     and the time elapsed since this minimum (::time_hum_min). \n
+    !!     The minimum moisture availability occurs when the monthly moisture availability, which is updated 
+    !!     daily earlier in this subroutine as previously described, is at a minimum during the dormancy period.
+    !!     Therefore the ::hum_min_dormance is initialised to the monthly moisture availability 
+    !!     at the beginning of the dormancy period (i.e. if it was previously set to undefined and the
+    !!     ::time_lowgpp>0) AND then whenever the monthly moisture availability is less than it has previously
+    !!     been. \n
+    !!     Consequently, the time counter (::time_hum_min) is initialised to 0 at the beginning of the dormancy  
+    !!     period (i.e. if it was previously set to undefined and the ::time_lowgpp>0) AND when the minimum 
+    !!     moisture availability is reached, and is increased by the stomate time step every day throughout
+    !!     the dormancy period. \n
+    !!     ::time_hum_min is used in the ::stomate_phenology module for the leaf onset models 'moi' and 'moigdd'.
+    !!     Each PFT is looped over but the two variables are only calculated for those
+    !!     PFTs for which the critical parameter ::hum_min_time is defined, i.e.   
+    !!     those which are assigned to the 'moi' or 'moigdd' models.
+    !
+
+    DO j = 2,nvm ! Loop over # PFTs
+
+       IF ( hum_min_time(j) .NE. undef ) THEN
+
+          !
+          !! 11.1 initialize if undefined and there is no GPP
+          !
+
+          WHERE (when_growthinit(:,j) .EQ. zero)
+
+             time_hum_min(:,j) = zero
+             hum_min_dormance(:,j) = moiavail_month(:,j)
+
+          ENDWHERE
+
+          !
+          !! 11.3 normal update, as described above, where ::time_hum_min and ::hum_min_dormance are defined
+          !
+
+          !! 11.3.1 increase time counter by the stomate time step
+
+          WHERE ( hum_min_dormance(:,j) .NE. undef )
+
+             time_hum_min(:,j) = time_hum_min(:,j) + dt
+
+          ENDWHERE
+
+          !! 11.3.2 set time counter to zero if minimum is reached
+
+          WHERE (( 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
+
+    !
+    !! NOTE: Sections 12. to 14. compute slowly-varying, "long-term" (i.e. weekly/monthly)
+    !! C fluxes (NPP, turnover, GPP) using the same linear relaxation method as in 
+    !! Sections 2. and 5. and described in the introduction to this section, as given 
+    !! by the following equation:
+    !! \latexonly
+    !! \input{season_lin_relax_eqn1.tex}
+    !! \endlatexonly
+    !! \n 
+    !! The following variables are calculated using the above equation, and the time constant 
+    !! is given for each. 
+    !
+
+    !
+    !! 12. Update the "long term" NPP. (::npp_daily in gC/m^2/day, ::npp_longterm in gC/m^2/year.)
+    !!     The time constant is given by the parameter ::tau_longterm, 
+    !!     which is set in ::stomate_data to be 3 * one year (in seconds, as 
+    !!     described above). If the ::npp_longterm is less than zero then set it to zero. \n
+    !!     ::npp_longterm is used in ::stomate_lpj in the calculation of long-term
+    !!     vegetation dynamics and in ::stomate_lcchange in the calculation of 
+    !!     land cover change. It is also used to calculate diagnose the hebivory activity in 
+    !!     Section 22 of this subroutine.
+    !
+
+    npp_longterm = ( npp_longterm * ( tau_longterm - dt ) + &
+         (npp_daily*one_year) * dt                          ) / &
+         tau_longterm
+
+    DO j = 2,nvm ! Loop over # PFTs
+       WHERE ( ABS(npp_longterm(:,j)) .LT. EPSILON(zero) )
+          npp_longterm(:,j) = zero
+       ENDWHERE
+    ENDDO
+
+    !
+    !! 13. Update the "long term" turnover rates (in gC/m^2/year).
+    !!     The time constant is given by the parameter ::tau_longterm, 
+    !!     which is set in ::stomate_data to be 3 * one year (in seconds, as 
+    !!     described above). If the ::turnover_longterm is less than zero then set it to zero.\n
+    !!     ::turnover_longterm is used in ::stomate_lpj and :: lpg_gap in the calculation 
+    !!     of long-term vegetation dynamics.
+    !
+
+    turnover_longterm(:,:,:,:) = ( turnover_longterm(:,:,:,:) * ( tau_longterm - dt ) + &
+         (turnover_daily(:,:,:,:)*one_year) * dt                          ) / &
+         tau_longterm
+
+    DO j = 2,nvm ! Loop over # PFTs
+       WHERE ( ABS(turnover_longterm(:,j,:,:)) .LT. EPSILON(zero) )
+          turnover_longterm(:,j,:,:) = zero
+       ENDWHERE
+    ENDDO
+
+    !
+    !! 14. Update the "weekly" GPP (where there is vegetation), otherwise set to zero.
+    !!     The time constant is given by the parameter ::tau_gpp_week, 
+    !!     which is set in ::stomate_data to be 7 days. If the ::gpp_week is 
+    !!     less than zero then set it to zero. \n
+    !!     ::gpp_week is used to update the annual maximum weekly GPP (::maxgppweek_thisyear)
+    !!     in Section 16 of this subroutine, which is then used to update the variable
+    !!     ::maxgppweek_lastyear in Section 21 of this subroutine. Both ::gpp_week and 
+    !!     ::maxgppweek_lastyear are used in Section 6 of this subroutine to calculate
+    !!     the onset and time-length of the dormancy period. 
+    !      Note: Used to be weekly GPP divided by veget_max, i.e. per ground covered, but not anymore.
+    !
+
+    WHERE ( veget_max .GT. zero )
+
+       gpp_week = ( gpp_week * ( tau_gpp_week - dt ) + &
+            gpp_daily * dt ) / tau_gpp_week
+
+    ELSEWHERE
+
+       gpp_week = zero
+
+    ENDWHERE
+
+    DO j = 2,nvm ! Loop over # PFTs
+
+       WHERE ( ABS(gpp_week(:,j)) .LT. EPSILON(zero) )
+
+          gpp_week(:,j) = zero
+
+       ENDWHERE
+
+    ENDDO
+    
+    !SZ 080806: gpp_week doesn't go to zero if there are no leaves,
+    ! hence the calculation of lowgpp_time is flawed, and hence hum_min_time
+    ! to correct for this, set gpp_week to zero in the absence of leaves
+    WHERE ( ABS(gpp_week(:,:)) .LT. EPSILON(0.) .OR. biomass(:,:,ileaf,icarbon) .LT. min_stomate)
+
+       gpp_week(:,:) = 0.
+
+    ENDWHERE
+
+    
+    !! 14.1 longterm radiation use efficiency
+    ! We add an ELSEWHERE condition for the biomass check of longterm radiation use efficiency
+    ! If we don't have the biomass, use the previous value. The additional statements are needed
+    ! to make sure that rue_longterm always has a value (even during severe droughtstress).
+    DO j=2,nvm
+
+       WHERE(biomass(:,j,ileaf,icarbon).GT. min_stomate)
+
+          rue_longterm(:,j) =  ( rue_longterm(:,j) * ( one_year - dt ) + &
+               gpp_daily(:,j) / &
+               (1. - exp(-0.5 * biomass(:,j,ileaf,icarbon)*sla(j))) * dt ) / &
+               (one_year)
+         
+       ELSEWHERE
+
+          rue_longterm(:,j) = rue_longterm(:,j)
+
+       ENDWHERE
+	
+       ! Make sure rue_longterm is never less than min_stomate
+       ! else we may get error messages in allocation and other
+       ! routines
+       WHERE (rue_longterm(:,j) .LE. min_stomate)
+
+          rue_longterm(:,j) = min_stomate	
+
+       ENDWHERE
+
+    ENDDO
+
+    !! 15. Update the maximum and minimum moisture availabilities (::maxmoiavail_thisyear 
+    !!     and ::minmoiavail_thisyear). If the daily moisture availability, ::moiavail_daily,
+    !!     which was calculated earlier in this subroutine, is greater or less than the current
+    !!     value of the maximum or minimum moisture availability, then set the value for the maximum
+    !!     or minimum to the current daily value respectively. \n
+    !!     ::maxmoiavail_thisyear and ::minmoiavail_thisyear are used to update the variables 
+    !!     ::maxmoiavail_lastyear and ::minmoiavail_lastyear in Section 21 of this subroutine, 
+    !!     which are used in the module ::stomate_phenology for the leaf onset models 'hum' and 
+    !!     'humgdd', and in the module ::stomate_turnover for the leaf senescence models 'dry' 
+    !!     and 'mixed'.
+    !
+
+    WHERE ( moiavail_daily .GT. maxmoiavail_thisyear )
+       maxmoiavail_thisyear = moiavail_daily
+    ENDWHERE
+
+    WHERE ( moiavail_daily .LT. minmoiavail_thisyear )
+       minmoiavail_thisyear = moiavail_daily
+    ENDWHERE
+
+    !
+    !! 16. Update the annual maximum weekly GPP (::maxgppweek_thisyear), if the weekly GPP
+    !!     is greater than the current value of the annual maximum weekly GPP.
+    !!     The use of this variable is described in Section 14.
+    !
+
+    WHERE ( gpp_week .GT. maxgppweek_thisyear )
+       maxgppweek_thisyear = gpp_week
+    ENDWHERE
+
+    !
+    !! 17. Update the annual GDD0 by adding the current daily 2-meter temperature 
+    !!     (multiplied by the stomate time step, which is one day), if it is greater
+    !!     than zero degrees C. \n
+    !!     This variable is mostly used in the module ::lpj_establish.
+    !
+
+    WHERE ( t2m_daily .GT. ZeroCelsius )
+       gdd0_thisyear = gdd0_thisyear + dt * ( t2m_daily - ZeroCelsius )
+    ENDWHERE
+
+    !
+    !! 18. Update the annual precipitation by adding the current daily precipitation
+    !!     amount (multiplied by the stomate time step, which is usually one day). \n
+    !
+
+    precip_thisyear = precip_thisyear + dt * precip_daily
+
+    
+!
+    !! 19. Update the annual maximum leaf mass for each PFT (::lm_thisyearmax) and the maximum fractional
+    !!     plant cover if the LPJ DGVM is activated.       
+    !
+    
+    !
+    !! 19.1 If the LPJ DGVM is activated first the fraction of natural vegetation (::fracnat), i.e. non-
+    !!      agricultural vegetation (PFTs 2-11) is calculated for each PFT. Each PFT is looped over.
+    !
+    IF(control%ok_dgvm ) THEN
+
+       fracnat(:) = un
+       DO j = 2,nvm ! Loop over # PFTs
+          IF ( .NOT. natural(j) ) THEN
+             fracnat(:) = fracnat(:) - veget_max(:,j)
+          ENDIF
+       ENDDO
+
+    ENDIF
+
+    !
+    !! 19.2 If LPJ and STOMATE are activated, first the maximum fractional plant cover needs to be updated, 
+    !!      and then this year's leaf biomass. Each PFT is looped over.
+    !!      Both are updated according to the linear relaxation method described above. 
+    !!      \latexonly
+    !!      \input{season_lin_relax_eqn1.tex}
+    !!      \endlatexonly
+    !!      \n
+    !!      The time constant for this process is set as one year (in seconds) divided by the parameter
+    !!      ::leaflife_tab, which gives the leaf lifetime in years and is set for each PFT in the module 
+    !!      ::stomate_constants. Each PFT is looped over. \n
+    !
+
+    IF ( control%ok_stomate ) THEN
+       IF(control%ok_dgvm ) THEN
+          DO j=2,nvm ! Loop over # PFTs
+
+             !
+             !! 19.2.1 Calculate maximum fractional plant cover (::maxfpc_lastyear).
+             !!        If natural vegetation is present in the grid cell, and the leaf
+             !!        biomass is greater than three-quarters of last year's leaf biomass, the maximum fractional plant
+             !!        cover for last year is updated. \n 
+             !!        The short-term variable (Xs in the above equation) that is being used to update the long-term 
+             !!        maximum fractional plant cover is the fractional cover of natural vegetation, specified as 
+             !!        ::veget/::fracnat. Last year's value is then set to be this year's value.
+             !
+
+             IF ( natural(j) .AND. control%ok_dgvm ) THEN
+
+                WHERE ( fracnat(:) .GT. min_stomate .AND. biomass(:,j,ileaf,icarbon).GT. lm_lastyearmax(:,j)*0.75 )
+                   maxfpc_lastyear(:,j) = ( maxfpc_lastyear(:,j) * ( tau_leaf(j)- dt ) + &
+                        veget(:,j) / fracnat(:) * dt ) / (tau_leaf(j))
+                ENDWHERE
+                maxfpc_thisyear(:,j) = maxfpc_lastyear(:,j) ! just to initialise value
+
+             ENDIF
+
+!NV : correct initialization
+!!$             WHERE(biomass(:,j,ileaf,icarbon).GT. lm_lastyearmax(:,j)*0.75)
+!!$                lm_lastyearmax(:,j) = ( lm_lastyearmax(:,j) * ( one_year/leaflife_tab(j)- dt ) + &
+!!$                     biomass(:,j,ileaf,icarbon) * dt ) / (one_year/leaflife_tab(j))
+!!$             ENDWHERE
+!!$             lm_thisyearmax(:,j)=lm_lastyearmax(:,j) ! just to initialise value
+
+             
+             !
+             !! 19.2.2 Update this year's leaf biomass (::lm_thisyearmax).
+             !!        The short-term variable (Xs in the above equation) that is being used to update the long-term 
+             !!        this year's leaf biomass is the leaf biomass pool (::biomass(i,j,ileaf).
+             !
+             WHERE (lm_thisyearmax(:,j) .GT. min_stomate)
+                WHERE(biomass(:,j,ileaf,icarbon).GT. lm_thisyearmax(:,j)*0.75)
+                   lm_thisyearmax(:,j) = ( lm_thisyearmax(:,j) * ( tau_leaf(j)- dt ) + &
+                        biomass(:,j,ileaf,icarbon) * dt ) / (tau_leaf(j))
+                ENDWHERE
+             ELSEWHERE
+                lm_thisyearmax(:,j) =biomass(:,j,ileaf,icarbon)
+             ENDWHERE
+
+          ENDDO
+
+       ELSE
+          
+          !
+          !! 19.3 If LPJ DGVM is not activated but STOMATE is, the maximum leaf mass is set to be the same  
+          !!      as the leaf biomass (::biomass(i,j,ileaf), without a change in the maximum fractional plant cover. 
+          !
+          DO j = 2,nvm ! Loop over # PFTs
+             WHERE ( biomass(:,j,ileaf,icarbon) .GT. lm_thisyearmax(:,j) )
+                lm_thisyearmax(:,j) = biomass(:,j,ileaf,icarbon)
+             ENDWHERE
+          ENDDO
+
+       ENDIF !(control%ok_dgvm)
+    ELSE
+
+          !
+          !! 19.4 If STOMATE is not activated, the maximum leaf biomass is set to be the maximum possible 
+          !!      LAI of the PFT.
+          !
+
+       DO j = 2,nvm ! Loop over # PFTs
+          lm_thisyearmax(:,j) = lai_max(j)  / sla(j)
+       ENDDO
+
+    ENDIF  !(control%ok_stomate)
+
+    !
+    !! 20. Update the annual maximum fractional plant cover for each PFT if the current fractional cover 
+    !!     (::veget), is larger than the current maximum value.
+    !!     ::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. At the end of the every year, last year's maximum and minimum moisture availability,
+    !!     annual GDD0, annual precipitation, annual max weekly GPP, and maximum leaf mass are 
+    !!     updated with the value calculated for the current year, and then their value reset.
+    !!     Either to zero for the maximum variables, or to ::large_value (set to be 1.E33 in ::
+    !!     the module ::stomate_constants) for the minimum variable ::minmoiavail_thisyear.
+    !
+
+    IF ( EndOfYear ) THEN
+
+       !
+       !! 21.1 Update last year's values. \n
+       !!      The variables ::maxmoiavail_lastyear, ::minmoiavail_lastyear and ::maxgppweek_lastyear  
+       !!      are updated using the relaxation method:
+       !!      \latexonly
+       !!      \input{season_lin_relax_eqn1.tex}
+       !!      \endlatexonly
+       !!      \n
+       !!      where Xs is this year's value, dt (Delta-t) is set to 1 (year), and the time constant (tau) !??
+       !!      is set by the parameter ::tau_climatology, which is set to 20 years at the beginning 
+       !!      of this subroutine. \n
+       !!      The other variables (::gdd0_lastyear, ::precip_lastyear, ::lm_lastyearmax and 
+       !!      ::maxfpc_lastyear) are just replaced with this year's value.
+       !
+       !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 for the "this year" variables. \n
+       !!      The maximum variables are set to zero and the minimum variable ::minmoiavail_thisyear
+       !!      is set to ::large_value (set to be 1.E33 in the module ::stomate_constants).
+       !
+
+       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 Set the maximum fractional plant cover for non-natural vegetation 
+       !!      (i.e. agricultural C3 and C4 - PFT 12 and 13) vegetation for last year to be zero.
+       !
+
+       !
+       ! 21.3.1 Only take into account natural PFTs
+       !
+
+       DO j = 2,nvm ! Loop over # PFTs
+          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 ! Loop over # PFTs
+!!$          sumfpc_nat(:) = sumfpc_nat(:) + maxfpc_lastyear(:,j)
+!!$       ENDDO
+!!$
+!!$       ! scale so that the new sum is fpc_crit
+!!$       DO j = 2,nvm ! Loop over # PFTs 
+!!$          WHERE ( sumfpc_nat(:) .GT. fpc_crit )
+!!$             maxfpc_lastyear(:,j) = maxfpc_lastyear(:,j) * (fpc_crit/sumfpc_nat(:))
+!!$          ENDWHERE
+!!$       ENDDO
+
+    ENDIF  ! EndOfYear
+
+    !
+    !! 22. Diagnose herbivore activity (::herbivores), determined as probability for a leaf to be
+    !!     eaten in a day (follows McNaughton et al., 1989). \n
+    !!     The amount of herbivore activity is used in the modules ::lpj_establish  
+    !!     and ::stomate_turnover.
+    !
+
+    !
+    !! 22.1 First calculate the mean long-term leaf NPP in grid box, mean residence
+    !!      time (years) of green tissue to give the biomass available for herbivore consumption.
+    !!      Each PFT is looped over, though the calculation is only made for
+    !!      natural vegetation (PFTs 2-11).
+    !
+
+    nlflong_nat(:,:) = zero
+    weighttot(:,:) = zero
+    green_age(:,:) = zero
+    !
+    DO j = 2,nvm ! Loop over # PFTs
+       !
+       IF ( natural(j) ) THEN
+          !
+          !! 22.1.1 Calculate the total weight of the leaves (::weighttot) as last year's leaf biomass
+          !
+          weighttot(:,j) = lm_lastyearmax(:,j)
+          
+          !
+          !! 22.1.2 Calculate the mean long-term leaf NPP as the long-term NPP calculated in Section 12 of 
+          !!        this subroutine weighted by the leaf fraction (::leaf_frac), which is defined to be 0.33
+          !!        at the beginning of this subroutine.
+          !
+          nlflong_nat(:,j) = npp_longterm(:,j) * leaf_frac_hvc
+          
+          !
+          !! 22.1.3 Calculate the mean residence time of the green tissue (::green_age) 
+          !!        This is calculated as the sum of 6 months 
+          !!        for natural seasonal vegetation (i.e. PFTs 3, 6, 8-11), and 2 years for evergreen 
+          !!        (PFTs 2, 4, 5, 8), multiplied by last year's leaf biomass for each PFT, divided by the 
+          !!        total weight of the leaves for all PFTs.
+          !         This is a crude approximation.  !!?? By whom?
+          !!        The difference between seasonal and evergreen vegetation is determined by the parameter
+          !!        ::pheno_model, which specifies the onset model of the PFT.
+ 
+          !
+          IF ( pheno_model(j) .EQ. 'none' ) THEN
+             green_age(:,j) = green_age_ever * lm_lastyearmax(:,j)
+          ELSE
+             green_age(:,j) = green_age_dec * 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. (1989) give herbivore consumption as a function of mean, long-term leaf NPP.
+    !!      as it gives an estimate of the edible biomass. The consumption of biomass by herbivores and the 
+    !!      resultant herbivore activity are calculated following the equations:
+    !!      \latexonly
+    !!      \input{season_consumption_eqn4.tex}
+    !!      \endlatexonly
+    !!      \n 
+    !!      and 
+    !!      \latexonly
+    !!      \input{season_herbivore_eqn5.tex}
+    !!      \endlatexonly
+    !!      \n 
+    !       
+
+    DO j = 2,nvm ! Loop over # PFTs
+       !
+       IF ( natural(j) ) THEN
+          !
+          WHERE ( nlflong_nat(:,j) .GT. zero )
+             consumption(:) = hvc1 * nlflong_nat(:,j) ** hvc2
+             herbivores(:,j) = one_year * green_age(:,j) * nlflong_nat(:,j) / 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: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_soilcarbon.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_soilcarbon.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_soilcarbon.f90	(revision 7236)
@@ -0,0 +1,577 @@
+! =================================================================================================================================
+! MODULE       : stomate_soilcarbon
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF       Calculate soil dynamics largely following the Century model
+!!	
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! SVN		:
+!! $HeadURL$ 
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE stomate_soilcarbon
+
+  ! modules used:
+
+  USE ioipsl_para
+  USE stomate_data
+  USE constantes
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC soilcarbon,soilcarbon_clear
+
+  ! Variables shared by all subroutines in this module
+  
+  LOGICAL, SAVE    :: firstcall = .TRUE.   !! Is this the first call? (true/false)
+!$OMP THREADPRIVATE(firstcall)
+
+CONTAINS
+
+
+!! ================================================================================================================================
+!!  SUBROUTINE   : soilcarbon_clear
+!!
+!>\BRIEF        Set the flag ::firstcall to .TRUE. and as such activate sections 1.1.2 and 1.2 of the subroutine soilcarbon 
+!! (see below).
+!! 
+!_ ================================================================================================================================
+  
+  SUBROUTINE soilcarbon_clear
+    firstcall=.TRUE.
+  END SUBROUTINE soilcarbon_clear
+
+
+!! ================================================================================================================================
+!!  SUBROUTINE   : soilcarbon
+!!
+!>\BRIEF        Computes the soil respiration and carbon stocks, essentially 
+!! following Parton et al. (1987).
+!!
+!! DESCRIPTION	: The soil is divided into 3 carbon pools, with different 
+!! characteristic turnover times : active (1-5 years), slow (20-40 years) 
+!! and passive (200-1500 years).\n
+!! There are three types of carbon transferred in the soil:\n
+!! - carbon input in active and slow pools from litter decomposition,\n
+!! - carbon fluxes between the three pools,\n
+!! - carbon losses from the pools to the atmosphere, i.e., soil respiration.\n
+!!
+!! The subroutine performs the following tasks:\n
+!!
+!! Section 1.\n
+!! The flux fractions (f) between carbon pools are defined based on Parton et 
+!! al. (1987). The fractions are constants, except for the flux fraction from
+!! the active pool to the slow pool, which depends on the clay content,\n
+!! \latexonly
+!! \input{soilcarbon_eq1.tex}
+!! \endlatexonly\n
+!! In addition, to each pool is assigned a constant turnover time.\n
+!!
+!! Section 2.\n
+!! The carbon input, calculated in the stomate_litter module, is added to the 
+!! carbon stock of the different pools.\n
+!!
+!! Section 3.\n
+!! First, the outgoing carbon flux of each pool is calculated. It is 
+!! proportional to the product of the carbon stock and the ratio between the 
+!! iteration time step and the residence time:\n
+!! \latexonly
+!! \input{soilcarbon_eq2.tex}
+!! \endlatexonly
+!! ,\n
+!! Note that in the case of crops, the additional multiplicative factor 
+!! integrates the faster decomposition due to tillage (following Gervois et 
+!! al. (2008)).
+!! In addition, the flux from the active pool depends on the clay content:\n
+!! \latexonly
+!! \input{soilcarbon_eq3.tex}
+!! \endlatexonly
+!! ,\n
+!! Each pool is then cut from the carbon amount corresponding to each outgoing
+!! flux:\n
+!! \latexonly
+!! \input{soilcarbon_eq4.tex}
+!! \endlatexonly\n
+!! Second, the flux fractions lost to the atmosphere is calculated in each pool
+!! by subtracting from 1 the pool-to-pool flux fractions. The soil respiration 
+!! is then the summed contribution of all the pools,\n
+!! \latexonly
+!! \input{soilcarbon_eq5.tex}
+!! \endlatexonly\n
+!! Finally, each carbon pool accumulates the contribution of the other pools:
+!! \latexonly
+!! \input{soilcarbon_eq6.tex}
+!! \endlatexonly
+!!
+!! Section 4.\n
+!! If the flag SPINUP_ANALYTIC is set to true, the matrix A is updated following
+!! Lardy (2011).
+!!
+!! RECENT CHANGE(S): None
+!! 
+!! MAIN OUTPUTS VARIABLE(S): carbon, resp_hetero_soil
+!!
+!! REFERENCE(S)   :
+!! - Parton, W.J., D.S. Schimel, C.V. Cole, and D.S. Ojima. 1987. Analysis of 
+!! factors controlling soil organic matter levels in Great Plains grasslands. 
+!! Soil Sci. Soc. Am. J., 51, 1173-1179.
+!! - Gervois, S., P. Ciais, N. de Noblet-Ducoudre, N. Brisson, N. Vuichard, 
+!! and N. Viovy (2008), Carbon and water balance of European croplands 
+!! throughout the 20th century, Global Biogeochem. Cycles, 22, GB2022, 
+!! doi:10.1029/2007GB003018.
+!! - Lardy, R, et al., A new method to determine soil organic carbon equilibrium,
+!! Environmental Modelling & Software (2011), doi:10.1016|j.envsoft.2011.05.016
+!!
+!! FLOWCHART    :
+!! \latexonly
+!! \includegraphics[scale=0.5]{soilcarbon_flowchart.jpg}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE soilcarbon (npts, dt, clay, soilcarbon_input, &
+       control_temp, control_moist, carbon, resp_hetero_soil, &
+       MatrixA,veget_max)
+
+!! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables
+    
+    INTEGER(i_std), INTENT(in)                            :: npts             !! Domain size (unitless)
+    REAL(r_std), INTENT(in)                               :: dt               !! Time step \f$(dtradia one_day^{-1})$\f
+    REAL(r_std), DIMENSION(npts), INTENT(in)              :: clay             !! Clay fraction (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)          :: veget_max        !! Coverage fraction of a PFT within the pixel 
+                                                                              !! (unitless, 0-1) 
+    REAL(r_std), DIMENSION(npts,nlevs), INTENT(in)        :: control_temp     !! Temperature control of heterotrophic respiration 
+                                                                              !! (unitless: 0->1)
+    REAL(r_std), DIMENSION(npts,nlevs), INTENT(in)        :: control_moist    !! Moisture control of heterotrophic respiration 
+                                                                              !! (unitless: 0.25->1)
+    REAL(r_std), DIMENSION(npts,ncarb,nvm), INTENT(in)    :: soilcarbon_input !! Amount of carbon going into the carbon pools from 
+                                                                              !! litter decomposition \f$(gC m^{-2} day^{-1})$\f
+
+    !! 0.2 Output variables
+    
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)         :: resp_hetero_soil !! Soil heterotrophic respiration 
+                                                                              !! \f$(gC m^{-2} (dtradia one_day^{-1})^{-1})$\f
+
+    !! 0.3 Modified variables
+    
+    REAL(r_std), DIMENSION(npts,ncarb,nvm), INTENT(inout) :: carbon           !! Soil carbon pools: active, slow, or passive, 
+                                                                              !! \f$(gC m^{2})$\f
+    REAL(r_std), DIMENSION(npts,nvm,nbpools,nbpools), &
+                                            INTENT(inout) :: MatrixA          !! Matrix containing the fluxes between the carbon
+                                                                              !! pools per sechiba time step 
+                                                                              !! @tex $(gC.m^2.day^{-1})$ @endtex
+
+    !! 0.4 Local variables
+    REAL(r_std), SAVE, DIMENSION(ncarb)                   :: carbon_tau       !! Residence time in carbon pools (days)
+!$OMP THREADPRIVATE(carbon_tau)
+    REAL(r_std), DIMENSION(npts,ncarb,ncarb)              :: frac_carb        !! Flux fractions between carbon pools 
+                                                                              !! (second index=origin, third index=destination) 
+                                                                              !! (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,ncarb)                    :: frac_resp        !! Flux fractions from carbon pools to the atmosphere 
+                                                                              !! (respiration) (unitless, 0-1)
+    REAL(r_std), DIMENSION(npts,ncarb,nelements)          :: fluxtot          !! Total flux out of carbon pools \f$(gC m^{2})$\f
+    REAL(r_std), DIMENSION(npts,ncarb,ncarb,nelements)    :: flux             !! Fluxes between carbon pools \f$(gC m^{2})$\f
+    CHARACTER(LEN=7), DIMENSION(ncarb)                    :: carbon_str       !! Name of the carbon pools for informative outputs 
+                                                                              !! (unitless)
+    INTEGER(i_std)                                        :: iicarb,m,j       !! Indices (unitless)
+    INTEGER(i_std)                                        :: icarb, imbc      !! Indices (unitless)
+    INTEGER(i_std)                                        :: ipts, ivm        !! Indices (unitless)
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements)    :: check_intern     !! Contains the components of the internal
+                                                                              !! mass balance chech for this routine
+                                                                              !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)            :: closure_intern   !! Check closure of internal mass balance
+                                                                              !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)            :: pool_start       !! Start and end pool of this routine 
+                                                                              !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)            :: pool_end         !! Start and end pool of this routine 
+                                                                              !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex  
+
+!_ ================================================================================================================================
+
+    !! bavard is the level of diagnostic information, 0 (none) to 4 (full)
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering soilcarbon' 
+
+!! 1. Initializations
+
+    !! 1.1 Initialize check for mass balance closure
+    !  The mass balance is calculated at the end of this routine
+    !  in section 14. Initial biomass and harvest pool and all other
+    !  relevant pools were set to zero before calling this routine.
+    pool_start(:,:,:) = zero
+    DO icarb = 1,ncarb
+          pool_start(:,:,icarbon) = pool_start(:,:,icarbon) + &
+               ( carbon(:,icarb,:) + (soilcarbon_input(:,icarb,:) * dt) ) * &
+               veget_max(:,:)
+    ENDDO
+
+    !! 1.2 Get soil "constants"
+    !! 1.2.1 Flux fractions between carbon pools: depend on clay content, 
+    !  recalculated each time. 
+    ! From active pool: depends on clay content
+    frac_carb(:,iactive,iactive) = zero
+    frac_carb(:,iactive,ipassive) = frac_carb_ap
+    frac_carb(:,iactive,islow) = un - frac_carb(:,iactive,ipassive) - &
+         (metabolic_ref_frac - active_to_pass_clay_frac*clay(:)) 
+
+    ! 1.2.2 from slow pool
+    frac_carb(:,islow,islow) = zero
+    frac_carb(:,islow,iactive) = frac_carb_sa
+    frac_carb(:,islow,ipassive) = frac_carb_sp
+
+    ! From passive pool
+    frac_carb(:,ipassive,ipassive) = zero
+    frac_carb(:,ipassive,iactive) = frac_carb_pa
+    frac_carb(:,ipassive,islow) = frac_carb_ps
+    
+    IF ( firstcall ) THEN
+
+       !! 1.2.3 Residence times in carbon pools (days)
+       !  1.5 years. This is same as CENTURY. But, in Parton et 
+       !  al. (1987), it's weighted by moisture and temperature 
+       !  dependences.
+       carbon_tau(iactive) = carbon_tau_iactive * one_year
+
+       ! 25 years. This is same as CENTURY. But, in Parton et 
+       ! al. (1987), it's weighted by moisture and temperature 
+       ! dependences.      
+       carbon_tau(islow) = carbon_tau_islow * one_year
+
+       ! 1000 years. This is same as CENTURY. But, in Parton et 
+       ! al. (1987), it's weighted by moisture and temperature 
+       ! dependences.   
+       carbon_tau(ipassive) = carbon_tau_ipassive * one_year       
+
+       !! 1.2.4 Messages : display the residence times  
+       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 icarb = 1, ncarb ! Loop over carbon pools
+          WRITE(numout,*) '(1, ::carbon_str(icarb)):',carbon_str(icarb), &
+               ' : (1, ::carbon_tau(icarb)):',carbon_tau(icarb)
+       ENDDO
+
+       WRITE(numout,*) '   > flux fractions between carbon pools: depend on clay content'
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    !! 1.3 Set soil respiration to zero
+    resp_hetero_soil(:,:) = zero
+
+
+!! 2. Update the carbon stocks with the different soil carbon input
+
+    carbon(:,:,:) = carbon(:,:,:) + soilcarbon_input(:,:,:) * dt
+
+
+!! 3. Fluxes between carbon reservoirs, and to the atmosphere (respiration) \n
+
+    !! 3.1. Determine the respiration fraction : what's left after
+    ! subtracting all the 'pool-to-pool' flux fractions
+    ! 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 = 1,nvm ! Loop over #Â PFTs
+
+      !! 3.2.1. Flux out of pools
+      DO icarb = 1, ncarb ! Loop over carbon pools from which the flux comes
+        
+        ! Determine total flux out of pool
+        ! For crops multiply tillage factor of decomposition
+        ! Not crop
+         IF ( natural(m) ) THEN
+
+            fluxtot(:,icarb,icarbon) = dt/carbon_tau(icarb) * carbon(:,icarb,m) * &
+                  control_moist(:,ibelow) * control_temp(:,ibelow)
+
+         ! C3 crop
+          ELSEIF ( (.NOT. natural(m)) .AND. (.NOT. is_c4(m)) ) THEN
+
+             fluxtot(:,icarb,icarbon) = dt/carbon_tau(icarb) * carbon(:,icarb,m) * &
+                  control_moist(:,ibelow) * control_temp(:,ibelow) * &
+                  flux_tot_coeff(1)
+
+          ! C4 Crop   
+          ELSEIF ( (.NOT. natural(m)) .AND. is_c4(m) ) THEN
+
+             fluxtot(:,icarb,icarbon) = dt/carbon_tau(icarb) * carbon(:,icarb,m) * &
+                  control_moist(:,ibelow) * control_temp(:,ibelow) * &
+                  flux_tot_coeff(2)
+
+        ENDIF ! natural(m)
+
+        ! Carbon flux from active pools depends on clay content
+        IF ( icarb .EQ. iactive ) THEN
+
+            fluxtot(:,icarb,icarbon) = fluxtot(:,icarb,icarbon) * &
+                 ( un - flux_tot_coeff(3) * clay(:) )
+
+        ENDIF
+        
+        ! Update the loss in each carbon pool
+        carbon(:,icarb,m) = carbon(:,icarb,m) - fluxtot(:,icarb,icarbon)
+        
+        ! Fluxes towards the other pools (icarb -> iicarb)
+        ! Loop over the carbon pools where the flux goes
+        DO iicarb = 1, ncarb 
+
+          flux(:,icarb,iicarb,icarbon) = frac_carb(:,icarb,iicarb) * &
+               fluxtot(:,icarb,icarbon)
+
+        ENDDO
+        
+      ENDDO ! End of loop over carbon pools
+      
+      !! 3.2.2 respiration
+      !  BE CAREFUL: Here resp_hetero_soil is divided by dt to have a value which corresponds to
+      !  the sechiba time step but then in stomate.f90 resp_hetero_soil is multiplied by dt.
+      !  Perhaps it could be simplified. Moreover, we should entirely adapt the routines to the 
+      !  dtradia/one_day time step and avoid some constructions that could create bugs during 
+      !  future developments.
+      resp_hetero_soil(:,m) = &
+         ( frac_resp(:,iactive) * fluxtot(:,iactive,icarbon) + &
+         frac_resp(:,islow) * fluxtot(:,islow,icarbon) + &
+         frac_resp(:,ipassive) * fluxtot(:,ipassive,icarbon)  ) / dt
+      
+      !! 3.2.3 add fluxes to active, slow, and passive pools
+      DO icarb = 1, ncarb ! Loop over carbon pools
+
+        carbon(:,icarb,m) = carbon(:,icarb,m) + &
+           flux(:,iactive,icarb,icarbon) + flux(:,ipassive,icarb,icarbon) + &
+           flux(:,islow,icarb,icarbon)
+
+      ENDDO ! Loop over carbon pools 
+      
+    ENDDO ! End loop over PFTs
+
+    
+!! 4. Check mass balance closure
+    
+    !! 4.1 Calculate components of the mass balance
+    pool_end(:,:,:) = zero 
+    DO icarb = 1,ncarb
+          pool_end(:,:,icarbon) = pool_end(:,:,icarbon) + &
+               ( carbon(:,icarb,:) * veget_max(:,:) )
+    ENDDO
+
+    !! 4.2 Calculate mass balance
+    !  Note that soilcarbon is transfered to other pools but that the pool
+    !  was not updated. We should not account for it in ::pool_end
+    check_intern(:,:,:,:) = zero
+    check_intern(:,:,iatm2land,icarbon) = zero
+    check_intern(:,:,iland2atm,icarbon) = -un * resp_hetero_soil(:,:) * &
+         veget_max(:,:) * dt 
+    check_intern(:,:,ilat2out,icarbon) = zero
+    check_intern(:,:,ilat2in,icarbon) = -un *  zero
+    check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - &
+         pool_start(:,:,icarbon))
+    closure_intern = zero
+    DO imbc = 1,nmbcomp
+       closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + &
+            check_intern(:,:,imbc,icarbon)
+    ENDDO
+
+    !! 4.3 Write verdict
+    DO ipts=1,npts
+       DO ivm=1,nvm
+          IF(ABS(closure_intern(ipts,ivm,icarbon)) .LE. min_stomate)THEN
+             IF (ld_massbal) WRITE(numout,*) 'Mass balance closure in stomate_soilcarbon.f90'
+          ELSE
+             WRITE(numout,*) 'Error: mass balance is not closed in stomate_soilcarbon.f90'
+             WRITE(numout,*) '   ipts,ivm; ', ipts,ivm
+             WRITE(numout,*) '   Difference is, ', closure_intern(ipts,ivm,icarbon)
+             WRITE(numout,*) '   pool_end,pool_start: ', pool_end(ipts,ivm,icarbon), pool_start(ipts,ivm,icarbon)
+             WRITE(numout,*) '   resp_hetero_soil,veget_max: ', resp_hetero_soil(ipts,ivm),veget_max(ipts,ivm) 
+             IF(ld_stop)THEN
+                CALL ipslerr_p (3,'soilcarbon', 'Mass balance error.','','')
+             ENDIF
+          ENDIF
+       ENDDO
+    ENDDO
+
+    
+ !! 5. (Quasi-)Analytical Spin-up
+    
+    !! 5.2 Finish to fill MatrixA with fluxes between soil pools
+    
+    IF (spinup_analytic) THEN
+
+       DO m = 2,nvm 
+
+          ! flux leaving the active pool
+          MatrixA(:,m,iactive_pool,iactive_pool) = moins_un * &
+               dt/carbon_tau(iactive) * &
+               control_moist(:,ibelow) * control_temp(:,ibelow) * &
+               ( 1. - flux_tot_coeff(3) * clay(:)) 
+
+          ! flux received by the active pool from the slow pool
+          MatrixA(:,m,iactive_pool,islow_pool) =  &
+               frac_carb(:,islow,iactive)*dt/carbon_tau(islow) * &
+               control_moist(:,ibelow) * control_temp(:,ibelow)
+
+          ! flux received by the active pool from the passive pool
+          MatrixA(:,m,iactive_pool,ipassive_pool) =  &
+               frac_carb(:,ipassive,iactive)*dt/carbon_tau(ipassive) * &
+               control_moist(:,ibelow) * control_temp(:,ibelow) 
+
+          ! flux received by the slow pool from the active pool
+          MatrixA(:,m,islow_pool,iactive_pool) =  frac_carb(:,iactive,islow) *&
+               dt/carbon_tau(iactive) * &
+               control_moist(:,ibelow) * control_temp(:,ibelow) * &
+               ( 1. - flux_tot_coeff(3) * clay(:) ) 
+
+          ! flux leaving the slow pool
+          MatrixA(:,m,islow_pool,islow_pool) = moins_un * &
+               dt/carbon_tau(islow) * &
+               control_moist(:,ibelow) * control_temp(:,ibelow)
+
+          ! flux received by the passive pool from the active pool
+          MatrixA(:,m,ipassive_pool,iactive_pool) =  &
+               frac_carb(:,iactive,ipassive)* &
+               dt/carbon_tau(iactive) * &
+               control_moist(:,ibelow) * control_temp(:,ibelow) *&
+               ( 1. - flux_tot_coeff(3) * clay(:) )
+
+          ! flux received by the passive pool from the slow pool
+          MatrixA(:,m,ipassive_pool,islow_pool) =  &
+               frac_carb(:,islow,ipassive) * &
+               dt/carbon_tau(islow) * &
+               control_moist(:,ibelow) * control_temp(:,ibelow)
+
+          ! flux leaving the passive pool
+          MatrixA(:,m,ipassive_pool,ipassive_pool) =  moins_un * &
+               dt/carbon_tau(ipassive) * &
+               control_moist(:,ibelow) * control_temp(:,ibelow)      
+
+
+          IF ( (.NOT. natural(m)) .AND. (.NOT. is_c4(m)) ) THEN ! C3crop
+
+             ! flux leaving the active pool
+             MatrixA(:,m,iactive_pool,iactive_pool) = &
+                  MatrixA(:,m,iactive_pool,iactive_pool) * &
+                  flux_tot_coeff(1)  
+
+             ! flux received by the active pool from the slow pool
+             MatrixA(:,m,iactive_pool,islow_pool)= &
+                  MatrixA(:,m,iactive_pool,islow_pool) * &
+                  flux_tot_coeff(1) 
+
+             ! flux received by the active pool from the passive pool
+             MatrixA(:,m,iactive_pool,ipassive_pool) = &
+                  MatrixA(:,m,iactive_pool,ipassive_pool) * &
+                  flux_tot_coeff(1)    
+
+             ! flux received by the slow pool from the active pool
+             MatrixA(:,m,islow_pool,iactive_pool) =  &
+                  MatrixA(:,m,islow_pool,iactive_pool) * &
+                  flux_tot_coeff(1) 
+
+             ! flux leaving the slow pool
+             MatrixA(:,m,islow_pool,islow_pool) = &
+                  MatrixA(:,m,islow_pool,islow_pool) * &
+                  flux_tot_coeff(1)     
+
+             ! flux received by the passive pool from the active pool
+             MatrixA(:,m,ipassive_pool,iactive_pool) = &
+                  MatrixA(:,m,ipassive_pool,iactive_pool) * &
+                  flux_tot_coeff(1)
+
+             ! flux received by the passive pool from the slow pool
+             MatrixA(:,m,ipassive_pool,islow_pool) = &
+                  MatrixA(:,m,ipassive_pool,islow_pool) * &
+                  flux_tot_coeff(1)
+
+             ! flux leaving the passive pool
+             MatrixA(:,m,ipassive_pool,ipassive_pool) =  &
+                  MatrixA(:,m,ipassive_pool,ipassive_pool) *&
+                  flux_tot_coeff(1)
+
+          ENDIF ! (.NOT. natural(m)) .AND. (.NOT. is_c4(m)) 
+
+
+          IF ( (.NOT. natural(m)) .AND. is_c4(m) ) THEN ! C4crop
+
+             ! flux leaving the active pool
+             MatrixA(:,m,iactive_pool,iactive_pool) = &
+                  MatrixA(:,m,iactive_pool,iactive_pool) * &
+                  flux_tot_coeff(2)  
+
+            ! flux received by the active pool from the slow pool
+             MatrixA(:,m,iactive_pool,islow_pool)= &
+                  MatrixA(:,m,iactive_pool,islow_pool) * &
+                  flux_tot_coeff(2) 
+
+             ! flux received by the active pool from the passive pool
+             MatrixA(:,m,iactive_pool,ipassive_pool) = &
+                  MatrixA(:,m,iactive_pool,ipassive_pool) * &
+                  flux_tot_coeff(2)    
+
+             ! flux received by the slow pool from the active pool
+             MatrixA(:,m,islow_pool,iactive_pool) =  &
+                  MatrixA(:,m,islow_pool,iactive_pool) * &
+                  flux_tot_coeff(2) 
+
+             ! flux leaving the slow pool
+             MatrixA(:,m,islow_pool,islow_pool) = &
+                  MatrixA(:,m,islow_pool,islow_pool) * &
+                  flux_tot_coeff(2)     
+
+             ! flux received by the passive pool from the active pool
+             MatrixA(:,m,ipassive_pool,iactive_pool) = &
+                  MatrixA(:,m,ipassive_pool,iactive_pool) * &
+                  flux_tot_coeff(2)
+
+             ! flux received by the passive pool from the slow pool
+             MatrixA(:,m,ipassive_pool,islow_pool) = &
+                  MatrixA(:,m,ipassive_pool,islow_pool) * &
+                  flux_tot_coeff(2)
+
+             ! flux leaving the passive pool
+             MatrixA(:,m,ipassive_pool,ipassive_pool) =  &
+                  MatrixA(:,m,ipassive_pool,ipassive_pool) * &
+                  flux_tot_coeff(2)
+
+          ENDIF ! (.NOT. natural(m)) .AND. is_c4(m) 
+
+          IF (bavard.GE.4) WRITE(numout,*)'Finish to fill MatrixA'
+
+       ENDDO ! Loop over # PFTS
+
+
+       ! 5.2 Add Identity for each submatrix(7,7) 
+
+       DO j = 1,nbpools
+          MatrixA(:,:,j,j) = MatrixA(:,:,j,j) + un 
+       ENDDO
+
+    ENDIF ! (spinup_analytic)
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving soilcarbon'
+    
+  END SUBROUTINE soilcarbon
+
+END MODULE stomate_soilcarbon
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_stand_structure.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_stand_structure.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_stand_structure.f90	(revision 7236)
@@ -0,0 +1,163 @@
+! =================================================================================================================================
+! MODULE       : stomate_stand_structure
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF         Initialize and update density, crown area.
+!!
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! REFERENCE(S)	:
+!!
+!! SVN          :
+!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/branches/ORCHIDEE-DOFOCO/ORCHIDEE/src_stomate/stomate_prescribe.f90 $
+!! $Date: 2013-01-04 16:50:56 +0100 (Fri, 04 Jan 2013) $
+!! $Revision: 1126 $
+!! \n
+!_ ================================================================================================================================
+
+MODULE stomate_stand_structure
+
+  ! modules used:
+
+  USE ioipsl_para
+  USE stomate_data
+  USE pft_parameters
+  USE constantes
+  USE function_library, ONLY:wood_to_height_eff, wood_to_dia_eff, wood_to_cv_eff, wood_to_cn_eff 
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC stand_structure_clear, derive_biomass_quantities
+
+    ! first call
+    LOGICAL, SAVE                                    :: firstcall = .TRUE.
+    
+CONTAINS
+
+! =================================================================================================================================
+!! SUBROUTINE   : stand_structure_clear
+!!
+!>\BRIEF        : Set the firstcall flag back to .TRUE. to prepare for the next simulation.
+!_=================================================================================================================================
+
+  SUBROUTINE stand_structure_clear
+    firstcall=.TRUE.
+  END SUBROUTINE stand_structure_clear
+
+
+!! ================================================================================================================================
+!! SUBROUTINE 	:derive_biomass_quantities
+!!
+!>\BRIEF        Use the basal areabiomass and number density to derive various
+!!              distributions of the trees in a single grid point for
+!!              all vegetation types
+!!
+!! DESCRIPTION  : I have chosen to do this for a single grid point instead of 
+!!                the whole map or a single grid point and single PFT because
+!!                of the compromise between speed (subroutine overhead) and
+!!                flexibility
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::height_dist, ::diameter_dist, ::cn_area_dist, ::cn_vol_dist
+!!
+!! REFERENCE(S) : 
+!!
+!! FLOWCHART : None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE derive_biomass_quantities(npts, nvm, ncirc, circ_class_n, &
+       circ_class_biomass, values)
+
+  !! 0 Variable and parameter declaration 
+  
+    !! 0.1 Input variables
+    INTEGER,INTENT(IN)                                      :: npts               !! Number of pixels
+    INTEGER,INTENT(IN)                                      :: nvm                !! Number of PFT types
+    INTEGER,INTENT(IN)                                      :: ncirc              !! Number of circumference classes
+    REAL(r_std), DIMENSION(npts,nvm,ncirc,nparts,nelements), &
+         INTENT(IN)                                         :: circ_class_biomass !! Biomass of the componets of the model  
+                                                                                  !! tree within a circumference
+                                                                                  !! class @tex $(gC ind^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,ncirc), INTENT(IN) &
+                                                            :: circ_class_n       !! Number of trees within each circumference
+                                                                                  !! class @tex $(m^{-2})$ @endtex
+
+    !! 0.2 Output variables
+
+    REAL(r_std),DIMENSION(npts,nvm,ncirc,ndist_types),INTENT(OUT)  &
+                                                            :: values             !! An array which holds data for
+                                                                                  !! various canopy parameters 
+
+
+    !! 0.3 Modified variables
+
+    !! 0.4 Local variables
+
+    INTEGER(i_std)                                          :: ipts, ivm, icir, &
+                                                                       idist_type !! index (unitless)
+!_ ================================================================================================================================
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Entering derive_biomass_quantities'
+
+    ! zero everything
+    values(:,:,:,:)=zero
+
+    DO ipts=1,npts
+       DO ivm=1,nvm
+
+          IF (.NOT. is_tree(ivm)) CYCLE
+
+          ! compute the new mean values
+
+          ! for the height
+          values(ipts,ivm,:,iheight)=&
+               wood_to_height_eff(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)
+
+          ! for the crown area
+          values(ipts,ivm,:,icnarea)=&
+               wood_to_cn_eff(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)
+
+          ! for the stem diameter
+          values(ipts,ivm,:,idiameter)=&
+               wood_to_dia_eff(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)
+
+          ! for the crown volume
+          values(ipts,ivm,:,icnvol)=&
+               wood_to_cv_eff(circ_class_biomass(ipts,ivm,:,:,icarbon),ivm)
+
+          ! these next two assume the crowns are ellipsoids...since we are 
+          ! interested in spheres at the moment, we just set the two crown
+          ! diameters to be equal for the verticle crown diameter
+          DO icir=1,ncirc
+             values(ipts,ivm,icir,icndiaver)=&
+                  2.0_r_std*(3.0_r_std*values(ipts,ivm,icir,icnvol)/&
+                  (4.0_r_std*pi))**(un/3.0_r_std)
+          ENDDO
+
+          ! for the horizontal crown diameter
+          values(ipts,ivm,:,icndiahor)=values(ipts,ivm,:,icndiaver)
+
+       ENDDO ! loop over PFT
+
+    ENDDO ! loop over points
+
+    IF (bavard.GE.2) WRITE(numout,*) 'Leaving derive_biomass_quantities'
+
+ END SUBROUTINE derive_biomass_quantities
+
+
+END MODULE stomate_stand_structure
+
+
+
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_turnover.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_turnover.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_turnover.f90	(revision 7236)
@@ -0,0 +1,2470 @@
+! =================================================================================================================================
+! MODULE       : stomate_turnover.f90
+!
+! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      : IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        This module manages the end of the growing season and calculates herbivory 
+!               and turnover of leaves, fruits, fine roots.
+!! 
+!!\n DESCRIPTION: This subroutine calculates leaf senescence due to climatic conditions or 
+!! as a function of leaf age and new LAI, and subsequent turnover of the different plant 
+!! biomass compartments (sections 1 to 6), herbivory (section 7), fruit turnover for trees 
+!! (section 8) and sapwood conversion (section 9). 
+!!
+!! RECENT CHANGE(S): None
+!!
+!! SVN          :
+!! $HeadURL$
+!! $Date$
+!! $Revision$
+!! \n
+!_ ================================================================================================================================
+
+MODULE stomate_turnover
+
+  ! modules used:gg
+  USE xios_orchidee
+  USE ioipsl_para
+  USE stomate_data
+  USE constantes
+  USE pft_parameters
+  USE sapiens_agriculture, ONLY: crop_harvest
+  USE function_library, ONLY : biomass_to_lai
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC turnover_diagnostic, turnover_prognostic, turnover_clear
+
+  LOGICAL, SAVE                          :: firstcall = .TRUE.           !! first call (true/false)
+!$OMP THREADPRIVATE(firstcall)
+
+CONTAINS
+
+
+!! ================================================================================================================================
+!! SUBROUTINE   : turnover_clear
+!!
+!>\BRIEF        Set flag ::firstcall to .TRUE., and therefore activate section 1 
+!!              of subroutine turn which writes a message to the output.
+!!                
+!_ ================================================================================================================================
+
+  SUBROUTINE turnover_clear
+    firstcall=.TRUE.
+  END SUBROUTINE turnover_clear
+
+
+!! ================================================================================================================================
+!! SUBROUTINE    : turn
+!!
+!>\BRIEF         Calculate turnover of leaves, roots, fruits and sapwood due to aging or climatic 
+!!               induced senescence. Calculate herbivory.
+!!
+!! DESCRIPTION : This subroutine determines the turnover of leaves and fine roots (and stems for grasses)
+!! and simulates following processes:
+!! 1. Mean leaf age is calculated from leaf ages of separate leaf age classes. Should actually 
+!!    be recalculated at the end of the routine, but it does not change too fast. The mean leaf 
+!!    age is calculated using the following equation:
+!!    \latexonly
+!!    \input{turnover_lma_update_eqn1.tex}
+!!    \endlatexonly
+!!    \n 
+!! 2. Meteorological senescence: the detection of the end of the growing season and shedding 
+!!    of leaves, fruits and fine roots due to unfavourable meteorological conditions.
+!!    The model distinguishes three different types of "climatic" leaf senescence, that do not 
+!!    change the age structure: sensitivity to cold temperatures, to lack of water, or both. 
+!!    If meteorological conditions are fulfilled, a flag ::senescence is set to TRUE. Note
+!!    that evergreen species do not experience climatic senescence.
+!!    Climatic senescence is triggered by sensitivity to cold temperatures where the critical 
+!!    temperature for senescence is calculated using the following equation:
+!!    \latexonly
+!!    \input{turnover_temp_crit_eqn2.tex}
+!!    \endlatexonly
+!!    \n
+!!    Climatic senescence is triggered by sensitivity to lack of water availability where the 
+!!    moisture availability critical level is calculated using the following equation:
+!!    \latexonly
+!!    \input{turnover_moist_crit_eqn3.tex}
+!!    \endlatexonly
+!!    \n
+!!    Climatic senescence is triggered by sensitivity to temperature or to lack of water where
+!!    critical temperature and moisture availability are calculated as above.\n
+!!    Trees in climatic senescence lose their fine roots at the same rate as they lose their leaves. 
+!!    The rate of biomass loss of both fine roots and leaves is presribed through the equation:
+!!    \latexonly
+!!    \input{turnover_clim_senes_biomass_eqn4.tex}
+!!    \endlatexonly
+!!    \n
+!!    with ::leaffall(j) a PFT-dependent time constant which is given in 
+!!    ::stomate_constants. In grasses, leaf senescence is extended to the whole plant 
+!!    (all carbon pools) except to its carbohydrate reserve.    
+!! 3. Senescence due to aging: the loss of leaves, fruits and  biomass due to aging
+!!    At a certain age, leaves fall off, even if the climate would allow a green plant
+!!    all year round. Even if the meteorological conditions are favorable for leaf maintenance,
+!!    plants, and in particular, evergreen trees, have to renew their leaves simply because the 
+!!    old leaves become inefficient. Roots, fruits (and stems for grasses) follow leaves. 
+!!    The ??senescence?? rate varies with leaf age. Note that plant is not declared senescent 
+!!    in this case (wchich is important for allocation: if the plant loses leaves because of 
+!!    their age, it can renew them). The leaf turnover rate due to aging of leaves is calculated
+!!    using the following equation:
+!!    \latexonly
+!!    \input{turnover_age_senes_biomass_eqn5.tex}
+!!    \endlatexonly
+!!    \n
+!!    Drop all leaves if there is a very low leaf mass during senescence. After this, the biomass 
+!!    of different carbon pools both for trees and grasses is set to zero and the mean leaf age 
+!!    is reset to zero. Finally, the leaf fraction and leaf age of the different leaf age classes 
+!!    is set to zero. For deciduous trees: next to leaves, also fruits and fine roots are dropped.
+!!    For grasses: all aboveground carbon pools, except the carbohydrate reserves are affected:
+!! 4. Update the leaf biomass, leaf age class fraction and the LAI
+!!    Older leaves will fall more frequently than younger leaves and therefore the leaf age 
+!!    distribution needs to be recalculated after turnover. The fraction of biomass in each 
+!!    leaf class is updated using the following equation:
+!!    \latexonly
+!!    \input{turnover_update_LeafAgeDistribution_eqn6.tex}
+!!    \endlatexonly
+!!    \n
+!! 5. Simulate herbivory activity and update leaf and fruits biomass. Herbivore activity 
+!!    affects the biomass of leaves and fruits as well as stalks (only for grasses).
+!!    However, herbivores do not modify leaf age structure.
+!! 6. Calculates fruit turnover for trees. Trees simply lose their fruits with a time 
+!!    constant ::tau_fruit(j), that is set to 90 days for all PFTs in ::stomate_constants 
+!! 7. Convert sapwood to heartwood for trees and update heart and softwood above and 
+!!    belowground biomass. Sapwood biomass is converted into heartwood biomass 
+!!    with a time constant tau ::tau_sap(j) of 1 year. Note that this biomass conversion 
+!!    is not added to "turnover" as the biomass is not lost. For the updated heartwood, 
+!!    the sum of new heartwood above and new heartwood below after converting sapwood to 
+!!    heartwood, is saved as ::hw_new(:). Creation of new heartwood decreases the age of 
+!!    the plant ??carbon?? with a factor that is determined by: old heartwood ::hw_old(:) 
+!!    divided by the new heartwood ::hw_new(:)
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLES: ::Biomass of leaves, fruits, fine roots and sapwood above (latter for grasses only), 
+!!                        ::Update LAI, ::Update leaf age distribution with new leaf age class fraction 
+!!
+!! REFERENCE(S) : 
+!! - Krinner, G., N. Viovy, N. de Noblet-Ducoudre, J. Ogee, J. Polcher, P. 
+!! Friedlingstein, P. Ciais, S. Sitch and I.C. Prentice (2005), A dynamic global
+!! vegetation model for studies of the coupled atmosphere-biosphere system, Global
+!! Biogeochemical Cycles, 19, doi:10.1029/2003GB002199. 
+!! - McNaughton, S. J., M. Oesterheld, D. A. Frank and K. J. Williams (1989), 
+!! Ecosystem-level patterns of primary productivity and herbivory in terrestrial habitats, 
+!! Nature, 341, 142-144, 1989. 
+!! - Sitch, S., C. Huntingford, N. Gedney, P. E. Levy, M. Lomas, S. L. Piao, , Betts, R., Ciais, P., Cox, P., 
+!! Friedlingstein, P., Jones, C. D., Prentice, I. C. and F. I. Woodward : Evaluation of the terrestrial carbon  
+!! cycle, future plant geography and climate-carbon cycle feedbacks using 5 dynamic global vegetation 
+!! models (dgvms), Global Change Biology, 14(9), 2015â2039, 2008. 
+!!
+!! FLOWCHART    : 
+!! \latexonly
+!! \includegraphics[scale=0.5]{turnover_flowchart_1.png}
+!! \includegraphics[scale=0.5]{turnover_flowchart_2.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE turnover_diagnostic (npts, dt, PFTpresent, herbivores, maxmoiavail_lastyear, &
+       minmoiavail_lastyear, moiavail_week, moiavail_month, tlong_ref, t2m_month, &
+       t2m_week, veget_max, gdd_from_growthinit, leaf_age, leaf_frac, & 
+       age, lai, biomass, turnover, senescence, &
+       turnover_time, forest_managed)
+
+    !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables 
+
+    INTEGER(i_std), INTENT(in)                                 :: npts                 !! Domain size - number of grid cells 
+                                                                                       !! (unitless)
+    INTEGER(i_std), DIMENSION (npts,nvm), INTENT(in)           :: forest_managed       !! forest management flag 
+    REAL(r_std), INTENT(in)                                    :: dt                   !! time step (dt_days)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                   :: PFTpresent           !! PFT exists (true/false)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                   :: tlong_ref            !! "long term" 2 meter reference 
+                                                                                       !! temperatures (K) 
+    REAL(r_std), DIMENSION(npts), INTENT(in)                   :: t2m_month            !! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                   :: t2m_week             !! "weekly" 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: herbivores           !! time constant of probability of a leaf to 
+                                                                                       !! be eaten by a herbivore (days) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: maxmoiavail_lastyear !! last year's maximum moisture availability 
+                                                                                       !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: minmoiavail_lastyear !! last year's minimum moisture availability 
+                                                                                       !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: moiavail_week        !! "weekly" moisture availability 
+                                                                                       !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: moiavail_month       !! "monthly" moisture availability 
+                                                                                       !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: veget_max            !! "maximal" coverage fraction of a PFT (LAI 
+                                                                                       !! -> infinity) on ground (unitless) 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: gdd_from_growthinit  !! gdd senescence for crop
+
+    !! 0.2 Output variables
+
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), INTENT(out) :: turnover         !! Turnover @tex ($gC m^{-2}$) @endtex
+    LOGICAL, DIMENSION(npts,nvm), INTENT(out)                  :: senescence           !! is the plant senescent? (true/false) 
+                                                                                       !! (interesting only for deciduous trees: 
+                                                                                       !! carbohydrate reserve) 
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_age             !! age of the leaves (days)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_frac            !! fraction of leaves in leaf age class 
+                                                                                       !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: age                  !! age (years)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: lai                  !! leaf area index @tex ($m^2 m^{-2}$) 
+                                                                                       !! @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)     :: turnover_time        !! turnover_time of grasses (days) 
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements), &
+                                                 INTENT(inout) :: biomass              !! biomass @tex ($gC m^{-2}$) @endtex
+
+    !! 0.4 Local  variables
+
+    REAL(r_std), DIMENSION(npts,nvm)                           :: leaf_meanage         !! mean age of the leaves (days)
+    REAL(r_std), DIMENSION(npts)                               :: dturnover            !! Intermediate variable for turnover ??
+                                                                                       !! @tex ($gC m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION(npts)                               :: moiavail_crit        !! critical moisture availability, function 
+                                                                                       !! of last year's moisture availability 
+                                                                                       !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                               :: tl                   !! long term annual mean temperature, (C)
+    REAL(r_std), DIMENSION(npts)                               :: t_crit               !! critical senescence temperature, function 
+                                                                                       !! of long term annual temperature (K) 
+    LOGICAL, DIMENSION(npts)                                   :: shed_rest            !! shed the remaining leaves? (true/false)
+    REAL(r_std), DIMENSION(npts)                               :: sapconv              !! Sapwood conversion @tex ($gC m^{-2}$) 
+                                                                                       !! @endtex 
+    REAL(r_std), DIMENSION(npts)                               :: hw_old               !! old heartwood mass @tex ($gC m^{-2}$) 
+                                                                                       !! @endtex 
+    REAL(r_std), DIMENSION(npts)                               :: hw_new               !! new heartwood mass @tex ($gC m^{-2}$) 
+                                                                                       !! @endtex 
+    REAL(r_std), DIMENSION(npts)                               :: lm_old               !! old leaf mass @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(npts,nleafages)                     :: delta_lm             !! leaf mass change for each age class @tex 
+                                                                                       !! ($gC m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION(npts)                               :: turnover_rate        !! turnover rate (unitless) 
+    REAL(r_std), DIMENSION(npts,nvm)                           :: leaf_age_crit        !! critical leaf age (days)
+    REAL(r_std), DIMENSION(npts,nvm)                           :: new_turnover_time    !! instantaneous turnover time (days)
+    INTEGER(i_std)                                             :: j,m,k                !! Index (unitless)
+    REAL(r_std)                                                :: branch_turn          !! turnover of branches (how much goes 
+                                                                                       !! to litter each day) (cf article CO2fix)
+    REAL(r_std), SAVE                                          :: ss_branch_turn       !! Variations for sensitivity analysis
+!$OMP THREADPRIVATE(ss_branch_turn)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements)          :: bm_old               !! old root mass
+    REAL(r_std), DIMENSION(npts,nvm)                           :: sapwood_age          !! sapwood age (days)
+    REAL(r_std), DIMENSION(npts)                               :: sw_old               !! old sapwood mass 
+                                                                                       !! (gC/(m**2 of nat/agri ground))
+    REAL(r_std), DIMENSION(npts)                               :: sw_new               !! new sapwood mass 
+                                                                                       !! (gC/(m**2 of nat/agri ground))
+    INTEGER(i_std), SAVE                                       :: turn_count           !!  
+!$OMP THREADPRIVATE(turn_count)
+!_ ================================================================================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering turnover'
+
+    !! 1. first call - output messages
+
+    IF ( firstcall ) THEN
+
+       WRITE(numout,*) 'turnover:'
+
+       WRITE(numout,*) ' > minimum mean leaf age for senescence (days) (::min_leaf_age_for_senescence) : '&
+            ,min_leaf_age_for_senescence
+
+       turn_count = 0
+
+       !Config Key   = SS_BRANCH_TURN
+       !Config Desc  = 
+       !Config If    = 
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+       !!!!!!!! needs a default value
+       ss_branch_turn=un
+       CALL getin_p  ('SS_BRANCH_TURN',ss_branch_turn)
+
+       firstcall = .FALSE.
+
+
+    ENDIF
+
+    !! 2. Initializations 
+
+    !! 2.1 set output to zero
+    turnover(:,:,:,:) = zero
+    new_turnover_time(:,:) = zero
+    senescence(:,:) = .FALSE.
+    sapwood_age(:,:)=un
+
+    ! save old biomass
+    bm_old(:,:,:,:) = biomass(:,:,:,:)
+    ! Compute the turnover of branches 
+    ! (2.5% per year : Orchidee standard, Masera 2003, Lehtonen 2004, DeAngelis 1981)
+    branch_turn = 0.025/(one_year/dt)*ss_branch_turn
+
+    !! 2.2 Recalculate mean leaf age
+    !      Mean leaf age is recalculated from leaf ages of separate leaf age classes. Should actually be recalculated at the 
+    !      end of this routine, but it does not change too fast.
+    !      The mean leaf age is calculated using the following equation:
+    !      \latexonly
+    !      \input{turnover_lma_update_eqn1.tex}
+    !      \endlatexonly
+    !      \n
+    leaf_meanage(:,:) = zero
+
+    DO m = 1, nleafages
+       leaf_meanage(:,:) = leaf_meanage(:,:) + leaf_age(:,:,m) * leaf_frac(:,:,m)
+    ENDDO
+    
+
+    IF (ld_trnov) THEN
+       WRITE(numout,*) 'leaf_meanage in turnover', leaf_meanage(:,test_pft)
+       WRITE(numout,*) 'leaf_age in turnover', leaf_age(:,test_pft,:)
+       WRITE(numout,*) 'leaf_frac in turnover', leaf_frac(:,test_pft,:)
+    ENDIF
+   
+    CALL histwrite_p (hist_id_stomate, 'LEAFAGE', itime, &
+           leaf_meanage, npts*nvm, horipft_index)
+   
+
+    !! 3. Climatic senescence
+
+    !     Three different types of "climatic" leaf senescence,
+    !     that do not change the age structure. 
+    DO j = 2,nvm ! Loop over # PFTs
+
+       !! 3.1 Determine if there is climatic senescence. 
+       !      The climatic senescence can be of three types:
+       !      sensitivity to cold temperatures, to lack of water, or both. If meteorological conditions are 
+       !      fulfilled, a flag senescence is set to TRUE.
+       !      Evergreen species do not experience climatic senescence.
+
+       SELECT CASE ( senescence_type(j) )
+
+
+       CASE ('crop' )!for crop senescence is based on a GDD criterium as in crop models
+          WHERE ( ( biomass(:,j,ileaf,icarbon) .GT. zero ) .AND. &
+               ( leaf_meanage(:,j) .GT. min_leaf_age_for_senescence(j) ) .AND. &
+               ( gdd_from_growthinit(:,j) .GT.  gdd_senescence(j)))
+             senescence(:,j) = .TRUE.
+          ENDWHERE
+
+       CASE ( 'cold' )
+
+          !! 3.1.1 Summergreen species: Climatic senescence is triggered by sensitivity to cold temperatures
+          !        Climatic senescence is triggered by sensitivity to cold temperatures as follows: 
+          !        If biomass is large enough (i.e. when it is greater than zero), 
+          !        AND (i.e. when leaf mean age is above a certain PFT-dependent treshold ::min_leaf_age_for_senescence,
+          !        which is given in ::stomate_constants),      
+          !        AND the monthly temperature is low enough (i.e. when monthly temperature ::t2m_month(:) is below a critical 
+          !        temperature ::t_crit(:), which is calculated in this module),
+          !        AND the temperature tendency is negative (i.e. when weekly temperatures ::t2m_week(:) are lower than monthly 
+          !        temperatures ::t2m_month(:))
+          !        If these conditions are met, senescence is set to TRUE.
+          !
+          !        The critical temperature for senescence is calculated using the following equation:
+          !        \latexonly
+          !        \input{turnover_temp_crit_eqn2.tex}
+          !        \endlatexonly
+          !        \n
+          !
+          ! Critical temperature for senescence may depend on long term annual mean temperature
+          tl(:) = tlong_ref(:) - ZeroCelsius
+          t_crit(:) = ZeroCelsius + senescence_temp(j,1) + &
+               tl(:) * senescence_temp(j,2) + &
+               tl(:)*tl(:) * senescence_temp(j,3)
+
+          WHERE ( ( biomass(:,j,ileaf,icarbon) .GT. zero ) .AND. &
+               ( leaf_meanage(:,j) .GT. 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: Climatic senescence is triggered by sensitivity to lack of water availability 
+          !        Climatic senescence is triggered by sensitivity to lack of water availability as follows:  
+          !        If biomass is large enough (i.e. when it is greater than zero), 
+          !        AND (i.e. when leaf mean age is above a certain PFT-dependent treshold ::min_leaf_age_for_senescence,
+          !        which is given in ::stomate_constants),      
+          !        AND the moisture availability drops below a critical level (i.e. when weekly moisture availability 
+          !        ::moiavail_week(:,j) is below a critical moisture availability ::moiavail_crit(:),
+          !        which is calculated in this module), 
+          !        If these conditions are met, senescence is set to TRUE.
+          !
+          !        The moisture availability critical level is calculated using the following equation:
+          !        \latexonly
+          !        \input{turnover_moist_crit_eqn3.tex}
+          !        \endlatexonly
+          !        \n
+          moiavail_crit(:) = &
+               MIN( MAX( minmoiavail_lastyear(:,j) + hum_frac(j) * &
+               ( maxmoiavail_lastyear(:,j) - minmoiavail_lastyear(:,j) ), &
+               senescence_hum(j) ), &
+               nosenescence_hum(j) )
+
+          WHERE ( ( biomass(:,j,ileaf,icarbon) .GT. zero ) .AND. &
+               ( leaf_meanage(:,j) .GT. min_leaf_age_for_senescence(j) ) .AND. &
+               ( moiavail_week(:,j) .LT. moiavail_crit(:) ) )
+
+             senescence(:,j) = .TRUE.
+
+          ENDWHERE
+
+       CASE ( 'mixed' )
+
+          !! 3.1.3 Mixed criterion: Climatic senescence is triggered by sensitivity to temperature or to lack of water  
+          !        Climatic senescence is triggered by sensitivity to temperature or to lack of water availability as follows:
+          !        If biomass is large enough (i.e. when it is greater than zero), 
+          !        AND (i.e. when leaf mean age is above a certain PFT-dependent treshold ::min_leaf_age_for_senescence,
+          !        which is given in ::stomate_constants),      
+          !        AND the moisture availability drops below a critical level (i.e. when weekly moisture availability 
+          !        ::moiavail_week(:,j) is below a critical moisture availability ::moiavail_crit(:), calculated in this module), 
+          !        OR 
+          !        the monthly temperature is low enough (i.e. when monthly temperature ::t2m_month(:) is below a critical 
+          !        temperature ::t_crit(:), calculated in this module),
+          !        AND the temperature tendency is negative (i.e. when weekly temperatures ::t2m_week(:) are lower than 
+          !        monthly temperatures ::t2m_month(:)).
+          !        If these conditions are met, senescence is set to TRUE.
+          moiavail_crit(:) = &
+               MIN( MAX( minmoiavail_lastyear(:,j) + hum_frac(j) * &
+               (maxmoiavail_lastyear(:,j) - minmoiavail_lastyear(:,j) ), &
+               senescence_hum(j) ), &
+               nosenescence_hum(j) )
+
+          tl(:) = tlong_ref(:) - ZeroCelsius
+          t_crit(:) = ZeroCelsius + senescence_temp(j,1) + &
+               tl(:) * senescence_temp(j,2) + &
+               tl(:)*tl(:) * senescence_temp(j,3)
+
+          IF ( is_tree(j) ) THEN
+             ! critical temperature for senescence may depend on long term annual mean temperature
+             WHERE ( ( biomass(:,j,ileaf,icarbon) .GT. zero ) .AND. &
+                  ( leaf_meanage(:,j) .GT. 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
+             
+             ! The nparts dimension was introduced for the prognstic part. Use dimension 1 so that
+             ! no new variable needs to be defined
+             turnover_time(:,j,1) = max_turnover_time(j)
+             
+             WHERE ( ( biomass(:,j,ileaf,icarbon) .GT. zero ) .AND. &
+                  ( leaf_meanage(:,j) .GT. min_leaf_age_for_senescence(j) ) .AND. &
+                  ( ( moiavail_week(:,j) .LT. moiavail_crit(:) )))
+                turnover_time(:,j,1) = max_turnover_time(j) * &
+                     (1.-   (1.- (moiavail_week(:,j)/  moiavail_crit(:)))**2)
+             ENDWHERE
+             
+             WHERE ( turnover_time(:,j,1) .LT. min_turnover_time(j) )
+                turnover_time(:,j,1) = min_turnover_time(j)
+             ENDWHERE
+             
+             WHERE ((( biomass(:,j,ileaf,icarbon) .GT. zero ) .AND. &
+                  ( leaf_meanage(:,j) .GT. min_leaf_age_for_senescence(j) ) .AND. &
+                  ((t2m_month(:) .LT. t_crit(:)) .AND. (lai(:,j) .GT. lai_max(j)/4.) .OR. &
+                  (t2m_month(:) .LT. ZeroCelsius)) .AND. ( t2m_week(:) .LT. t2m_month(:) )))
+                turnover_time(:,j,1)= leaffall(j) 
+             ENDWHERE
+             
+          ENDIF
+
+
+       !! Evergreen species do not experience climatic senescence
+       CASE ( 'none' )
+
+          
+       !! In case no climatic senescence type is recognized.
+       CASE default
+
+          WRITE(numout,*) '  turnover: don''t know how to treat this PFT.'
+          WRITE(numout,*) '  number (::j) : ',j
+          WRITE(numout,*) '  senescence type (::senescence_type(j)) : ',senescence_type(j)
+
+          STOP
+
+       END SELECT
+
+       !! 3.2 Drop leaves and roots, plus stems and fruits for grasses
+
+       IF ( is_tree(j) ) THEN
+
+          !! 3.2.1 Trees in climatic senescence lose their fine roots at the same rate as they lose their leaves. 
+          !        The rate of biomass loss of both fine roots and leaves is presribed through the equation:
+          !        \latexonly
+          !        \input{turnover_clim_senes_biomass_eqn4.tex}
+          !        \endlatexonly
+          !        \n
+          !         with ::leaffall(j) a PFT-dependent time constant which is given in ::stomate_constants),
+          WHERE ( senescence(:,j) )
+
+             turnover(:,j,ileaf,icarbon) = biomass(:,j,ileaf,icarbon) * dt / leaffall(j)
+             turnover(:,j,iroot,icarbon) = biomass(:,j,iroot,icarbon) * dt / leaffall(j)
+
+          ENDWHERE
+
+       ELSE
+
+          !! 3.2.2 In grasses, leaf senescence is extended to the whole plant 
+          !        In grasses, leaf senescence is extended to the whole plant (all carbon pools) except to its
+          !        carbohydrate reserve.      
+
+          IF (senescence_type(j) .EQ. 'crop') THEN
+             ! 3.2.2.1 crops with 'crop' phenological model
+             WHERE ( senescence(:,j) )
+                turnover(:,j,ileaf,icarbon) = biomass(:,j,ileaf,icarbon) * dt / leaffall(j)
+                turnover(:,j,iroot,icarbon) = biomass(:,j,iroot,icarbon) * dt / leaffall(j)
+                turnover(:,j,isapabove,icarbon) = biomass(:,j,isapabove,icarbon) * dt / leaffall(j)
+                turnover(:,j,ifruit,icarbon) = biomass(:,j,ifruit,icarbon) * dt /leaffall(j)
+             ENDWHERE
+          ELSE
+
+             ! 3.2.2.2 grass or crops based on 'mixed' phenological model
+             WHERE (turnover_time(:,j,1) .LT. max_turnover_time(j)) 
+                turnover(:,j,ileaf,icarbon) = biomass(:,j,ileaf,icarbon) * dt / turnover_time(:,j,1)
+                turnover(:,j,isapabove,icarbon) = biomass(:,j,isapabove,icarbon) * dt / turnover_time(:,j,1)
+                turnover(:,j,iroot,icarbon) = biomass(:,j,iroot,icarbon) * dt / turnover_time(:,j,1) 
+                turnover(:,j,ifruit,icarbon) = biomass(:,j,ifruit,icarbon) * dt / turnover_time(:,j,1)
+             ENDWHERE
+          ENDIF
+       ENDIF      ! tree/grass
+
+       biomass(:,j,ileaf,icarbon) = biomass(:,j,ileaf,icarbon) - turnover(:,j,ileaf,icarbon)
+       biomass(:,j,isapabove,icarbon) = biomass(:,j,isapabove,icarbon) - turnover(:,j,isapabove,icarbon)
+       biomass(:,j,iroot,icarbon) = biomass(:,j,iroot,icarbon) - turnover(:,j,iroot,icarbon)
+       biomass(:,j,ifruit,icarbon) = biomass(:,j,ifruit,icarbon) - turnover(:,j,ifruit,icarbon)
+
+    ENDDO        ! loop over PFTs
+
+    !! 4. Leaf fall
+    !     At a certain age, leaves fall off, even if the climate would allow a green plant
+    !     all year round. Even if the meteorological conditions are favorable for leaf maintenance,
+    !     plants, and in particular, evergreen trees, have to renew their leaves simply because the 
+    !     old leaves become inefficient.   
+    !     Roots, fruits (and stems) follow leaves. The decay rate varies with leaf age.
+    !     Note that plant is not declared senescent in this case (wchich is important for allocation:
+    !     if the plant loses leaves because of their age, it can renew them).
+    !
+    !     The leaf turnover rate due to aging of leaves is calculated using the following equation:
+    !     \latexonly
+    !     \input{turnover_age_senes_biomass_eqn5.tex}
+    !     \endlatexonly
+    !     \n
+    DO j = 2,nvm ! Loop over # PFTs
+
+       !! save old leaf mass
+       lm_old(:) = biomass(:,j,ileaf,icarbon)
+
+       !! initialize leaf mass change in age class
+       delta_lm(:,:) = zero
+
+       IF ( is_tree(j) .OR. (.NOT. natural(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) = tau_leaf(j)
+
+       ELSE
+
+          !! 4.2 Grasses: leaves, roots, fruits, sap follow leaves.
+
+          !! 4.2.1 Critical leaf age depends on long-term temperature
+          !        Critical leaf age depends on long-term temperature
+          !        generally, lower turnover in cooler climates.
+          leaf_age_crit(:,j) = &
+               MIN( tau_leaf(j) * leaf_age_crit_coeff(1) , &
+               MAX( tau_leaf(j) * leaf_age_crit_coeff(2) , &
+               tau_leaf(j) - leaf_age_crit_coeff(3) * &
+               ( tlong_ref(:)-ZeroCelsius - leaf_age_crit_tref ) ) )
+
+       END IF
+          
+       ! 4.2.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) )**quatre ) )
+
+          ENDWHERE
+          
+          dturnover(:) = biomass(:,j,ileaf,icarbon) * leaf_frac(:,j,m) * turnover_rate(:)
+          turnover(:,j,ileaf,icarbon) = turnover(:,j,ileaf,icarbon) + dturnover(:)
+          biomass(:,j,ileaf,icarbon) = biomass(:,j,ileaf,icarbon) - dturnover(:)
+
+          ! save leaf mass change
+          delta_lm(:,m) = - dturnover(:)
+          
+          dturnover(:) = biomass(:,j,iroot,icarbon) * leaf_frac(:,j,m) * turnover_rate(:)
+          turnover(:,j,iroot,icarbon) = turnover(:,j,iroot,icarbon) + dturnover(:)
+          biomass(:,j,iroot,icarbon) = biomass(:,j,iroot,icarbon) - dturnover(:)
+          
+          dturnover(:) = biomass(:,j,ifruit,icarbon) * leaf_frac(:,j,m) * turnover_rate(:)
+          turnover(:,j,ifruit,icarbon) = turnover(:,j,ifruit,icarbon) + dturnover(:)
+          biomass(:,j,ifruit,icarbon) = biomass(:,j,ifruit,icarbon) - dturnover(:)
+          
+          IF (.NOT. is_tree(j)) THEN
+             dturnover(:) = biomass(:,j,isapabove,icarbon) * leaf_frac(:,j,m) * turnover_rate(:)
+             turnover(:,j,isapabove,icarbon) = turnover(:,j,isapabove,icarbon) + dturnover(:)
+             biomass(:,j,isapabove,icarbon) = biomass(:,j,isapabove,icarbon) - dturnover(:)
+          ENDIF
+          
+       ENDDO
+
+       
+
+       !! 4.3 Recalculate the fraction of leaf biomass in each leaf age class.
+       !      Older leaves will fall more fast than younger leaves and therefore 
+       !      the leaf age distribution needs to be recalculated after turnover. 
+       !      The fraction of biomass in each leaf class is updated using the following equation:
+       !      \latexonly
+       !      \input{turnover_update_LeafAgeDistribution_eqn6.tex}
+       !      \endlatexonly
+       !      \n
+       !
+       !      new fraction = new leaf mass of that fraction / new total leaf mass
+       !                   = (old fraction*old total leaf mass ::lm_old(:) + biomass change of that fraction ::delta_lm(:,m)  ) /
+       !                     new total leaf mass ::biomass(:,j,ileaf
+       DO m = 1, nleafages
+          
+          WHERE ( biomass(:,j,ileaf,icarbon) .GT. zero )
+
+             leaf_frac(:,j,m) = ( leaf_frac(:,j,m)*lm_old(:) + delta_lm(:,m) ) / biomass(:,j,ileaf,icarbon)
+
+          ELSEWHERE
+
+             leaf_frac(:,j,m) = zero
+
+          ENDWHERE
+        
+       ENDDO
+       
+    ENDDO         ! loop over PFTs
+
+    !! 5. New (provisional) LAI 
+    !     ::lai(:,j) is determined from the leaf biomass ::biomass(:,j,ileaf,icarbon) and the 
+    !     specific leaf surface :: sla(j) (m^2 gC^{-1})
+    !     The leaf area index is updated using the following equation:
+    !     \latexonly
+    !     \input{turnover_update_LAI_eqn7.tex}
+    !     \endlatexonly
+    !     \n
+
+    !    lai(:,ibare_sechiba) = zero
+    !    DO j = 2, nvm ! Loop over # PFTs
+    !        lai(:,j) = biomass(:,j,ileaf,icarbon) * sla(j)
+    !    ENDDO
+
+    !! 6. Definitely drop all leaves if there is a very low leaf mass during senescence.
+
+    !     Both for deciduous trees and grasses same conditions are checked:
+    !     If biomass is large enough (i.e. when it is greater than zero), 
+    !     AND when senescence is set to true
+    !     AND the leaf biomass drops below a critical minimum biomass level (i.e. when it is lower than half
+    !     the minimum initial LAI ::lai_initmin(j) divided by the specific leaf area ::sla(j),
+    !     ::lai_initmin(j) is set to 0.3 in stomate_data.f90 and sla is a constant that is set to 0.015366 m2/gC), 
+    !     If these conditions are met, the flag ::shed_rest(:) is set to TRUE.
+    !
+    !     After this, the biomass of different carbon pools both for trees and grasses is set to zero
+    !     and the mean leaf age is reset to zero.
+    !     Finally, the leaf fraction and leaf age of the different leaf age classes is set to zero.
+    DO j = 2,nvm ! Loop over # PFTs
+
+       shed_rest(:) = .FALSE.
+
+       !! 6.1 For deciduous trees: next to leaves, also fruits and fine roots are dropped 
+       !      For deciduous trees: next to leaves, also fruits and fine roots are dropped: fruit ::biomass(:,j,ifruit) 
+       !      and fine root ::biomass(:,j,iroot) carbon pools are set to zero.
+       IF ( is_tree(j) .AND. ( senescence_type(j) .NE. 'none' ) ) THEN
+
+          ! check whether we shed the remaining leaves
+          WHERE ( ( biomass(:,j,ileaf,icarbon) .GT. zero ) .AND. senescence(:,j) .AND. &
+               ( biomass(:,j,ileaf,icarbon) .LT. (lai_initmin(j) / 2.)/sla(j) )             )
+
+             shed_rest(:) = .TRUE.
+
+             turnover(:,j,ileaf,icarbon)  = turnover(:,j,ileaf,icarbon) + biomass(:,j,ileaf,icarbon)
+             turnover(:,j,iroot,icarbon)  = turnover(:,j,iroot,icarbon) + biomass(:,j,iroot,icarbon)
+             turnover(:,j,ifruit,icarbon) = turnover(:,j,ifruit,icarbon) + biomass(:,j,ifruit,icarbon)
+
+             biomass(:,j,ileaf,icarbon)  = zero
+             biomass(:,j,iroot,icarbon)  = zero
+             biomass(:,j,ifruit,icarbon) = zero
+
+             ! reset leaf age
+             leaf_meanage(:,j) = zero
+
+          ENDWHERE
+
+       ENDIF
+
+       !! 6.2 For grasses: all aboveground carbon pools, except the carbohydrate reserves are affected: 
+       !      For grasses: all aboveground carbon pools, except the carbohydrate reserves are affected: 
+       !      fruit ::biomass(:,j,ifruit,icarbon), fine root ::biomass(:,j,iroot,icarbon) and sapwood above 
+       !      ::biomass(:,j,isapabove,icarbon) carbon pools are set to zero. 
+       IF ( .NOT. is_tree(j) ) THEN
+
+          ! Shed the remaining leaves if LAI very low.
+          WHERE ( ( biomass(:,j,ileaf,icarbon) .GT. zero ) .AND. senescence(:,j) .AND. &
+               (  biomass(:,j,ileaf,icarbon) .LT. (lai_initmin(j) / 2.)/sla(j) ))
+
+             shed_rest(:) = .TRUE.
+
+             turnover(:,j,ileaf,icarbon) = turnover(:,j,ileaf,icarbon) + biomass(:,j,ileaf,icarbon)
+             turnover(:,j,isapabove,icarbon) = turnover(:,j,isapabove,icarbon) + biomass(:,j,isapabove,icarbon)
+             turnover(:,j,iroot,icarbon) = turnover(:,j,iroot,icarbon) + biomass(:,j,iroot,icarbon)
+             turnover(:,j,ifruit,icarbon) = turnover(:,j,ifruit,icarbon) + biomass(:,j,ifruit,icarbon)
+
+             biomass(:,j,ileaf,icarbon) = zero
+             biomass(:,j,isapabove,icarbon) = zero
+             biomass(:,j,iroot,icarbon) = zero
+             biomass(:,j,ifruit,icarbon) = zero
+
+             ! reset leaf age
+             leaf_meanage(:,j) = zero
+
+          ENDWHERE
+
+       ENDIF
+
+       !! 6.3 Reset the leaf age structure: the leaf fraction and leaf age of the different leaf age classes is set to zero.
+      
+       DO m = 1, nleafages
+
+          WHERE ( shed_rest(:) )
+
+             leaf_age(:,j,m) = zero
+             leaf_frac(:,j,m) = zero
+
+          ENDWHERE
+
+       ENDDO
+
+
+
+      !! 6.4 drop part of the branches and mortality of smaller trees until average height reaches 10 m 
+      !! (herbivory, water shortage, ...). This "youth mortality" does not affect tree density as young 
+      !! dead trees are immediately replaced.
+      !
+      IF ( control%forest_management ) THEN
+          
+          IF ( is_tree(j) ) THEN
+             
+             WHERE (forest_managed(:,j) > 0)
+
+                ! Drop part of the branches
+                turnover(:,j,isapabove,icarbon) = branch_ratio(j)*branch_turn*biomass(:,j,isapabove,icarbon)
+                turnover(:,j,iheartabove,icarbon) = branch_ratio(j)*branch_turn*biomass(:,j,iheartabove,icarbon)
+                turnover(:,j,isapbelow,icarbon) = branch_ratio(j)*branch_turn*biomass(:,j,isapbelow,icarbon)
+                turnover(:,j,iheartbelow,icarbon) = branch_ratio(j)*branch_turn*biomass(:,j,iheartbelow,icarbon)
+
+                biomass(:,j,isapabove,icarbon) = biomass(:,j,isapabove,icarbon) - turnover(:,j,isapabove,icarbon)
+                biomass(:,j,iheartabove,icarbon) = biomass(:,j,iheartabove,icarbon) - turnover(:,j,iheartabove,icarbon)
+                biomass(:,j,isapbelow,icarbon) = biomass(:,j,isapbelow,icarbon) - turnover(:,j,isapbelow,icarbon)
+                biomass(:,j,iheartbelow,icarbon) = biomass(:,j,iheartbelow,icarbon) - turnover(:,j,iheartbelow,icarbon)
+
+             END WHERE
+
+          END IF
+
+       END IF ! (control%forest_management)
+
+    ENDDO          ! loop over PFTs
+    
+    !! 7. Herbivore activity: elephants, cows, gazelles but no lions.
+ 
+    !     Herbivore activity affects the biomass of leaves and fruits as well 
+    !     as stalks (only for grasses). Herbivore activity does not modify leaf 
+    !     age structure. Herbivores ::herbivores(:,j) is the time constant of 
+    !     probability of a leaf to be eaten by a herbivore, and is calculated in 
+    !     ::stomate_season. following Mc Naughton et al. [1989].
+
+    IF ( control%ok_herbivory ) THEN
+
+       ! If the herbivore activity is allowed (if ::control%ok_herbivory is true, which is set in run.def), 
+       ! remove the amount of biomass consumed by herbivory from the leaf biomass ::biomass(:,j,ileaf,icarbon) and 
+       ! the fruit biomass ::biomass(:,j,ifruit,icarbon).
+       ! The daily amount consumed equals the biomass multiplied by 1 day divided by the time constant ::herbivores(:,j).
+       DO j = 2,nvm ! Loop over # PFTs
+
+          IF ( is_tree(j) ) THEN
+
+             !! For trees: only the leaves and fruit carbon pools are affected
+
+             WHERE (biomass(:,j,ileaf,icarbon) .GT. zero)
+
+                ! added by shilong
+                WHERE (herbivores(:,j).GT. zero)
+
+                   dturnover(:) = biomass(:,j,ileaf,icarbon) * dt / herbivores(:,j)
+                   turnover(:,j,ileaf,icarbon) = turnover(:,j,ileaf,icarbon) + dturnover(:)
+                   biomass(:,j,ileaf,icarbon) = biomass(:,j,ileaf,icarbon) - dturnover(:)
+
+                   dturnover(:) = biomass(:,j,ifruit,icarbon) * dt / herbivores(:,j)
+                   turnover(:,j,ifruit,icarbon) = turnover(:,j,ifruit,icarbon) + dturnover(:)
+                   biomass(:,j,ifruit,icarbon) = biomass(:,j,ifruit,icarbon) - dturnover(:)
+
+                ENDWHERE
+
+             ENDWHERE
+
+          ELSE
+
+             ! For grasses: all aboveground carbon pools are affected: leaves, fruits and sapwood above
+             WHERE ( biomass(:,j,ileaf,icarbon) .GT. zero )
+
+                ! added by shilong
+                WHERE (herbivores(:,j) .GT. zero)
+
+                   dturnover(:) = biomass(:,j,ileaf,icarbon) * dt / herbivores(:,j)
+                   turnover(:,j,ileaf,icarbon) = turnover(:,j,ileaf,icarbon) + dturnover(:)
+                   biomass(:,j,ileaf,icarbon) = biomass(:,j,ileaf,icarbon) - dturnover(:)
+
+                   dturnover(:) = biomass(:,j,isapabove,icarbon) * dt / herbivores(:,j)
+                   turnover(:,j,isapabove,icarbon) = turnover(:,j,isapabove,icarbon) + dturnover(:)
+                   biomass(:,j,isapabove,icarbon) = biomass(:,j,isapabove,icarbon) - dturnover(:)
+
+                   dturnover(:) = biomass(:,j,ifruit,icarbon) * dt / herbivores(:,j)
+                   turnover(:,j,ifruit,icarbon) = turnover(:,j,ifruit,icarbon) + dturnover(:)
+                   biomass(:,j,ifruit,icarbon) = biomass(:,j,ifruit,icarbon) - dturnover(:)
+
+                ENDWHERE
+
+             ENDWHERE
+
+          ENDIF  ! tree/grass?
+
+       ENDDO    ! loop over PFTs
+
+    ENDIF ! end herbivores
+
+    !! 8. Fruit turnover for trees
+
+    !     Fruit turnover for trees: trees simply lose their fruits with a time constant ::tau_fruit(j), 
+    !     that is set to 90 days for all PFTs in ::stomate_constants
+
+    DO k = 1,nelements 
+
+       DO j = 2,nvm ! Loop over # PFTs
+
+          IF ( is_tree(j) ) THEN
+
+             dturnover(:) = biomass(:,j,ifruit,k) * dt / tau_fruit(j)
+             turnover(:,j,ifruit,k) = turnover(:,j,ifruit,k) + dturnover(:)
+             biomass(:,j,ifruit,k) = biomass(:,j,ifruit,k) - dturnover(:)
+             
+          ENDIF
+
+       ENDDO       ! loop over PFTs
+   
+    END DO
+
+    !! 9 Conversion of sapwood to heartwood both for aboveground and belowground sapwood and heartwood.
+
+    !   Following LPJ (Sitch et al., 2003), sapwood biomass is converted into heartwood biomass 
+    !   with a time constant tau ::tau_sap(j) of 1 year.
+    !   Note that this biomass conversion is not added to "turnover" as the biomass is not lost!
+    DO j = 2,nvm ! Loop over # PFTs
+
+       IF ( is_tree(j) ) THEN
+
+          !! For the recalculation of age in 9.2 (in case the vegetation is not dynamic ie. ::control%ok_dgvm is FALSE), 
+          !! the heartwood above and below is stored in ::hw_old(:).
+          IF ( .NOT. control%ok_dgvm ) THEN
+
+             hw_old(:) = biomass(:,j,iheartabove,icarbon) + biomass(:,j,iheartbelow,icarbon)
+             sw_old(:) = biomass(:,j,isapabove,icarbon) + biomass(:,j,isapbelow,icarbon)
+
+          ENDIF
+
+          !! 9.1 Calculate the rate of sapwood to heartwood conversion 
+          !      Calculate the rate of sapwood to heartwood conversion with the time constant ::tau_sap(j) 
+          !      and update aboveground and belowground sapwood ::biomass(:,j,isapabove) and ::biomass(:,j,isapbelow)
+          !      and heartwood ::biomass(:,j,iheartabove) and ::biomass(:,j,iheartbelow).
+
+          DO k = 1,nelements
+
+             ! Above the ground
+             sapconv(:) = biomass(:,j,isapabove,k) * dt / tau_sap(j)
+             biomass(:,j,isapabove,k) = biomass(:,j,isapabove,k) - sapconv(:)
+             biomass(:,j,iheartabove,k) =  biomass(:,j,iheartabove,k) + sapconv(:)
+             
+             ! Below the ground
+             sapconv(:) = biomass(:,j,isapbelow,k) * dt / tau_sap(j)
+             biomass(:,j,isapbelow,k) = biomass(:,j,isapbelow,k) - sapconv(:)
+             biomass(:,j,iheartbelow,k) =  biomass(:,j,iheartbelow,k) + sapconv(:)
+
+          END DO
+
+          !! 9.2 If the vegetation is not dynamic, the age of the plant is decreased. 
+          !      The updated heartwood, the sum of new heartwood above and new heartwood below after 
+          !      converting sapwood to heartwood, is saved as ::hw_new(:) .
+          !      Creation of new heartwood decreases the age of the plant with a factor that is determined by: 
+          !      old heartwood ::hw_old(:) divided by the new heartwood ::hw_new(:)
+          IF ( .NOT. control%ok_dgvm ) THEN
+
+             hw_new(:) = biomass(:,j,iheartabove,icarbon) + biomass(:,j,iheartbelow,icarbon)
+             sw_new(:) = biomass(:,j,isapabove,icarbon) + biomass(:,j,isapbelow,icarbon)
+
+             WHERE ( hw_new(:) .GT. zero )
+
+                age(:,j) = age(:,j) * hw_old(:)/hw_new(:)
+                sapwood_age(:,j) = sapwood_age(:,j) * sw_old(:)/sw_new(:)
+
+             ENDWHERE
+
+          ENDIF
+
+       ENDIF
+
+    ENDDO       ! loop over PFTs
+
+
+    CALL xios_orchidee_send_field("HERBIVORES",herbivores)
+    CALL xios_orchidee_send_field("LEAF_AGE",leaf_meanage)
+    
+
+    ! Write mean leaf age and time constant of probability of a leaf to be eaten by a herbivore 
+    ! to the stomate output file.
+    !CALL histwrite_p (hist_id_stomate, 'LEAFAGE', itime, &
+    !     leaf_meanage, npts*nvm, horipft_index)
+    CALL histwrite_p (hist_id_stomate, 'HERBIVORES', itime, &
+         herbivores, npts*nvm, horipft_index)
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving turnover'
+
+  END SUBROUTINE turnover_diagnostic
+
+
+
+!! ================================================================================================================================
+!! SUBROUTINE    : turnover_prognostic
+!!
+!>\BRIEF         Calculate turnover of leaves, roots, fruits and sapwood due to aging or climatic 
+!!               induced senescence. Calculate herbivory.
+!!
+!! DESCRIPTION : This subroutine determines the turnover of leaves and fine roots (and stems for grasses)
+!! and simulates following processes:
+!! 1. Mean leaf age is calculated from leaf ages of separate leaf age classes. Should actually 
+!!    be recalculated at the end of the routine, but it does not change too fast. The mean leaf 
+!!    age is calculated using the following equation:
+!!    \latexonly
+!!    \input{turnover_lma_update_eqn1.tex}
+!!    \endlatexonly
+!!    \n 
+!! 2. Meteorological senescence: the detection of the end of the growing season and shedding 
+!!    of leaves, fruits and fine roots due to unfavourable meteorological conditions.
+!!    The model distinguishes three different types of "climatic" leaf senescence, that do not 
+!!    change the age structure: sensitivity to cold temperatures, to lack of water, or both. 
+!!    If meteorological conditions are fulfilled, a flag ::senescence is set to TRUE. Note
+!!    that evergreen species do not experience climatic senescence.
+!!    Climatic senescence is triggered by sensitivity to cold temperatures where the critical 
+!!    temperature for senescence is calculated using the following equation:
+!!    \latexonly
+!!    \input{turnover_temp_crit_eqn2.tex}
+!!    \endlatexonly
+!!    \n
+!!    Climatic senescence is triggered by sensitivity to lack of water availability where the 
+!!    moisture availability critical level is calculated using the following equation:
+!!    \latexonly
+!!    \input{turnover_moist_crit_eqn3.tex}
+!!    \endlatexonly
+!!    \n
+!!    Climatic senescence is triggered by sensitivity to temperature or to lack of water where
+!!    critical temperature and moisture availability are calculated as above.\n
+!!    Trees in climatic senescence lose their fine roots at the same rate as they lose their leaves. 
+!!    The rate of biomass loss of both fine roots and leaves is presribed through the equation:
+!!    \latexonly
+!!    \input{turnover_clim_senes_biomass_eqn4.tex}
+!!    \endlatexonly
+!!    \n
+!!    with ::leaffall(j) a PFT-dependent time constant which is given in 
+!!    ::stomate_constants. In grasses, leaf senescence is extended to the whole plant 
+!!    (all carbon pools) except to its carbohydrate reserve.    
+!! 3. Senescence due to aging: the loss of leaves, fruits and  biomass due to aging
+!!    At a certain age, leaves fall off, even if the climate would allow a green plant
+!!    all year round. Even if the meteorological conditions are favorable for leaf maintenance,
+!!    plants, and in particular, evergreen trees, have to renew their leaves simply because the 
+!!    old leaves become inefficient. Roots, fruits (and stems for grasses) follow leaves. 
+!!    The ??senescence?? rate varies with leaf age. Note that plant is not declared senescent 
+!!    in this case (wchich is important for allocation: if the plant loses leaves because of 
+!!    their age, it can renew them). The leaf turnover rate due to aging of leaves is calculated
+!!    using the following equation:
+!!    \latexonly
+!!    \input{turnover_age_senes_biomass_eqn5.tex}
+!!    \endlatexonly
+!!    \n
+!!    Drop all leaves if there is a very low leaf mass during senescence. After this, the biomass 
+!!    of different carbon pools both for trees and grasses is set to zero and the mean leaf age 
+!!    is reset to zero. Finally, the leaf fraction and leaf age of the different leaf age classes 
+!!    is set to zero. For deciduous trees: next to leaves, also fruits and fine roots are dropped.
+!!    For grasses: all aboveground carbon pools, except the carbohydrate reserves are affected:
+!! 4. Update the leaf biomass, leaf age class fraction and the LAI
+!!    Older leaves will fall more frequently than younger leaves and therefore the leaf age 
+!!    distribution needs to be recalculated after turnover. The fraction of biomass in each 
+!!    leaf class is updated using the following equation:
+!!    \latexonly
+!!    \input{turnover_update_LeafAgeDistribution_eqn6.tex}
+!!    \endlatexonly
+!!    \n
+!! 5. Simulate herbivory activity and update leaf and fruits biomass. Herbivore activity 
+!!    affects the biomass of leaves and fruits as well as stalks (only for grasses).
+!!    However, herbivores do not modify leaf age structure.
+!! 6. Calculates fruit turnover for trees. Trees simply lose their fruits with a time 
+!!    constant ::tau_fruit(j), that is set to 90 days for all PFTs in ::stomate_constants 
+!! 7. Convert sapwood to heartwood for trees and update heart and softwood above and 
+!!    belowground biomass. Sapwood biomass is converted into heartwood biomass 
+!!    with a time constant tau ::tau_sap(j) of 1 year. Note that this biomass conversion 
+!!    is not added to "turnover" as the biomass is not lost. For the updated heartwood, 
+!!    the sum of new heartwood above and new heartwood below after converting sapwood to 
+!!    heartwood, is saved as ::hw_new(:). Creation of new heartwood decreases the age of 
+!!    the plant ??carbon?? with a factor that is determined by: old heartwood ::hw_old(:) 
+!!    divided by the new heartwood ::hw_new(:)
+!!
+!! RECENT CHANGE(S) : None
+!!
+!! MAIN OUTPUT VARIABLES: ::Biomass of leaves, fruits, fine roots and sapwood above (latter for grasses only), 
+!!                        ::Update LAI, ::Update leaf age distribution with new leaf age class fraction 
+!!
+!! REFERENCE(S) : 
+!! - Krinner, G., N. Viovy, N. de Noblet-Ducoudre, J. Ogee, J. Polcher, P. 
+!! Friedlingstein, P. Ciais, S. Sitch and I.C. Prentice (2005), A dynamic global
+!! vegetation model for studies of the coupled atmosphere-biosphere system, Global
+!! Biogeochemical Cycles, 19, doi:10.1029/2003GB002199. 
+!! - McNaughton, S. J., M. Oesterheld, D. A. Frank and K. J. Williams (1989), 
+!! Ecosystem-level patterns of primary productivity and herbivory in terrestrial habitats, 
+!! Nature, 341, 142-144, 1989. 
+!! - Sitch, S., C. Huntingford, N. Gedney, P. E. Levy, M. Lomas, S. L. Piao, , Betts, R., Ciais, P., Cox, P., 
+!! Friedlingstein, P., Jones, C. D., Prentice, I. C. and F. I. Woodward : Evaluation of the terrestrial carbon  
+!! cycle, future plant geography and climate-carbon cycle feedbacks using 5 dynamic global vegetation 
+!! models (dgvms), Global Change Biology, 14(9), 2015â2039, 2008. 
+!!
+!! FLOWCHART    : 
+!! \latexonly
+!! \includegraphics[scale=0.5]{turnover_flowchart_1.png}
+!! \includegraphics[scale=0.5]{turnover_flowchart_2.png}
+!! \endlatexonly
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE turnover_prognostic (npts, dt, PFTpresent, herbivores, &
+       maxmoiavail_lastyear, minmoiavail_lastyear, moiavail_week, moiavail_month, &
+       tlong_ref, t2m_longterm, t2m_month, t2m_week, veget_max, &
+       gdd_from_growthinit, leaf_age, leaf_frac, age, &
+       biomass, turnover, senescence, turnover_time, &
+       circ_class_biomass, circ_class_n, ind, allow_initpheno, &
+       when_growthinit, tau_eff_leaf, tau_eff_sap, tau_eff_root, &
+       harvest_pool, harvest_type, harvest_cut, harvest_area, &
+       resolution, wstress_month)
+
+ !! 0. Variable and parameter declaration
+
+    !! 0.1 Input variables 
+
+    INTEGER(i_std), INTENT(in)                       :: npts                 !! Domain size - number of grid cells 
+                                                                             !! (unitless) 
+    REAL(r_std), INTENT(in)                          :: dt                   !! time step (dt_days)
+    LOGICAL, DIMENSION(:,:), INTENT(in)              :: PFTpresent           !! PFT exists (true/false)
+    REAL(r_std),DIMENSION(:,:), INTENT(in)           :: resolution           !! The length in m of each grid-box in X and Y
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: herbivores           !! time constant of probability of a leaf to 
+                                                                             !! be eaten by a herbivore (days) 
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: maxmoiavail_lastyear !! last year's maximum moisture availability 
+                                                                             !! (0-1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: minmoiavail_lastyear !! last year's minimum moisture availability 
+                                                                             !! (0-1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: moiavail_week        !! "weekly" moisture availability 
+                                                                             !! (0-1, unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: moiavail_month       !! "monthly" moisture availability 
+                                                                             !! (0-1, unitless)
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: tlong_ref            !! "long term" 2 meter reference 
+                                                                             !! temperatures (K)
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: t2m_longterm         !! "longterm" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: t2m_month            !! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(:), INTENT(in)            :: t2m_week             !! "weekly" 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: veget_max            !! "maximal" coverage fraction of a PFT (LAI 
+                                                                             !! -> infinity) on ground (unitless) 
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: gdd_from_growthinit  !! gdd senescence for crop
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: when_growthinit      !! How many days ago was the beginning of 
+                                                                             !! the growing season (days) 
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)        :: circ_class_n         !! Number of individuals in each circ class
+                                                                             !! @tex $(m^{-2})$ @endtex
+    LOGICAL, DIMENSION(:,:), INTENT(in)              :: allow_initpheno      !! Are we allowed to declare the 
+                                                                             !! beginning of the growing season?
+                                                                             !! and the end of senescence (true/false) 
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: tau_eff_root         !! Effective root turnover time that accounts
+                                                                             !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: tau_eff_sap          !! Effective sapwood turnover time that accounts
+                                                                             !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: tau_eff_leaf         !! Effective leaf turnover time that accounts
+                                                                             !! waterstress (days)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)          :: wstress_month        !! Water stress factor, based on hum_rel_daily
+                                                                             !! (unitless, 0-1)
+
+
+    !! 0.2 Output variables
+   
+
+    !! 0.3 Modified variables
+
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: leaf_age             !! age of the leaves (days)
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: leaf_frac            !! fraction of leaves in leaf age class 
+                                                                             !! (0-1, unitless)
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: harvest_pool         !! The wood and biomass that have been
+                                                                             !! havested by humans @tex $(gC)$ @endtex
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: harvest_type         !! Type of management that resulted
+                                                                             !! in the harvest (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: harvest_cut          !! Type of cutting that was used for the harvest
+                                                                             !! (unitless)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: harvest_area         !! Harvested area (m^{2})
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: age                  !! age (years)
+    REAL(r_std), DIMENSION(:,:), INTENT(inout)       :: ind                  !! Density of individuals 
+                                                                             !! @tex $(m^{-2})$ @endtex
+    REAL(r_std), DIMENSION(:,:,:), INTENT(inout)     :: turnover_time        !! turnover_time of grasses (days) 
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: biomass              !! biomass @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(:,:,:,:), INTENT(inout)   :: turnover             !! Turnover @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(:,:,:,:,:), INTENT(inout) :: circ_class_biomass   !! Biomass of the componets of the model  
+                                                                             !! tree within a circumference
+                                                                             !! class @tex $(gC ind^{-1})$ @endtex
+    LOGICAL, DIMENSION(:,:), INTENT(inout)           :: senescence           !! is the plant senescent? (true/false) 
+                                                                             !! (interesting only for deciduous trees: 
+                                                                             !! carbohydrate reserve)
+    
+    !! 0.4 Local  variables
+
+    LOGICAL, DIMENSION(npts)                         :: shed_rest            !! shed the remaining leaves? (true/false)
+    INTEGER(i_std)                                   :: ivm,iele,ilage,ipts  !! Index (unitless)
+    INTEGER(i_std)                                   :: ipar,icirc,imbc      !! Index (unitless)
+    INTEGER(i_std), SAVE                             :: turn_count           !!  
+!$OMP THREADPRIVATE(turn_count)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: leaf_meanage         !! mean age of the leaves (days)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: lai                  !! leaf area index @tex ($m^2 m^{-2}$) 
+                                                                             !! @endtex
+    REAL(r_std), DIMENSION(npts)                     :: dturnover            !! Intermediate variable for turnover ??
+                                                                             !! @tex ($gC m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION(npts)                     :: moiavail_crit        !! critical moisture availability, function 
+                                                                             !! of last year's moisture availability 
+                                                                             !! (0-1, unitless)
+    REAL(r_std), DIMENSION(npts)                     :: tl                   !! long term annual mean temperature, (C)
+    REAL(r_std), DIMENSION(npts)                     :: t_crit               !! critical senescence temperature, function 
+                                                                             !! of long term annual temperature (K) 
+    REAL(r_std), DIMENSION(npts)                     :: sapconv              !! Sapwood conversion @tex ($gC m^{-2}$) 
+                                                                             !! @endtex 
+    REAL(r_std), DIMENSION(npts)                     :: hw_old               !! old heartwood mass @tex ($gC m^{-2}$) 
+                                                                             !! @endtex 
+    REAL(r_std), DIMENSION(npts)                     :: hw_new               !! new heartwood mass @tex ($gC m^{-2}$) 
+                                                                             !! @endtex 
+    REAL(r_std), DIMENSION(npts)                     :: lm_old               !! old leaf mass @tex ($gC m^{-2}$) @endtex
+    REAL(r_std), DIMENSION(npts,nleafages)           :: delta_lm             !! leaf mass change for each age class @tex 
+                                                                             !! ($gC m^{-2}$) @endtex 
+    REAL(r_std), DIMENSION(npts)                     :: turnover_rate        !! turnover rate (unitless) 
+    REAL(r_std), DIMENSION(npts,nvm)                 :: leaf_age_crit        !! critical leaf age (days)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: new_turnover_time    !! instantaneous turnover time (days)
+    REAL(r_std), DIMENSION(npts,nvm)                 :: harvest_time         !! Prescribed harvest time adjusted for the
+                                                                             !! longterm temperature at the pixel (days)
+    REAL(r_std)                                      :: branch_turn          !! turnover of branches (how much goes 
+                                                                             !! to litter each day) (cf article CO2fix)
+    REAL(r_std), SAVE                                :: ss_branch_turn       !! Variations for sensitivity analysis
+!$OMP THREADPRIVATE(ss_branch_turn)
+    REAL(r_std), DIMENSION(npts,nvm,nparts,nelements):: bm_old               !! old root mass
+    REAL(r_std), DIMENSION(npts,nvm)                 :: sapwood_age          !! sapwood age (days)
+    REAL(r_std), DIMENSION(npts)                     :: sw_old               !! old sapwood mass 
+                                                                             !! (gC/(m**2 of nat/agri ground))
+    REAL(r_std), DIMENSION(npts)                     :: sw_new               !! new sapwood mass 
+                                                                             !! (gC/(m**2 of nat/agri ground)
+    REAL(r_std), DIMENSION(npts)                     :: pixel_area           !! surface area of the pixel @tex ($m^{2}$) @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nmbcomp,nelements)&
+                                                     :: check_intern         !! Contains the components of the internal
+                                                                             !! mass balance chech for this routine
+                                                                             !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)       :: closure_intern       !! Check closure of internal mass balance
+                                                                             !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    REAL(r_std), DIMENSION(npts,nvm,nelements)       :: pool_start, pool_end !! Start and end pool of this routine 
+                                                                             !! @tex $(gC pixel^{-1} dt^{-1})$ @endtex
+    
+!_ ================================================================================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering prognostic turnover'
+
+ !! 1. first call - output messages
+
+    IF ( firstcall ) THEN
+
+       WRITE(numout,*) 'turnover:'
+
+       WRITE(numout,*) ' > minimum mean leaf age for senescence (days) (::min_leaf_age_for_senescence) : '&
+            ,min_leaf_age_for_senescence
+
+       turn_count = 0
+
+       !Config Key   = SS_BRANCH_TURN
+       !Config Desc  = 
+       !Config If    = 
+       !Config Def   = 
+       !Config Help  = 
+       !Config Units = 
+
+       ! this needs to be initialized, else it crashes in the getin_p call
+       ss_branch_turn=un
+       CALL getin_p  ('SS_BRANCH_TURN',ss_branch_turn)
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+
+ !! 2. Initializations 
+
+    !! 2.1 set output to zero
+    turnover(:,:,:,:) = zero
+    new_turnover_time(:,:) = zero
+    harvest_time(:,:) = zero 
+
+    !! 2.2 Initialize check for mass balance closure
+    !  The mass balance is calculated at the end of this routine
+    !  in section 10.
+    ! turnover is always equal to zero, so maybe that term doesn't need
+    ! to be included here.
+    pool_start = zero
+    DO ipar = 1,nparts
+       DO iele = 1,nelements
+          !  Initial biomass pool
+          pool_start(:,:,iele) = pool_start(:,:,iele) + &
+               (biomass(:,:,ipar,iele) * veget_max(:,:)) + &
+               (turnover(:,:,ipar,iele) * veget_max(:,:))
+       ENDDO
+    ENDDO
+
+    !  Surface area (m2) of the pixel
+    pixel_area(:) = resolution(:,1) * resolution(:,2)
+
+    ! The biomass harvest pool is expressed in gC pixel-1 So, it 
+    ! shouldn't be multiplied by veget_max but it should be divided
+    ! by pixel_area to obtain gC m-2.
+    DO ivm = 1,nvm
+       pool_start(:,ivm,icarbon) = pool_start(:,ivm,icarbon) + &
+            SUM(harvest_pool(:,ivm,:,icarbon),2) / &
+            pixel_area(:)
+    ENDDO
+
+    ! save old biomass
+    bm_old(:,:,:,:) = biomass(:,:,:,:)
+
+    ! Compute the turnover of branches 
+    ! (2.5% per year : Orchidee standard, Masera 2003, Lehtonen 2004, DeAngelis 1981)
+    branch_turn = 0.025/(one_year/dt)*ss_branch_turn
+
+    ! Calculate lai
+    DO ivm = 2,nvm
+       DO ipts=1,npts
+          lai(ipts,ivm) = biomass_to_lai(biomass(ipts,ivm,ileaf,icarbon),ivm)
+       ENDDO
+    ENDDO
+    lai(:,1) = zero
+
+    !! 2.2 Recalculate mean leaf age
+    !  Mean leaf age is recalculated from leaf ages of separate leaf age classes. 
+    !  Leaf age is used as a criterion in several of the following IF/WHERE loops 
+    !  The mean leaf age is calculated using the following equation:
+    !  \latexonly
+    !  \input{turnover_lma_update_eqn1.tex}
+    !  \endlatexonly
+    !  \n
+    leaf_meanage(:,:) = zero
+
+    DO ilage = 1, nleafages
+
+       leaf_meanage(:,:) = leaf_meanage(:,:) + leaf_age(:,:,ilage) * leaf_frac(:,:,ilage)
+
+    ENDDO
+
+ !! 3. Climatic senescence
+
+    ! Three different types of "climatic" leaf senescence,
+    ! that do not change the age structure. 
+    DO ivm = 2,nvm ! Loop over # PFTs
+
+       !! 3.1 Determine if there is climatic senescence. 
+       !  The climatic senescence can be of three types: sensitivity to cold temperatures, 
+       !  to lack of water, or both. If meteorological conditions are fulfilled, a flag 
+       !  senescence is set to TRUE. Evergreen species do not experience climatic senescence.
+       SELECT CASE ( senescence_type(ivm) )
+
+       !! 3.1.1 Crops
+       !  Crop senescence is based on a GDD criterium as in crop models.
+       CASE ('crop' )
+          
+          !+++CHECK+++
+          ! This is pure plumbing under time pressure (says the one who introduced it).     
+          ! Switch senescence to true and it will stay true until begin_leaves becomes true
+          ! A growing season should last about 4 months  where the longterm temperature 
+          ! is 282 K (crude observation from N. France) before senescence can set in unless 
+          ! the growing degrees are reached. In colder and warmer places the growing season
+          ! is shortened or lengthened. Because in warmer places the growing season lasts 
+          ! longer, crop can be planted that required more light.
+          harvest_time(:,ivm) = 130 + 3 * ( t2m_longterm(:) - 282)
+
+          WHERE ( ( biomass(:,ivm,ileaf,icarbon) .GT. zero ) .AND. &
+               ( leaf_meanage(:,ivm) .GT. min_leaf_age_for_senescence(ivm) ) .AND. &
+               ( ( gdd_from_growthinit(:,ivm) .GT. gdd_senescence(ivm) ) .OR. &
+               ( ( when_growthinit(:,ivm) .GT. harvest_time(:,ivm) ) ) ) )
+
+             senescence(:,ivm) = .TRUE.
+
+          ENDWHERE
+          !+++++++++++
+
+
+       !! 3.1.2 Summergreen species
+       !  Climatic senescence is triggered by sensitivity to cold temperatures as follows: 
+       !  If biomass is large enough (i.e. when it is greater than zero), 
+       !  AND (i.e. when leaf mean age is above a certain PFT-dependent treshold ::min_leaf_age_for_senescence,
+       !  which is given in constants),      
+       !  AND the monthly temperature is low enough (i.e. when monthly temperature ::t2m_month(:) is below a critical 
+       !  temperature ::t_crit(:), which is calculated in this module),
+       !  AND the temperature tendency is negative (i.e. when weekly temperatures ::t2m_week(:) are lower than monthly 
+       !  temperatures ::t2m_month(:))
+       !  If these conditions are met, senescence is set to TRUE.
+       !
+       !  The critical temperature for senescence is calculated using the following equation:
+       !  \latexonly
+       !  \input{turnover_temp_crit_eqn2.tex}
+       !  \endlatexonly
+       !  \n
+       !  Critical temperature for senescence may depend on long term annual mean temperature
+       CASE ( 'cold' )
+ 
+          tl(:) = tlong_ref(:) - ZeroCelsius
+          t_crit(:) = ZeroCelsius + senescence_temp(ivm,1) + &
+               tl(:) * senescence_temp(ivm,2) + &
+               tl(:)*tl(:) * senescence_temp(ivm,3)
+
+          WHERE ( ( biomass(:,ivm,ileaf,icarbon) .GT. zero ) .AND. &
+               ( leaf_meanage(:,ivm) .GT. min_leaf_age_for_senescence(ivm) ) .AND. &
+               ( t2m_month(:) .LT. t_crit(:) ) .AND. &
+               ( t2m_week(:) .LT. t2m_month(:) ) )
+
+             senescence(:,ivm) = .TRUE.
+          
+          ENDWHERE
+
+       !! 3.1.3 Raingreen species
+       !  Climatic senescence is triggered by sensitivity to lack of water availability as follows:  
+       !  If biomass is large enough (i.e. when it is greater than zero), 
+       !  AND (i.e. when leaf mean age is above a certain PFT-dependent treshold ::min_leaf_age_for_senescence,
+       !  which is given in ::stomate_constants),      
+       !  AND the moisture availability drops below a critical level (i.e. when weekly moisture availability 
+       !  ::moiavail_week(:,ivm) is below a critical moisture availability ::moiavail_crit(:),
+       !  which is calculated in this module), 
+       !  If these conditions are met, senescence is set to TRUE.
+       !
+       !  The moisture availability critical level is calculated using the following equation:
+       !  \latexonly
+       !  \input{turnover_moist_crit_eqn3.tex}
+       !  \endlatexonly
+       !  \n
+       CASE ( 'dry' )
+
+          moiavail_crit(:) = &
+               MIN( MAX( minmoiavail_lastyear(:,ivm) + hum_frac(ivm) * &
+               ( maxmoiavail_lastyear(:,ivm) - minmoiavail_lastyear(:,ivm) ), &
+               senescence_hum(ivm) ), &
+               nosenescence_hum(ivm) )
+
+          WHERE ( ( biomass(:,ivm,ileaf,icarbon) .GT. zero ) .AND. &
+               ( leaf_meanage(:,ivm) .GT. min_leaf_age_for_senescence(ivm) ) .AND. &
+               ( moiavail_week(:,ivm) .LT. moiavail_crit(:) ) )
+
+             senescence(:,ivm) = .TRUE.
+
+          ENDWHERE
+
+       !! 3.1.4 Mixed criterion: Climatic senescence is triggered by sensitivity to temperature or to lack of water  
+       !  Climatic senescence is triggered by sensitivity to temperature or to lack of water availability as follows:
+       !  If biomass is large enough (i.e. when it is greater than zero), 
+       !  AND (i.e. when leaf mean age is above a certain PFT-dependent treshold ::min_leaf_age_for_senescence,
+       !  which is given in ::stomate_constants),      
+       !  AND the moisture availability drops below a critical level (i.e. when weekly moisture availability 
+       !  ::moiavail_week(:,ivm) is below a critical moisture availability ::moiavail_crit(:), calculated in this module), 
+       !  OR 
+       !  the monthly temperature is low enough (i.e. when monthly temperature ::t2m_month(:) is below a critical 
+       !  temperature ::t_crit(:), calculated in this module),
+       !  AND the temperature tendency is negative (i.e. when weekly temperatures ::t2m_week(:) are lower than 
+       !  monthly temperatures ::t2m_month(:)).
+       !  If these conditions are met, senescence is set to TRUE.
+       CASE ( 'mixed' )
+    
+          moiavail_crit(:) = MIN( MAX( minmoiavail_lastyear(:,ivm) + hum_frac(ivm) * &
+               (maxmoiavail_lastyear(:,ivm) - minmoiavail_lastyear(:,ivm) ), &
+               senescence_hum(ivm) ), nosenescence_hum(ivm) )
+          tl(:) = tlong_ref(:) - ZeroCelsius
+          t_crit(:) = ZeroCelsius + senescence_temp(ivm,1) + &
+               tl(:) * senescence_temp(ivm,2) + &
+               tl(:)*tl(:) * senescence_temp(ivm,3)
+
+          IF ( is_tree(ivm) ) THEN
+
+             ! critical temperature for senescence may depend on long term annual mean temperature
+             WHERE ( ( biomass(:,ivm,ileaf,icarbon) .GT. zero ) .AND. &
+                  ( leaf_meanage(:,ivm) .GT. min_leaf_age_for_senescence(ivm) ) .AND. &
+                  ( ( moiavail_week(:,ivm) .LT. moiavail_crit(:) ) .OR. &
+                  ( ( t2m_month(:) .LT. t_crit(:) ) .AND. ( t2m_week(:) .LT. t2m_month(:) ) ) ) )
+
+                senescence(:,ivm) = .TRUE.
+
+             ENDWHERE
+
+          ! Grasses
+          ELSE
+
+!!$            !+++CHECK+++
+!!$            ! There is no longer this kind of turnover outside the senescence period.
+!!$            ! The physiological basis of this turnover is unclear because the turn
+!!$            ! over due to ageing has been accounted for in Â§4. Not sure whether the
+!!$            ! values for ::turnover_time calculated here are ever used because turnover
+!!$            ! from ageing in Â§4 recalculates the turnover times. 
+!!$            WHERE ( ( biomass(:,ivm,ileaf,icarbon) .GT. zero ) .AND. &
+!!$                 ( leaf_meanage(:,ivm) .GT. min_leaf_age_for_senescence(ivm) ) .AND. &
+!!$                 ( ( moiavail_week(:,ivm) .LT. moiavail_crit(:) )))
+!!$
+!!$               turnover_time(:,ivm,ileaf) = tau_eff_leaf(:,ivm) * &
+!!$                    (un - (un - (moiavail_week(:,ivm)/  moiavail_crit(:)))**deux)
+!!$               turnover_time(:,ivm,iroot) = tau_eff_root(:,ivm) * &
+!!$                    (un - (un - (moiavail_week(:,ivm)/  moiavail_crit(:)))**deux)
+!!$               turnover_time(:,ivm,isapabove) = tau_eff_sap(:,ivm) * &
+!!$                    (un - (un - (moiavail_week(:,ivm)/  moiavail_crit(:)))**deux)
+!!$               turnover_time(:,ivm,ifruit) = tau_fruit(ivm) * &
+!!$                    (un - (un - (moiavail_week(:,ivm)/  moiavail_crit(:)))**deux)
+!!$		
+!!$            ENDWHERE
+!!$            !+++++++++++
+
+            ! Because the DOFOCO increase of LAI is much slower than in the trunk there
+            ! is a period at the start of the growing season where LAI is less than lai_happy
+            ! In that period t2_month is still increasing from its winter values but could be
+            ! below t_crit. That condition resulted in many grasslands along the Atlantic and
+            ! North Sea coast to go into senescence in May. If someone wants to put it back in
+            ! be carefull with the brackets.((t2m_month(:) .LT. t_crit(:)) .AND. (lai(:,ivm) 
+            ! .GT. lai_happy(ivm)))
+            WHERE ( ( (biomass(:,ivm,ileaf,icarbon) .GT. zero) .AND. &
+                (leaf_meanage(:,ivm) .GT. min_leaf_age_for_senescence(ivm)) .AND. &
+                (t2m_month(:) .LT. ZeroCelsius) .AND. (t2m_week(:) .LT. t2m_month(:)) ) )
+               
+               ! Shed leaves, roots and fruits at a high rate = senescence
+               turnover_time(:,ivm,ileaf) = leaffall(ivm)
+               turnover_time(:,ivm,iroot) = leaffall(ivm)
+               turnover_time(:,ivm,ifruit) = leaffall(ivm)
+
+               ! Slowly turnover the structural carbon this allows to store 
+               ! reserves. This structural pool is essential for the functioning 
+               ! of the labile and reserve pools
+               turnover_time(:,ivm,isapabove) = tau_eff_sap(:,ivm)
+               senescence(:,ivm) = .TRUE.
+ 
+            ENDWHERE
+            
+         ENDIF
+
+       !! 3.1.5 Evergreen species 
+       !  Evergreen species do not experience climatic senescence
+       CASE ( 'none' )
+    
+       !! 3.1.6 Other cases
+       !  In case no climatic senescence type is recognized.
+       CASE default
+
+          WRITE(numout,*) '  turnover: don''t know how to treat this PFT.'
+          WRITE(numout,*) '  number (::ivm) : ',ivm
+          WRITE(numout,*) '  senescence type (::senescence_type(ivm)) : ',senescence_type(ivm)
+
+          STOP
+
+       END SELECT
+
+       !---TEMP---
+       IF (ivm .EQ. test_pft .AND. ld_pheno) THEN
+          WRITE(numout,*) 'phenology, senescence, ',senescence(:,ivm)
+       ENDIF
+       !----------
+
+       !! 3.2 Drop leaves and roots, plus stems and fruits for grasses
+       IF ( is_tree(ivm) ) THEN
+
+          !! 3.2.1 Trees in climatic senescence 
+          !  Trees in climate senescence lose their fine roots at the same rate as they lose their leaves. 
+          !  The rate of biomass loss of both fine roots and leaves is presribed through the equation:
+          !  \latexonly
+          !  \input{turnover_clim_senes_biomass_eqn4.tex}
+          !  \endlatexonly
+          !  \n
+          !  with ::leaffall(ivm) a PFT-dependent time constant which is given in ::stomate_constants).
+
+          ! Notice that we do not change the carbohydrate (icarbres) and labile (ilabile) pools here.  We
+          ! assume that trees can anticipate senescence and move these pools
+          ! to more permanent storage areas so that are not lost, unlike
+          ! in the case of harvesting.
+          WHERE ( senescence(:,ivm) )
+
+             ! Turnover at the stand level (gC m-2)
+             turnover(:,ivm,ileaf,icarbon) = biomass(:,ivm,ileaf,icarbon) * dt / leaffall(ivm)
+             turnover(:,ivm,iroot,icarbon) = biomass(:,ivm,iroot,icarbon) * dt / leaffall(ivm)
+
+             ! Update biomass at the stand level (gC m-2)
+             biomass(:,ivm,ileaf,icarbon) = biomass(:,ivm,ileaf,icarbon) - turnover(:,ivm,ileaf,icarbon)
+             biomass(:,ivm,iroot,icarbon) = biomass(:,ivm,iroot,icarbon) - turnover(:,ivm,iroot,icarbon)
+
+          ENDWHERE
+
+          ! Turnover at tree level (gC tree-1)
+          DO icirc = 1,ncirc
+
+             WHERE ( senescence(:,ivm) )
+
+                circ_class_biomass(:,ivm,icirc,ileaf,icarbon) = circ_class_biomass(:,ivm,icirc,ileaf,icarbon) * &
+                     (un - dt / leaffall(ivm))
+                circ_class_biomass(:,ivm,icirc,iroot,icarbon) = circ_class_biomass(:,ivm,icirc,iroot,icarbon) * &
+                     (un - dt / leaffall(ivm))
+
+             ENDWHERE
+
+          ENDDO
+
+       ! Grasses and crops
+       ELSE
+
+          !! 3.2.2.1 crops with 'crop' phenological model
+          IF (senescence_type(ivm) .EQ. 'crop') THEN
+
+             DO ipts = 1,npts
+             
+                IF (senescence(ipts,ivm)) THEN
+             
+                   ! Crops are planted every year. So make sure to remove everything 
+                   ! at the end of senescence which for crops is actually harvest. 
+                   ! Next stomate_prescribe should prescribe a new crop. If sapwood 
+                   ! is not removed, some is left on site and the model will try to 
+                   ! grow a crop. However, there are not enough reserves left so the 
+                   ! crop will die. This results in one year of normal crop growth 
+                   ! (following the prescribe) and then one year of almost no growth 
+                   ! (the year starting from the too low reserves). This issue has 
+                   ! been fixed.
+                   CALL crop_harvest(npts, ipts, ivm, dt, &
+                        veget_max, turnover, harvest_pool, harvest_type, &
+                        harvest_cut, harvest_area, resolution, biomass, &
+                        ind, leaf_meanage)   
+
+                ENDIF
+
+             ENDDO
+
+          !! 3.2.2.2 grass or crops based on 'mixed' phenological model
+          ! Phenological turnover
+          ELSEIF (senescence_type(ivm) .EQ. 'mixed') THEN
+
+             WHERE (senescence(:,ivm))
+
+                turnover(:,ivm,ileaf,icarbon) = biomass(:,ivm,ileaf,icarbon) * dt / turnover_time(:,ivm,ileaf)
+                turnover(:,ivm,isapabove,icarbon) = biomass(:,ivm,isapabove,icarbon) * dt / turnover_time(:,ivm,isapabove) 
+                turnover(:,ivm,iroot,icarbon) = biomass(:,ivm,iroot,icarbon) * dt / turnover_time(:,ivm,iroot) 
+                turnover(:,ivm,ifruit,icarbon) = biomass(:,ivm,ifruit,icarbon) * dt / turnover_time(:,ivm,ifruit)
+
+             ENDWHERE
+
+             ! Update the biomass pools for grasses and crops
+             biomass(:,ivm,ileaf,icarbon) = biomass(:,ivm,ileaf,icarbon) - turnover(:,ivm,ileaf,icarbon)
+             biomass(:,ivm,isapabove,icarbon) = biomass(:,ivm,isapabove,icarbon) - turnover(:,ivm,isapabove,icarbon)
+             biomass(:,ivm,iroot,icarbon) = biomass(:,ivm,iroot,icarbon) - turnover(:,ivm,iroot,icarbon)
+             biomass(:,ivm,ifruit,icarbon) = biomass(:,ivm,ifruit,icarbon) - turnover(:,ivm,ifruit,icarbon)
+
+          !! 3.2.2.3 Grasses modeled as an evergreen biome  
+          ELSEIF  (senescence_type(ivm) .EQ. 'none') THEN
+
+             turnover(:,ivm,:,icarbon) = zero
+
+          !! 3.2.2.4 Conceptual problem
+          ELSE
+
+             WRITE(numout,*) 'ERROR: senenescence type not known'
+             
+          END IF
+
+          ! Synchronize circ_class_biomass and biomass
+          DO ipar = 1,nparts
+
+             WHERE (ind(:,ivm) .GT. zero)
+
+                circ_class_biomass(:,ivm,1,ipar,icarbon) = &
+                     biomass(:,ivm,ipar,icarbon) / ind(:,ivm)
+
+             ELSEWHERE
+
+                circ_class_biomass(:,ivm,1,ipar,icarbon) = zero
+
+             ENDWHERE
+
+          ENDDO ! nparts
+
+       ENDIF      ! tree/grass
+
+       !---TEMP---
+       IF (ivm .EQ. test_pft .AND. ld_trnov) THEN
+          WRITE(numout,*) 'Check turnover'
+          !   DO ipar = 1,nparts
+          !      WRITE(numout,*) 'biomass vs circ_class_biomass (gC m-2), ', biomass(1,ivm,ipar,icarbon), &
+          !           SUM(circ_class_biomass(1,ivm,:,ipar,icarbon)*circ_class_n(1,ivm,:))
+          !   ENDDO
+          WRITE(numout,*) 'TOTAL biomass vs circ_class_biomass, ', SUM(biomass(1,ivm,:,icarbon)), &
+               SUM( SUM(circ_class_biomass(1,ivm,:,:,icarbon),2) * circ_class_n(1,ivm,:),1)
+       ENDIF
+       !----------
+
+    ENDDO        ! loop over PFTs
+
+
+ !! 4. Leaf fall
+
+    !  At a certain age, leaves fall off, even if the climate would allow a 
+    !  green plant all year round. Even if the meteorological conditions are 
+    !  favorable for leaf maintenance, plants, and in particular, evergreen 
+    !  trees, have to renew their leaves simply because the old leaves become 
+    !  inefficient. Another reason for leaf fall may be waterstress. When 
+    !  the plant experiences water stress some of the leaves will die.
+    !  Wstress is calculated from the ratio between stressed and unstressed
+    !  GPP. If the wstress is less than 1, this implies that we have to maintain
+    !  a complete canopy (and therefore have the Ra cost) but that only part 
+    !  of the canopy will contribute to GPP. Although this is exactely what 
+    !  happens on a warm summer day, what we are trying to account for here is
+    !  the impact of a lasting drought (days to weeks). Adaptation to the
+    !  growing conditions are accounted for through KF (see allocation).
+    !   
+    !  Roots, fruits (and stems) follow leaves. The decay rate varies with 
+    !  leaf  age. Note that plant is not declared senescent in this case 
+    !  (wchich is important for allocation: if the plant loses leaves because 
+    !  of their age, it can renew them). 
+    !
+    !  Notice that we do not change the reserve pools here (ilabile and 
+    !  icarbres). We assume that the tree will move these pools out of old 
+    !  leaves and therefore the carbon will not be lost.  Trees are smart.
+    !
+    !  The leaf turnover rate due to aging of leaves is calculated using 
+    !  the following equation:
+    !  \latexonly
+    !  \input{turnover_age_senes_biomass_eqn5.tex}
+    !  \endlatexonly
+    !  \n
+    DO ivm = 2,nvm ! Loop over # PFTs
+
+       !! 4.1 Calculate critical leaf age
+       !  save old leaf mass
+       lm_old(:) = biomass(:,ivm,ileaf,icarbon)
+
+       !! initialize leaf mass change in age class
+       delta_lm(:,:) = zero
+
+       !  Trees and crops
+       !  leaves, roots, fruits roots and fruits follow leaves.
+       IF ( is_tree(ivm) .OR. (.NOT. natural(ivm)) ) THEN
+
+          ! Critical age: prescribed for trees
+          leaf_age_crit(:,ivm) = tau_eff_leaf(:,ivm)
+
+       !  Grasses
+       !  leaves, roots, fruits, sap follow leaves.
+       ELSE
+
+          !  Critical leaf age depends on long-term temperature
+          !  generally, lower turnover in cooler climates.
+          leaf_age_crit(:,ivm) = MIN( tau_eff_leaf(:,ivm) * leaf_age_crit_coeff(1) , &
+               MAX( tau_eff_leaf(:,ivm) * leaf_age_crit_coeff(2) , &
+               tau_eff_leaf(:,ivm) - leaf_age_crit_coeff(3) * &
+               ( tlong_ref(:)-ZeroCelsius - leaf_age_crit_tref ) ) )
+
+       END IF
+          
+       !! 4.2 Turnover for different leaf age classes
+       DO ilage = 1, nleafages
+
+          turnover_rate(:) = zero
+
+          WHERE ( leaf_age(:,ivm,ilage) .GT. leaf_age_crit(:,ivm) / deux)
+
+             turnover_rate(:) =  MIN( 0.99_r_std, dt / ( leaf_age_crit(:,ivm) * &
+                  ( leaf_age_crit(:,ivm) / leaf_age(:,ivm,ilage) )**quatre ) )
+
+          ENDWHERE
+  
+          IF (is_tree(ivm)) THEN
+
+             ! Stand level turnover (gC m-2)
+             ! Leaves
+             ! Water stress is increasing (note that ::wstress is thus 
+             ! decreasing)so the LAI will be lowered if the decrease is 
+             ! small, this will result in a cosmetic change in LAI. 
+             ! If water stress is increasing over a the course of a week, 
+             ! this decrease may become important. The correction is 
+             ! cummulative, for example, ::biomass(ileaf) is decreased 
+             ! by 10% in day one and the remaining fraction of 
+             ! ::biomass(ileaf) can be decreased by another 10% the next 
+             ! day, etc ... The choice to multiply with ::wstress_month
+             ! is arbitrary, we could have well used ::wstress_week. By
+             ! using the monthly value we hope a smoother decrease 
+             ! compared to using ::wstress_week or ::wstress_day.
+             
+             !+++CHECK+++
+             ! Switch off the drought feedback
+             ! Do we have enough biomass to satisfy the turnover?
+!!$             WHERE ( (wstress_month(:,ivm)**(1/tau_hum_month)) .LT. un ) 
+!!$                
+!!$                ! Account for water stress
+!!$                turnover_rate(:) =  turnover_rate(:) / &
+!!$                     (wstress_month(:,ivm)**(1/tau_hum_month))
+!!$
+!!$             ENDWHERE
+             !+++++++++++
+
+             ! Update biomass and turnover pools
+             dturnover(:) = biomass(:,ivm,ileaf,icarbon) * leaf_frac(:,ivm,ilage) * turnover_rate(:)
+             biomass(:,ivm,ileaf,icarbon) = biomass(:,ivm,ileaf,icarbon) - dturnover(:) 
+             turnover(:,ivm,ileaf,icarbon) = turnover(:,ivm,ileaf,icarbon) + dturnover(:)
+             
+             ! save leaf mass change
+             delta_lm(:,ilage) = - dturnover(:)
+
+             !+++CHECK+++
+             ! It is not clear why roots follow the leaves. A turnover rate for roots based on
+             ! tau_eff_root can be easily calculated
+             ! Roots
+             dturnover(:) = biomass(:,ivm,iroot,icarbon) * leaf_frac(:,ivm,ilage) * turnover_rate(:)
+             biomass(:,ivm,iroot,icarbon) = biomass(:,ivm,iroot,icarbon) - dturnover(:)
+             turnover(:,ivm,iroot,icarbon) = turnover(:,ivm,iroot,icarbon) + dturnover(:)
+             !+++++++++++
+             
+             ! Fruit
+             dturnover(:) = biomass(:,ivm,ifruit,icarbon) * leaf_frac(:,ivm,ilage) * turnover_rate(:)
+             biomass(:,ivm,ifruit,icarbon) = biomass(:,ivm,ifruit,icarbon) - dturnover(:)
+             turnover(:,ivm,ifruit,icarbon) = turnover(:,ivm,ifruit,icarbon) + dturnover(:)
+
+             ! Tree level turnover (gC tree-1): leaves, roots and fruit
+             DO icirc = 1,ncirc
+
+                circ_class_biomass(:,ivm,icirc,ileaf,icarbon) = circ_class_biomass(:,ivm,icirc,ileaf,icarbon) * &
+                     (un - leaf_frac(:,ivm,ilage) * turnover_rate(:))
+                circ_class_biomass(:,ivm,icirc,iroot,icarbon) = circ_class_biomass(:,ivm,icirc,iroot,icarbon) * &
+                     (un - leaf_frac(:,ivm,ilage) * turnover_rate(:))
+                circ_class_biomass(:,ivm,icirc,ifruit,icarbon) = circ_class_biomass(:,ivm,icirc,ifruit,icarbon) * &
+                     (un - leaf_frac(:,ivm,ilage) * turnover_rate(:))
+
+             ENDDO
+
+          ! Crops
+          ELSEIF (.NOT. natural(ivm)) THEN
+
+             ! The sapwood acts as the structure to supports leaves and roots and store the 
+             ! reserves and labile. Because the growing season is short for crops, the 
+             ! turnover of tissues should be kept to a minimum or the GPP and NPP will be 
+             ! too low.
+             dturnover(:) = biomass(:,ivm,ileaf,icarbon) * leaf_frac(:,ivm,ilage) * &
+                  turnover_rate(:) / (wstress_month(:,ivm)**(1/tau_hum_month))
+
+             ! Do we have enough biomass to satisfy the turnover?
+             WHERE ( dturnover(:) .GE. biomass(:,ivm,ileaf,icarbon) )
+                
+                ! No longer account for wstress
+                dturnover(:) = biomass(:,ivm,ileaf,icarbon) * &
+                     leaf_frac(:,ivm,ilage) * turnover_rate(:)
+
+             ENDWHERE
+
+             ! Update biomass and turnover pools
+             turnover(:,ivm,ileaf,icarbon) = turnover(:,ivm,ileaf,icarbon) + dturnover(:)
+             biomass(:,ivm,ileaf,icarbon) = biomass(:,ivm,ileaf,icarbon) - dturnover(:)
+
+             ! save leaf mass change
+             delta_lm(:,ilage) = - dturnover(:)
+
+             dturnover(:) = biomass(:,ivm,iroot,icarbon) * dt / tau_eff_root(:,ivm)
+             turnover(:,ivm,iroot,icarbon) = turnover(:,ivm,iroot,icarbon) + dturnover(:)
+             biomass(:,ivm,iroot,icarbon) = biomass(:,ivm,iroot,icarbon) - dturnover(:)
+
+             dturnover(:) = biomass(:,ivm,ifruit,icarbon) * leaf_frac(:,ivm,ilage) * turnover_rate(:)
+             turnover(:,ivm,ifruit,icarbon) = turnover(:,ivm,ifruit,icarbon) + dturnover(:)
+             biomass(:,ivm,ifruit,icarbon) = biomass(:,ivm,ifruit,icarbon) - dturnover(:)
+            
+             ! Synchronize circ_class_biomass and biomass
+             DO ipar = 1,nparts
+
+                WHERE (ind(:,ivm) .GT. zero)
+
+                   circ_class_biomass(:,ivm,1,ipar,icarbon) = &
+                        biomass(:,ivm,ipar,icarbon) / ind(:,ivm)
+
+                ELSEWHERE
+
+                   circ_class_biomass(:,ivm,1,ipar,icarbon) = zero
+
+                ENDWHERE
+
+             ENDDO ! nparts
+
+          ! Grasses   
+          ELSEIF ( ( .NOT. is_tree(ivm) ) .AND. natural(ivm) ) THEN
+             
+             ! Grasses are now modeled as an evergreen biome, turnover is thus needed.
+             ! This section was implemented much later then the previous blocks and we
+             ! therefore followed our own advice and used tau_sap and tau_root rather 
+             ! then having all biomass pool to follow leaf turnover.
+             dturnover(:) = biomass(:,ivm,ileaf,icarbon) * leaf_frac(:,ivm,ilage) * &
+                  turnover_rate(:) / (wstress_month(:,ivm)**(1/tau_hum_month))
+
+             ! Do we have enough biomass to satisfy the turnover?
+             WHERE ( dturnover(:) .GE. biomass(:,ivm,ileaf,icarbon) )
+                
+                ! No longer account for wstress
+                dturnover(:) = biomass(:,ivm,ileaf,icarbon) * &
+                     leaf_frac(:,ivm,ilage) * turnover_rate(:)
+
+             ENDWHERE
+             
+             ! Grasses are no longer considered natural and so it is assumed that the
+             ! aboveground turnover ends up in the harvest pool (mowing or grazing). 
+             ! No idea whether this is anything close to reality but it is better to 
+             ! assuming that there is no lateral transport. After testing over Europe
+             ! the annual harvest_pool for grasses was 128 Tg C year compared to the 
+             ! estimated/observed 161 Tg C year. It is left to grassland people to further
+             ! improve this. Note that strictly speaking there is still no harvest, all 
+             ! we did is moving the natural turnover (due to longevity) into the harvest
+             ! pool.
+             harvest_pool(:,ivm,1,icarbon) = harvest_pool(:,ivm,1,icarbon) + &
+                  dturnover(:) * veget_max(:,ivm) * pixel_area(:)
+             biomass(:,ivm,ileaf,icarbon) = biomass(:,ivm,ileaf,icarbon) - dturnover(:)
+
+             ! save leaf mass change
+             delta_lm(:,ilage) = - dturnover(:)
+
+             ! Seeds are eaten
+             dturnover(:) = biomass(:,ivm,ifruit,icarbon) * dt / tau_eff_leaf(:,ivm)
+             harvest_pool(:,ivm,1,icarbon) = harvest_pool(:,ivm,1,icarbon) + &
+                  dturnover(:) * veget_max(:,ivm) * pixel_area(:)
+             biomass(:,ivm,ifruit,icarbon) = biomass(:,ivm,ifruit,icarbon) - dturnover(:)
+
+             ! Half the sapwood is eaten, half is added to the litter
+             dturnover(:) = biomass(:,ivm,isapabove,icarbon) * dt / tau_eff_sap(:,ivm)
+             harvest_pool(:,ivm,1,icarbon) = harvest_pool(:,ivm,1,icarbon) + &
+                  0.5 * dturnover(:) * veget_max(:,ivm) * pixel_area(:)
+             turnover(:,ivm,isapabove,icarbon) = turnover(:,ivm,isapabove,icarbon) + &
+                  0.5 * dturnover(:)
+             biomass(:,ivm,isapabove,icarbon) = biomass(:,ivm,isapabove,icarbon) - dturnover(:)
+ 
+             ! Fill associated harvest variables
+             harvest_type(:,ivm) = ifm_grass
+             harvest_cut(:,ivm) = icut_grass
+             harvest_area(:,ivm) = veget_max(:,ivm) * pixel_area(:)
+
+             ! Make sure the harvest does not enter the turnover pool
+             turnover(:,ivm,ileaf,icarbon) = zero
+             turnover(:,ivm,ifruit,icarbon) = zero
+
+             ! Root turnover at the stand level (gC m-2). Roots are added to the litter pool
+             dturnover(:) = biomass(:,ivm,iroot,icarbon) * dt / tau_eff_root(:,ivm)
+             turnover(:,ivm,iroot,icarbon) = turnover(:,ivm,iroot,icarbon) + dturnover(:)
+             biomass(:,ivm,iroot,icarbon) = biomass(:,ivm,iroot,icarbon) - dturnover(:)
+
+             ! Synchronize circ_class_biomass and biomass
+             DO ipar = 1,nparts
+
+                WHERE (ind(:,ivm) .GT. zero)
+
+                   circ_class_biomass(:,ivm,1,ipar,icarbon) = &
+                        biomass(:,ivm,ipar,icarbon) / ind(:,ivm)
+
+                ELSEWHERE
+
+                   circ_class_biomass(:,ivm,1,ipar,icarbon) = zero
+
+                ENDWHERE
+
+             ENDDO ! nparts
+             
+          ELSE
+
+             WRITE(numout,*) 'ERROR: turnover has not been defined'
+
+          ENDIF ! is_tree(ivm)
+
+          !---TEMP---
+          IF (ivm .EQ. test_pft .AND. ld_trnov) THEN
+             WRITE(numout,*) 'Check turnover - senesence'
+             !   DO ipar = 1,nparts
+             !      WRITE(numout,*) 'biomass vs circ_class_biomass (gC m-2), ', biomass(test_grid,ivm,ipar,icarbon), &
+             !           SUM(circ_class_biomass(test_grid,ivm,:,ipar,icarbon)*circ_class_n(test_grid,ivm,:))
+             !   ENDDO
+             WRITE(numout,*) 'TOTAL biomass vs circ_class_biomass, ', SUM(biomass(test_grid,ivm,:,icarbon)), &
+                  SUM( SUM(circ_class_biomass(test_grid,ivm,:,:,icarbon),2) * circ_class_n(test_grid,ivm,:),1)
+          ENDIF
+          !----------
+             
+       ENDDO
+
+       !! 4.3 Recalculate the fraction of leaf biomass in each leaf age class.
+       !  Older leaves will fall faster than younger leaves and therefore 
+       !  the leaf age distribution needs to be recalculated after turnover. 
+       !  The fraction of biomass in each leaf class is updated using the following equation:
+       !  \latexonly
+       !  \input{turnover_update_LeafAgeDistribution_eqn6.tex}
+       !  \endlatexonly
+       !  \n
+       !  new fraction = new leaf mass of that fraction / new total leaf mass
+       !               = (old fraction*old total leaf mass ::lm_old(:) + biomass change of that fraction ::delta_lm(:,m)  ) /
+       !                  new total leaf mass ::biomass(:,ivm,ileaf
+       DO ilage = 1, nleafages
+          
+          WHERE ( biomass(:,ivm,ileaf,icarbon) .GT. zero )
+
+             leaf_frac(:,ivm,ilage) = ( leaf_frac(:,ivm,ilage)*lm_old(:) + delta_lm(:,ilage) ) / biomass(:,ivm,ileaf,icarbon)
+
+          ELSEWHERE
+
+             leaf_frac(:,ivm,ilage) = zero
+
+          ENDWHERE
+        
+       ENDDO
+       
+    ENDDO         ! loop over PFTs
+
+
+ !! 5. Definitely drop all leaves if there is a very low leaf mass during senescence.
+
+    !  Both for deciduous trees and grasses same conditions are checked:
+    !  If biomass is large enough (i.e. when it is greater than zero), 
+    !  AND when senescence is set to true
+    !  AND the leaf biomass drops below a critical minimum biomass level (i.e. when it is lower than half
+    !  the minimum initial LAI ::lai_initmin(ivm) divided by the specific leaf area ::sla(ivm),
+    !  ::lai_initmin(ivm) is set to 0.3 in stomate_data.f90 and sla is a constant that is set to 0.015366 m2/gC), 
+    !  If these conditions are met, the flag ::shed_rest(:) is set to TRUE.
+    !
+    !  After this, the biomass of different carbon pools both for trees and grasses is set to zero
+    !  and the mean leaf age is reset to zero.
+    !  Finally, the leaf fraction and leaf age of the different leaf age classes is set to zero.
+    DO ivm = 2,nvm ! Loop over # PFTs
+
+       shed_rest(:) = .FALSE.
+
+       !! 5.1 For deciduous trees: next to leaves, also fruits and fine roots are dropped 
+       !  For deciduous trees: next to leaves, also fruits and fine roots are dropped: fruit ::biomass(:,ivm,ifruit) 
+       !  and fine root ::biomass(:,ivm,iroot) carbon pools are set to zero.
+       IF ( is_tree(ivm) .AND. ( senescence_type(ivm) .NE. 'none' ) ) THEN
+
+          ! Check whether we shed the remaining leaves. The condition depends on biomass(ileaf)
+          ! so first calculate the sheding at the tree level. because biomass(ileaf) is not 
+          ! changed at the tree level the same statement can then be used at the stand level.
+          DO icirc = 1,ncirc
+
+             ! check whether we shed the remaining leaves
+             WHERE ( ( biomass(:,ivm,ileaf,icarbon) .GT. zero ) .AND. senescence(:,ivm) .AND. &
+                  ( biomass(:,ivm,ileaf,icarbon) .LT. (lai_initmin(ivm) / 2.)/sla(ivm) ) )
+
+                ! Tree level (gC tree-1)
+                circ_class_biomass(:,ivm,icirc,ileaf,icarbon)  = zero
+                circ_class_biomass(:,ivm,icirc,iroot,icarbon)  = zero
+                circ_class_biomass(:,ivm,icirc,ifruit,icarbon) = zero
+
+             ENDWHERE
+
+          ENDDO !ncirc
+
+          ! check whether we shed the remaining leaves
+          WHERE ( ( biomass(:,ivm,ileaf,icarbon) .GT. zero ) .AND. senescence(:,ivm) .AND. &
+               ( biomass(:,ivm,ileaf,icarbon) .LT. (lai_initmin(ivm) / 2.)/sla(ivm) ) )
+
+             shed_rest(:) = .TRUE.
+
+             ! Stand level (gc m-2)
+             turnover(:,ivm,ileaf,icarbon)  = turnover(:,ivm,ileaf,icarbon) + biomass(:,ivm,ileaf,icarbon)
+             turnover(:,ivm,iroot,icarbon)  = turnover(:,ivm,iroot,icarbon) + biomass(:,ivm,iroot,icarbon)
+             turnover(:,ivm,ifruit,icarbon) = turnover(:,ivm,ifruit,icarbon) + biomass(:,ivm,ifruit,icarbon)
+             biomass(:,ivm,ileaf,icarbon)  = zero
+             biomass(:,ivm,iroot,icarbon)  = zero
+             biomass(:,ivm,ifruit,icarbon) = zero
+
+             ! reset leaf age
+             leaf_meanage(:,ivm) = zero
+
+          ENDWHERE
+
+       ENDIF
+
+       !! 5.2 For grasses: all aboveground carbon pools, except the carbohydrate reserves are affected: 
+       !  For grasses: all aboveground carbon pools, except the carbohydrate reserves are affected: 
+       !  fruit ::biomass(:,ivm,ifruit,icarbon), fine root ::biomass(:,ivm,iroot,icarbon) and sapwood above 
+       !  ::biomass(:,ivm,isapabove,icarbon) carbon pools are set to zero. 
+       IF ( .NOT. is_tree(ivm) ) THEN
+
+          IF (senescence_type(ivm) .EQ. 'crop') THEN
+
+!!$             ! Shed the remaining leaves if LAI very low.
+!!$             WHERE ( ( biomass(:,ivm,ileaf,icarbon) .GT. zero ) .AND. senescence(:,ivm) .AND. &
+!!$                  (  biomass(:,ivm,ileaf,icarbon) .LT. (lai_initmin(ivm) / deux) / sla(ivm) ) )
+!!$                
+!!$                shed_rest(:) = .TRUE.
+!!$             
+!!$                ! Crops are planted every year. So make sure to remove everything at the end of senescence 
+!!$                ! which for crops is actually harvest. Next stomate_prescribe should prescribe a new crop.
+!!$                ! If sapwood is not removed, some is left on site and the model will try to grow a crop.
+!!$                ! However, there are not enough reserves left so the crop will die. This results in one year
+!!$                ! of normal crop growth (following the prescribe) and then one year of almost no growth (the
+!!$                ! year starting from the too low reserves).
+!!$                turnover(:,ivm,ileaf,icarbon) = turnover(:,ivm,ileaf,icarbon) + biomass(:,ivm,ileaf,icarbon) + &
+!!$                     biomass(:,ivm,icarbres,icarbon) + biomass(:,ivm,ilabile,icarbon)
+!!$                turnover(:,ivm,iroot,icarbon) = turnover(:,ivm,iroot,icarbon) + biomass(:,ivm,iroot,icarbon)
+!!$                turnover(:,ivm,ifruit,icarbon) = turnover(:,ivm,ifruit,icarbon) + biomass(:,ivm,ifruit,icarbon)
+!!$                turnover(:,ivm,isapabove,icarbon) = turnover(:,ivm,isapabove,icarbon) + biomass(:,ivm,isapabove,icarbon) + &
+!!$                     biomass(:,ivm,isapbelow,icarbon)
+!!$                turnover(:,ivm,isapabove,icarbon) = turnover(:,ivm,isapabove,icarbon) + biomass(:,ivm,iheartabove,icarbon) + &
+!!$                     biomass(:,ivm,iheartbelow,icarbon)
+!!$                biomass(:,ivm,isapabove,icarbon) = zero
+!!$                biomass(:,ivm,ileaf,icarbon) = zero
+!!$                biomass(:,ivm,iroot,icarbon) = zero
+!!$                biomass(:,ivm,ifruit,icarbon) = zero
+!!$                biomass(:,ivm,icarbres,icarbon) = zero
+!!$                biomass(:,ivm,ilabile,icarbon) = zero
+!!$                
+!!$                ! To be sure put overlooked residuals also in the turnover pool 
+!!$                biomass(:,ivm,iheartbelow,icarbon) = zero
+!!$                biomass(:,ivm,iheartabove,icarbon) = zero
+!!$                biomass(:,ivm,isapbelow,icarbon) = zero
+!!$
+!!$                ! No individuals left
+!!$                ind(:,ivm) = zero
+!!$
+!!$                ! reset leaf age
+!!$                leaf_meanage(:,ivm) = zero
+!!$
+!!$             ENDWHERE
+
+          ELSEIF (senescence_type(ivm) .EQ. 'mixed') THEN
+
+             ! Shed the remaining leaves if LAI very low.
+             WHERE ( ( biomass(:,ivm,ileaf,icarbon) .GT. zero ) .AND. senescence(:,ivm) .AND. &
+                  (  biomass(:,ivm,ileaf,icarbon) .LT. (lai_initmin(ivm) / deux) / sla(ivm) ) )
+                
+                shed_rest(:) = .TRUE.
+             
+                ! Grasses should live on after senescence. Do not shed the sapwood because then the whole 
+                ! system collapse because the reserves are calculated based on the sapwood. no sapwood = no 
+                ! reserves = no phenology = no growth.
+                turnover(:,ivm,ileaf,icarbon) = turnover(:,ivm,ileaf,icarbon) + biomass(:,ivm,ileaf,icarbon) + &
+                      biomass(:,ivm,icarbres,icarbon) + biomass(:,ivm,ilabile,icarbon)
+                turnover(:,ivm,iroot,icarbon) = turnover(:,ivm,iroot,icarbon) + biomass(:,ivm,iroot,icarbon)
+                turnover(:,ivm,ifruit,icarbon) = turnover(:,ivm,ifruit,icarbon) + biomass(:,ivm,ifruit,icarbon)
+                biomass(:,ivm,ileaf,icarbon) = zero
+                biomass(:,ivm,iroot,icarbon) = zero
+                biomass(:,ivm,ifruit,icarbon) = zero
+                biomass(:,ivm,icarbres,icarbon) = zero
+                biomass(:,ivm,ilabile,icarbon) = zero
+
+                ! Note that grasses stay alive so do not change the number of individuals!
+
+                ! reset leaf age
+                leaf_meanage(:,ivm) = zero
+            
+             ENDWHERE
+
+          ELSEIF (senescence_type(ivm) .EQ. 'none') THEN
+
+             ! Nothing should be done
+
+          ELSE
+             
+             WRITE(numout,*) 'ERROR: senescence type is not known'
+
+          ENDIF
+
+          !---TEMP---
+          IF (ivm .EQ. test_pft .AND. ld_pheno) THEN
+             WRITE(numout,*) 'phenology, shed_rest, ',shed_rest(:)
+          ENDIF
+          !----------
+
+          ! Synchronize circ_class_biomass and biomass
+          DO ipar = 1,nparts
+
+             WHERE (ind(:,ivm) .GT. zero)
+
+                circ_class_biomass(:,ivm,1,ipar,icarbon) = &
+                     biomass(:,ivm,ipar,icarbon) / ind(:,ivm)
+
+             ELSEWHERE
+
+                circ_class_biomass(:,ivm,1,ipar,icarbon) = zero
+
+             ENDWHERE
+
+          ENDDO ! nparts
+
+       ENDIF ! is_tree(ivm)
+
+       !---TEMP---
+       IF (ivm .EQ. test_pft .AND. ld_trnov) THEN
+          WRITE(numout,*) 'Check turnover - leaf sheding'
+          WRITE(numout,*) 'ifruit biomass vs circ_class_biomass (gC m-2), ', biomass(test_grid,ivm,ifruit,icarbon), &
+               SUM(circ_class_biomass(test_grid,ivm,:,ifruit,icarbon)*circ_class_n(test_grid,ivm,:))
+
+          WRITE(numout,*) 'TOTAL biomass vs circ_class_biomass, ', SUM(biomass(test_grid,ivm,:,icarbon)), &
+               SUM( SUM(circ_class_biomass(test_grid,ivm,:,:,icarbon),2) * circ_class_n(test_grid,ivm,:),1)
+       ENDIF
+       !----------
+
+       !! 5.3 Reset the leaf age structure: the leaf fraction and leaf age 
+       !  of the different leaf age classes is set to zero.
+       DO ilage = 1, nleafages
+
+          WHERE ( shed_rest(:) )
+
+             leaf_age(:,ivm,ilage) = zero
+             leaf_frac(:,ivm,ilage) = zero
+
+          ENDWHERE
+
+       ENDDO
+
+    ENDDO          ! loop over PFTs
+  
+
+ !! 6. Herbivore activity: elephants, cows, gazelles but no lions.
+ 
+    ! Herbivore activity affects the biomass of leaves and fruits as well 
+    ! as stalks (only for grasses). Herbivore activity does not modify leaf 
+    ! age structure. Herbivores ::herbivores(:,ivm) is the time constant of 
+    ! probability of a leaf to be eaten by a herbivore, and is calculated in 
+    ! ::stomate_season. following Mc Naughton et al. [1989].
+    IF ( control%ok_herbivory ) THEN
+
+       ! If the herbivore activity is allowed (if ::control%ok_herbivory is true, which is set in run.def), 
+       ! remove the amount of biomass consumed by herbivory from the leaf biomass ::biomass(:,ivm,ileaf,icarbon) and 
+       ! the fruit biomass ::biomass(:,ivm,ifruit,icarbon).
+       ! The daily amount consumed equals the biomass multiplied by 1 day divided by the time constant ::herbivores(:,ivm).
+       DO ivm = 2,nvm ! Loop over # PFTs
+
+          IF ( is_tree(ivm) ) THEN
+
+             !---TEMP---
+             IF (ivm .EQ. test_pft .AND. ld_trnov) THEN
+                WRITE(numout,*) 'herbivores, ',herbivores
+             ENDIF
+             !---------
+
+             !! For trees: only the leaves and fruit carbon pools are affected
+             !+++CHECK+++
+             ! Why is root herbivory not accounted for. Could be difficult to parameterize but if 
+             ! leaf browsing is accounted for, there is no reason to ignore root browsing
+             WHERE (biomass(:,ivm,ileaf,icarbon) .GT. zero)
+
+                WHERE (herbivores(:,ivm).GT. zero)
+
+                   ! Stand level (gC m-2)
+                   dturnover(:) = biomass(:,ivm,ileaf,icarbon) * dt / herbivores(:,ivm)
+                   biomass(:,ivm,ileaf,icarbon) = biomass(:,ivm,ileaf,icarbon) - dturnover(:)
+                   turnover(:,ivm,ileaf,icarbon) = turnover(:,ivm,ileaf,icarbon) + dturnover(:)
+                   
+                   dturnover(:) = biomass(:,ivm,ifruit,icarbon) * dt / herbivores(:,ivm)
+                   biomass(:,ivm,ifruit,icarbon) = biomass(:,ivm,ifruit,icarbon) - dturnover(:)
+                   turnover(:,ivm,ifruit,icarbon) = turnover(:,ivm,ifruit,icarbon) + dturnover(:)
+
+                ENDWHERE
+
+             ENDWHERE
+
+             ! Tree level herbivory
+             DO icirc = 1,ncirc
+
+                !! For trees: only the leaves and fruit carbon pools are affected
+                WHERE (biomass(:,ivm,ileaf,icarbon) .GT. zero)
+
+                   WHERE (herbivores(:,ivm).GT. zero)
+                      ! Tree level (gC tree-1)
+                      circ_class_biomass(:,ivm,icirc,ileaf,icarbon) = circ_class_biomass(:,ivm,icirc,ileaf,icarbon) * &
+                           (un - dt / herbivores(:,ivm))
+                      circ_class_biomass(:,ivm,icirc,ifruit,icarbon) = circ_class_biomass(:,ivm,icirc,ifruit,icarbon) * & 
+                           (un - dt / herbivores(:,ivm))
+                   ENDWHERE
+
+                ENDWHERE
+
+             ENDDO ! ncirc
+             !+++++++++
+
+          ! grasses and croplands
+          ELSE
+
+             ! For grasses: all aboveground carbon pools are affected: leaves, fruits and sapwood above
+             WHERE ( biomass(:,ivm,ileaf,icarbon) .GT. zero )
+
+                WHERE (herbivores(:,ivm) .GT. zero)
+
+                   dturnover(:) = biomass(:,ivm,ileaf,icarbon) * dt / herbivores(:,ivm)
+                   turnover(:,ivm,ileaf,icarbon) = turnover(:,ivm,ileaf,icarbon) + dturnover(:)
+                   biomass(:,ivm,ileaf,icarbon) = biomass(:,ivm,ileaf,icarbon) - dturnover(:)
+
+                   dturnover(:) = biomass(:,ivm,isapabove,icarbon) * dt / herbivores(:,ivm)
+                   turnover(:,ivm,isapabove,icarbon) = turnover(:,ivm,isapabove,icarbon) + dturnover(:)
+                   biomass(:,ivm,isapabove,icarbon) = biomass(:,ivm,isapabove,icarbon) - dturnover(:)
+
+                   dturnover(:) = biomass(:,ivm,ifruit,icarbon) * dt / herbivores(:,ivm)
+                   turnover(:,ivm,ifruit,icarbon) = turnover(:,ivm,ifruit,icarbon) + dturnover(:)
+                   biomass(:,ivm,ifruit,icarbon) = biomass(:,ivm,ifruit,icarbon) - dturnover(:)
+
+                ENDWHERE
+
+             ENDWHERE
+
+             ! Synchronize circ_class_biomass and biomass
+             DO ipar = 1,nparts
+
+                WHERE (ind(:,ivm) .GT. zero)
+
+                   circ_class_biomass(:,ivm,1,ipar,icarbon) = &
+                        biomass(:,ivm,ipar,icarbon) / ind(:,ivm)
+
+                ELSEWHERE
+
+                   circ_class_biomass(:,ivm,1,ipar,icarbon) = zero
+
+                ENDWHERE
+
+             ENDDO ! nparts
+             
+          ENDIF  ! tree/grass?
+
+          !---TEMP---
+          IF (ivm .EQ. test_pft .AND. ld_trnov) THEN
+             WRITE(numout,*) 'Check turnover - herbivory '
+             WRITE(numout,*) 'TOTAL biomass vs circ_class_biomass, ', (biomass(test_grid,ivm,:,icarbon)), &
+                  ( SUM(circ_class_biomass(test_grid,ivm,:,:,icarbon),2) * circ_class_n(test_grid,ivm,:))
+          ENDIF
+          !----------
+
+       ENDDO    ! loop over PFTs
+
+    ENDIF ! end herbivores
+
+
+ !! 7. Fruit turnover for trees
+
+    !  Fruit turnover for trees: trees simply lose their fruits
+    !  with a time constant ::tau_fruit(ivm), 
+    !  that is set to 90 days for all PFTs in ::constants_mtc
+    !  Again, we assume that the trees do not lose either of the 
+    !  reserve pools (ilabile or icarbres).
+    DO iele = 1,nelements
+
+       DO ivm = 2,nvm ! Loop over # PFTs
+
+          IF ( is_tree(ivm) ) THEN
+
+             ! Stand level (gC m-2)
+             dturnover(:) = biomass(:,ivm,ifruit,iele) * dt / tau_fruit(ivm)
+             biomass(:,ivm,ifruit,iele) = biomass(:,ivm,ifruit,iele) - dturnover(:)
+             turnover(:,ivm,ifruit,iele) = turnover(:,ivm,ifruit,iele) + dturnover(:)
+
+             ! Tree level (gC tree-1)
+             circ_class_biomass(:,ivm,:,ifruit,iele) = circ_class_biomass(:,ivm,:,ifruit,iele) * &
+                (un - dt / tau_fruit(ivm))
+
+             !---TEMP---
+             IF (ivm .EQ. test_pft .AND. ld_trnov) THEN
+                WRITE(numout,*) 'Check turnover - fruits'
+                WRITE(numout,*) 'biomass(ifruit), circ_class_biomass(ifruit), ',biomass(test_grid,ivm,ifruit,icarbon),  &
+                     SUM(circ_class_biomass(test_grid,ivm,:,ifruit,icarbon)*circ_class_n(test_grid,ivm,:))
+                WRITE(numout,*) 'turnover, ', dt/tau_fruit(ivm)
+             ENDIF
+             !----------
+
+          ENDIF ! is_tree 
+
+          !---TEMP---
+          IF (ivm .EQ. test_pft .AND. ld_trnov) THEN
+             WRITE(numout,*) 'biomass vs circ_class_biomass (gC m-2), ', biomass(test_grid,ivm,ifruit,icarbon), &
+                  SUM(circ_class_biomass(test_grid,ivm,:,ifruit,icarbon)*circ_class_n(test_grid,ivm,:))
+             WRITE(numout,*) 'TOTAL biomass vs circ_class_biomass, ', SUM(biomass(test_grid,ivm,:,icarbon)), &
+                  SUM( SUM(circ_class_biomass(test_grid,ivm,:,:,icarbon),2) * circ_class_n(test_grid,ivm,:),1)
+          ENDIF
+          !----------
+
+       ENDDO ! loop over PFTs
+
+    END DO ! nelements
+
+
+ !! 8. Conversion of sapwood to heartwood both for aboveground and belowground sapwood and heartwood.
+
+    !  Following LPJ (Sitch et al., 2003), sapwood biomass is converted into heartwood biomass 
+    !  with a time constant tau ::tau_sap(j) of 1 year.
+    !  Note that this biomass conversion is not added to "turnover" as the biomass is not lost!
+    DO ivm = 2,nvm ! Loop over # PFTs
+   
+       IF ( is_tree(ivm) ) THEN
+
+          ! For the recalculation of age in 9.2 (in case the vegetation is not dynamic ie. ::control%ok_dgvm is FALSE), 
+          ! the heartwood above and below is stored in ::hw_old(:).
+          IF ( .NOT. control%ok_dgvm ) THEN
+
+             hw_old(:) = biomass(:,ivm,iheartabove,icarbon) + biomass(:,ivm,iheartbelow,icarbon)
+             sw_old(:) = biomass(:,ivm,isapabove,icarbon) + biomass(:,ivm,isapbelow,icarbon)
+
+          ENDIF
+
+          !! 8.1 Calculate the rate of sapwood to heartwood conversion 
+          !  Calculate the rate of sapwood to heartwood conversion with the 
+          !  time constant ::tau_sap(ivm) and update aboveground and 
+          !  belowground sapwood ::biomass(:,ivm,isapabove) and ::biomass(:,ivm,isapbelow)
+          !  and heartwood ::biomass(:,ivm,iheartabove) and ::biomass(:,ivm,iheartbelow).
+          DO iele = 1,nelements
+             
+             ! Stand level above the ground (gC m-2)
+             sapconv(:) = biomass(:,ivm,isapabove,iele) * dt / tau_eff_sap(:,ivm)
+             biomass(:,ivm,iheartabove,iele) =  biomass(:,ivm,iheartabove,iele) + sapconv(:)
+             biomass(:,ivm,isapabove,iele) = biomass(:,ivm,isapabove,iele) - sapconv(:)
+                
+             ! Stand level below the ground (gC m-2)
+             sapconv(:) = biomass(:,ivm,isapbelow,iele) * dt / tau_eff_sap(:,ivm)
+             biomass(:,ivm,iheartbelow,iele) =  biomass(:,ivm,iheartbelow,iele) + sapconv(:)
+             biomass(:,ivm,isapbelow,iele) = biomass(:,ivm,isapbelow,iele) - sapconv(:)
+             
+             DO icirc = 1,ncirc
+                ! Tree level above and belowground (gC tree-1)
+                circ_class_biomass(:,ivm,icirc,iheartabove,iele) =  &
+                     circ_class_biomass(:,ivm,icirc,iheartabove,iele) + &
+                     circ_class_biomass(:,ivm,icirc,isapabove,iele) * dt / &
+                     tau_eff_sap(:,ivm)
+                circ_class_biomass(:,ivm,icirc,isapabove,iele) = &
+                     circ_class_biomass(:,ivm,icirc,isapabove,iele) * &
+                     (un - dt / tau_eff_sap(:,ivm)) 
+                circ_class_biomass(:,ivm,icirc,iheartbelow,iele) = &
+                     circ_class_biomass(:,ivm,icirc,iheartbelow,iele) + &
+                     circ_class_biomass(:,ivm,icirc,isapbelow,iele) * dt / &
+                     tau_eff_sap(:,ivm)
+                circ_class_biomass(:,ivm,icirc,isapbelow,iele) = &
+                     circ_class_biomass(:,ivm,icirc,isapbelow,iele) * &
+                     (un - dt / tau_eff_sap(:,ivm))  
+                
+             ENDDO
+
+          ENDDO
+
+          !---TEMP---
+          IF (ivm .EQ. test_pft .AND. ld_trnov) THEN
+             WRITE(numout,*) 'Check turnover - sap & heartwood'
+          !   DO ipar = 1, nparts
+          !      WRITE(numout,*) 'biomass vs circ_class_biomass (gC m-2), ', biomass(test_grid,ivm,ipar,icarbon), &
+          !           SUM(circ_class_biomass(test_grid,ivm,:,ipar,icarbon)*circ_class_n(test_grid,ivm,:))
+          !   ENDDO
+             WRITE(numout,*) 'TOTAL biomass vs circ_class_biomass, ', SUM(biomass(test_grid,ivm,:,icarbon)), &
+                  SUM( SUM(circ_class_biomass(test_grid,ivm,:,:,icarbon),2) * circ_class_n(test_grid,ivm,:),1)
+          ENDIF
+          !----------
+
+          !! 8.2 If the vegetation is not dynamic, the age of the plant is decreased. 
+          !  The updated heartwood, the sum of new heartwood above and new heartwood below after 
+          !  converting sapwood to heartwood, is saved as ::hw_new(:) .
+          !  Creation of new heartwood decreases the age of the plant with a factor that is determined by: 
+          !  old heartwood ::hw_old(:) divided by the new heartwood ::hw_new(:)
+          IF ( .NOT. control%ok_dgvm ) THEN
+
+             hw_new(:) = biomass(:,ivm,iheartabove,icarbon) + biomass(:,ivm,iheartbelow,icarbon)
+             sw_new(:) = biomass(:,ivm,isapabove,icarbon) + biomass(:,ivm,isapbelow,icarbon)
+
+             WHERE ( hw_new(:) .GT. zero )!
+
+                age(:,ivm) = age(:,ivm) * hw_old(:)/hw_new(:)
+
+                ! Sapwood age doesn't seem to be used, but it causes problems because it is not initialised in this
+                ! routine and it is a local variable
+                !!$ sapwood_age(:,ivm) = sapwood_age(:,ivm) * sw_old(:)/sw_new(:)
+
+             ENDWHERE
+
+          ENDIF
+
+       ENDIF
+
+    ENDDO       ! loop over PFTs
+
+    !---TEMP---  
+    IF (ld_trnov) THEN
+       WRITE(numout,*) 'leaf_meanage in turnover', leaf_meanage(:,test_pft)
+       WRITE(numout,*) 'leaf_age in turnover', leaf_age(:,test_pft,:)
+       WRITE(numout,*) 'leaf_frac in turnover', leaf_frac(:,test_pft,:)
+    ENDIF
+    !----------
+
+    ! Write mean leaf age and time constant of probability of a leaf to be eaten by a herbivore 
+    ! to the stomate output file. 
+    CALL histwrite_p (hist_id_stomate, 'LEAFAGE', itime, &
+         leaf_meanage, npts*nvm, horipft_index)
+    CALL histwrite_p (hist_id_stomate, 'HERBIVORES', itime, &
+         herbivores, npts*nvm, horipft_index)
+
+
+ !! 10. Check mass balance closure
+
+    !! 10.1 Calculate pools at the end of the routine
+    pool_end = zero
+    DO ipar = 1,nparts
+       DO iele = 1,nelements
+          pool_end(:,:,iele) = pool_end(:,:,iele) + &
+               (biomass(:,:,ipar,iele) * veget_max(:,:)) + &
+               (turnover(:,:,ipar,iele) * veget_max(:,:))
+       ENDDO
+    ENDDO
+
+    ! The biomass harvest pool is expressed in gC pixel-1 So, it 
+    ! shouldn't be multiplied by veget_max but it should be divided
+    ! by pixel_area to obtain gC m-2.
+    DO ivm = 1,nvm
+       pool_end(:,ivm,icarbon) = pool_end(:,ivm,icarbon) + &
+            SUM(harvest_pool(:,ivm,:,icarbon),2) / &
+            pixel_area(:)
+    ENDDO
+
+    !! 10.2 Calculate components of the mass balance
+    check_intern(:,:,iatm2land,icarbon) = zero
+    check_intern(:,:,iland2atm,icarbon) = -un * zero
+    check_intern(:,:,ilat2out,icarbon) = zero
+    check_intern(:,:,ilat2in,icarbon) = -un * zero
+    check_intern(:,:,ipoolchange,icarbon) = -un * (pool_end(:,:,icarbon) - pool_start(:,:,icarbon))
+    closure_intern = zero
+    DO imbc = 1,nmbcomp
+       closure_intern(:,:,icarbon) = closure_intern(:,:,icarbon) + check_intern(:,:,imbc,icarbon)
+    ENDDO
+
+    ! Write outcome
+    DO ipts = 1,npts
+       DO ivm = 1,nvm
+          IF (closure_intern(ipts,ivm,icarbon) .LT. min_stomate .AND. &
+               closure_intern(ipts,ivm,icarbon) .GT. -min_stomate) THEN
+             IF (ld_massbal) WRITE(numout,*) 'Mass balance closure: stomate_turnover.f90', ipts, ivm
+          ELSE
+             WRITE(numout,*) 'Error: mass balance is not closed in stomate_turnover.f90'
+             WRITE(numout,*) '   ipts,ivm; ', ipts,ivm
+             WRITE(numout,*) '   Difference is, ', closure_intern(ipts,ivm,icarbon)
+             WRITE(numout,*) '   pool_end,pool_start: ', pool_end(ipts,ivm,icarbon), &
+                  pool_start(ipts,ivm,icarbon)
+         ENDIF
+       ENDDO
+    ENDDO
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving prognostic turnover'
+
+  END SUBROUTINE turnover_prognostic
+
+END MODULE stomate_turnover
Index: branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_vmax.f90
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_vmax.f90	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_stomate/stomate_vmax.f90	(revision 7236)
@@ -0,0 +1,793 @@
+! =================================================================================================================================
+! MODULE 	: stomate_vmax
+!
+! CONTACT	: orchidee-help _at_ ipsl.jussieu.fr
+!
+! LICENCE      	: IPSL (2006). This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!>\BRIEF        calculates the leaf efficiency.
+!!	
+!!\n DESCRIPTION: None
+!!
+!! RECENT CHANGE(S): None
+!!
+!! SVN		:
+!! $HeadURL$ 
+!! $Date$
+!! $Revision$
+!! \n
+!_ =================================================================================================================================
+
+MODULE stomate_vmax
+
+  ! modules used:
+
+  USE ioipsl_para
+  USE stomate_data
+  USE constantes
+  USE pft_parameters
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC vmax_prognostic, vmax_diagnostic, vmax_clear
+
+  ! first call
+  LOGICAL, SAVE                                              :: firstcall = .TRUE.
+!$OMP THREADPRIVATE(firstcall)
+
+CONTAINS
+
+!! ================================================================================================================================
+!! SUBROUTINE	: vmax_clear
+!!
+!>\BRIEF	  Flag setting 
+!!
+!!\n DESCRIPTION: This subroutine sets flags ::firstcall, to .TRUE., and therefore activates   
+!!		  section 1.1 of the ::vmax subroutine which writes messages to the output. \n
+!!		  This subroutine is called at the end of the subroutine ::stomate_clear, in the 
+!!		  module ::stomate.
+!!
+!! RECENT CHANGE(S):None
+!!
+!! MAIN OUTPUT VARIABLE(S): ::firstcall
+!!
+!! REFERENCE(S)  : None 
+!!
+!! FLOWCHART     : None
+!! \n		  
+!_ =================================================================================================================================
+
+  SUBROUTINE vmax_clear
+    firstcall=.TRUE.
+  END SUBROUTINE vmax_clear
+
+
+
+!! ================================================================================================================================
+!! SUBROUTINE    : vmax
+!!
+!>\BRIEF         This subroutine computes vcmax photosynthesis parameters 
+!! given optimal vcmax parameter value and a leaf age-related efficiency.
+!!
+!! DESCRIPTION (functional, design, flags): 
+!! Leaf age classes are introduced to take into account the fact that photosynthetic activity depends on leaf age
+!! (Ishida et al., 1999). There are \f$nleafages\f$ classes (constant defined in pft_parameters.f90).
+!! This subroutine first calculates the new age of each leaf age-class based on fraction of leaf 
+!! that goes from one to another class.                                              
+!! Then calculation of the new fraction of leaf in each class is performed.      
+!! Last, leaf efficiency is calculated for each PFT and for each leaf age class.
+!! vcmax is defined as vcmax25 weighted by a mean leaf
+!! efficiency. vcmax25 is PFT-dependent constants defined in pft_parameters.f90.
+!!
+!! This routine is called once at the beginning by stomate_var_init and then at each stomate time step by stomateLpj.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): vcmax
+!!
+!! REFERENCE(S)	: 
+!! - Ishida, A., A. Uemura, N. Koike, Y. Matsumoto, and A. Lai Hoe (1999),
+!! Interactive effects of leaf age and self-shading on leaf structure, photosynthetic
+!! capacity and chlorophyll fluorescence in the rain forest tree,
+!! dryobalanops aromatica, Tree Physiol., 19, 741-747
+!!
+!! FLOWCHART    : None
+!!
+!! REVISION(S)	: None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE vmax_prognostic (npts, dt, leaf_age, leaf_frac, &
+       age_stand, vcmax, tau_eff_leaf)
+
+    !
+    !! 0. Variable and parameter declaration
+    !
+
+    !
+    !! 0.1 Input variables
+    !
+    INTEGER(i_std), INTENT(in)                                 :: npts                    !! Domain size (unitless)
+    REAL(r_std), INTENT(in)                                    :: dt                      !! time step of stomate (days)
+    INTEGER(i_std),DIMENSION(npts,nvm),INTENT(in)              :: age_stand               !! Age of stand (years)
+                                                                                          !! (is the forest being managed?)
+    REAL(r_std), DIMENSION(:,:), INTENT(in)                    :: tau_eff_leaf            !! Effective leaf turnover time that accounts
+                                                                                          !! waterstress (days)
+    !
+    !! 0.2 Output variables 
+    !
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)              :: vcmax                   !! Maximum rate of carboxylation 
+                                                                                          !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+
+    !
+    !! 0.3 Modified variables
+    !
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_age                !! Leaf age (days)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_frac               !! fraction of leaves in leaf age 
+                                                                                          !! classes 
+                                                                                          !! (unitless)
+
+    !
+    !! 0.4 Local variables
+    !
+    REAL(r_std), DIMENSION(npts)                               :: leaf_efficiency         !! leaf efficiency (vcmax/vcmax25)
+                                                                                          !! (unitless)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages)                 :: d_leaf_frac             !! turnover between age classes
+                                                                                          !! (unitless)
+    REAL(r_std), DIMENSION(npts,nleafages)                     :: leaf_age_new            !! new leaf age (days)
+    REAL(r_std), DIMENSION(npts)                               :: sumfrac                 !! sum of leaf age fractions, 
+                                                                                          !! for normalization
+                                                                                          !! (unitless)
+    REAL(r_std), DIMENSION(npts)                               :: rel_age                 !! relative leaf age (age/critical age)
+                                                                                          !! (unitless)
+    INTEGER(i_std)                                             :: i,j,m                   !! indices (unitless)
+    REAL(r_std), DIMENSION(npts,nvm)                           :: age_decline             !! Age-related decline in photosynthesis efficiency 
+                                                                                          !! (as a proportion to vcmax and vjmax : 1 while age<60
+                                                                                          !! (cf. Gower 1996) 
+                                                                                          !!  and decline_max when age>140 (cf Gower 1996))
+    REAL(r_std), SAVE                                          :: ss_decl_max             !! Temporary variable for sensitivity study 
+!$OMP THREADPRIVATE(ss_decl_max)
+
+!_ ================================================================================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering vmax'
+
+    !
+    !! 1 Initialization
+    !
+
+    !
+    !! 1.1 first call: info about flags and parameters.
+    !
+
+    IF ( firstcall ) THEN
+
+! We do not think we need the FM stuff here anymore.  In theory,
+! the only difference between managed trees and unmanaged trees
+! should be the thinning operations.
+!!$       IF ( control%forest_management ) THEN
+!!$          
+!!$          ss_decl_max = 1.
+!!$          !Config Key   = 
+!!$          !Config Desc  = 
+!!$          !Config If    = 
+!!$          !Config Def   = 
+!!$          !Config Help  = 
+!!$          !Config Units = 
+!!$          CALL getin_p ('ss_decl_max',ss_decl_max)
+!!$         
+!!$       END IF ! control%forest_management
+
+       WRITE(numout,*) 'vmax:'
+
+       WRITE(numout,*) '   > offset (minimum vcmax/vmax_opt):' , vmax_offset
+       WRITE(numout,*) '   > relative leaf age at which vmax reaches 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 reaches its minimum:', leafage_old
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    !
+    !! 1.2 initialize output
+    !
+    age_decline(:,:) = zero
+    vcmax(:,:) = zero
+
+    !
+    !! 2 leaf age: general increase and turnover between age classes.
+    !
+
+    !
+    !! 2.1 increase leaf age
+    !
+
+
+
+!
+!! The age of the leaves in each leaf-age-class increases by 1 time step.
+    DO m = 1, nleafages	! Loop over # leaf age classes 
+       DO j = 2,nvm	! Loop over # PFTs
+          WHERE ( leaf_frac(:,j,m) .GT. min_stomate )
+
+             leaf_age(:,j,m) = leaf_age(:,j,m) + dt
+             
+          ENDWHERE
+       ENDDO	! Loop over # PFTs 
+
+    ENDDO	! Loop over # leaf age classes
+
+   
+
+    !
+    !! 2.2 turnover between leaf age classes
+    !     d_leaf_frac(:,:,m) = what leaves m-1 and goes into m
+    !
+
+    DO j = 2,nvm	! Loop over # PFTs
+
+       !! 2.2.1 fluxes
+
+       !! nothing goes into first age class
+       d_leaf_frac(:,j,1) = zero
+
+       !! for others age classes (what goes from m-1 to m)
+       DO m = 2, nleafages 
+
+          !! leaf_timecst is defined in pft_parameters.f90 as the quotient of the critical leaf age per the number of age classes.
+          !! The critical leaf age is a PFT-dependent constant defined in pft_parameters.f90, that represents the leaf life span.
+          !! This time constant (leaf_timecst) determines the turnover between the nleafages different leaf age classes
+          !! (see section [118] in Krinner et al. (2005)).
+          d_leaf_frac(:,j,m) = leaf_frac(:,j,m-1) * dt/leaf_timecst(j)
+          !KIM 
+          !!!! hiding this for doing global runs
+          !WRITE(numout,*) 'turnover between leaf classes, pft, age class', d_leaf_frac(:,j,m), j, m
+
+          !KIM 
+     !     IF (j .EQ. 4) THEN
+     !       WRITE(numout,*) 'turnover between leaf classes, pft, age class', d_leaf_frac(:,j,m), j, m
+     !     ENDIF
+
+       ENDDO
+
+       !! 2.2.2 new leaf age in class
+       !!       new age = ( old age * (old fraction - fractional loss) + fractional increase * age of the source class ) / new fraction
+       !!       The leaf age of the youngest class (m=1) is updated into stomate_alloc          
+       leaf_age_new(:,:) = zero
+
+       DO m = 2, nleafages-1       ! Loop over age classes
+	!! For all age classes except first and last 
+          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) )
+             
+          ENDWHERE
+
+       ENDDO       ! Loop over age classes
+
+	!! For last age class, there is no leaf fraction leaving the class. 
+
+       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
+       !KIM
+       !!! hiding these write statements for global runs
+       !WRITE(numout,*) 'new leaf age, age class', leaf_age_new(:,:)
+       !WRITE(numout,*) 'old leaf age, pft, age class', leaf_age(:,j,:),j
+
+                        !KIM
+     !  IF (j .EQ. 4) THEN
+     !     WRITE(numout,*) 'new leaf age, age class', leaf_age_new
+     !     WRITE(numout,*) 'old leaf age, pft, age', leaf_age,j
+     !  ENDIF
+
+       DO m = 2, nleafages       ! Loop over age classes
+
+          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       ! Loop over age classes
+
+          ! 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       ! Loop over age classes
+
+       !! 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       ! Loop over age classes
+
+          sumfrac(:) = sumfrac(:) + leaf_frac(:,j,m)
+
+       ENDDO       ! Loop over age classes
+
+       ! normalize
+
+       DO m = 1, nleafages       ! Loop over age classes
+
+
+
+          WHERE ( sumfrac(:) .GT. min_stomate )
+
+             leaf_frac(:,j,m) = leaf_frac(:,j,m) / sumfrac(:) 
+
+
+
+          ELSEWHERE
+
+             leaf_frac(:,j,m) = zero
+
+
+
+          ENDWHERE
+
+
+
+       ENDDO       ! Loop over age classes
+
+    ENDDO         ! Loop over PFTs
+
+    !
+    !! 3 calculate vmax as a function of the age
+    !
+
+    DO j = 2,nvm
+
+       vcmax(:,j) = zero
+
+
+       ! sum up over the different age classes
+
+       DO m = 1, nleafages       ! Loop over age classes
+
+          !
+          !! 3.1 efficiency in each of the age classes
+          !!     it varies from vmax_offset to 1 
+          !!     linearly increases from vmax_offset to 1 for 0 < rel_age < leafage_firstmax
+          !!     is 1 when leafage_firstmax < rel_age < leafage_lastmax
+          !!     linearly decreases from 1 to vmax_offset for leafage_lastmax < rel_age < leafage_firstmax
+          !!     vmax_offset for rel_age >= leafage_old
+          !!     (Ishida et al., 1999)
+
+          rel_age(:) = leaf_age(:,j,m) / tau_eff_leaf(:,j)
+
+          leaf_efficiency(:) = MAX( vmax_offset, MIN( un, &
+               vmax_offset + (un - vmax_offset) * rel_age(:) / leafage_firstmax, &
+               un - (un - vmax_offset) * ( rel_age(:) - leafage_lastmax ) / &
+               ( leafage_old - leafage_lastmax ) ) )
+
+          
+          !KIM
+           IF (ld_vmax .AND. j .EQ. test_pft .AND. m .EQ. 4) THEN 
+              WRITE(numout,*) 'rel_age', rel_age(:)
+              WRITE(numout,*) 'leaf efficiency', leaf_efficiency(:)
+           ENDIF
+
+
+          !
+          !! 3.2 add to mean vmax
+          !
+          
+          vcmax(:,j) = vcmax(:,j) + Vcmax25(j) * leaf_efficiency(:) * leaf_frac(:,j,m)
+
+
+
+       ENDDO     ! loop over age classes
+       !KIM
+       IF (ld_vmax .AND. j .EQ. test_pft) THEN 
+           WRITE(numout,*) 'vcmax corrected for leafage, pft', vcmax(:,test_pft), j
+       ENDIF
+       !
+       !! 4 Modify vmax as a function of the age of the stand and management
+       !
+! We do not think we need the FM stuff here anymore.  In theory,
+! the only difference between managed trees and unmanaged trees
+! should be the thinning operations.
+!!$       IF ( control%forest_management ) THEN
+!!$
+!!$          IF (is_tree(j)) THEN
+!!$
+!!$             WHERE ( forest_managed(:,j) == 0 )
+!!$                age_decline(:,j) = 1.        !-ss_decl_max*decl_factor(j)*100.
+!!$             END WHERE
+!!$
+!!$             DO i = 1,npts
+!!$                IF (forest_managed(i,j) > 0) THEN
+!!$
+!!$                   ! If TCR, values from Calfapietra 2005
+!!$                   IF (forest_managed(i,j) == 4) THEN
+!!$                      vcmax(i,j) = vcmax(i,j)*79.1/vcmax_opt(j)
+!!$                      vjmax(i,j) = vjmax(i,j)*152.4/vjmax_opt(j)
+!!$                   END IF
+!!$                   ! Final age-related decline in photosynthesis efficiency
+!!$                   age_decline(i,j) = 1.-ss_decl_max*decl_factor(j)*REAL(MIN(MAX(age_stand(i,j)-50,0),100)) !**0.5
+!!$
+!!$                END IF
+!!$             END DO
+!!$
+!!$             vcmax(:,j) = age_decline(:,j)**4*opt_factor(j)*vcmax(:,j)
+!!$             vjmax(:,j) = age_decline(:,j)**4*opt_factor(j)*vjmax(:,j)
+!!$
+!!$          ENDIF
+!!$
+!!$       END IF ! (control%forest_management)
+
+    ENDDO       ! loop over PFTs
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving vmax'
+
+  END SUBROUTINE vmax_prognostic
+
+!! ================================================================================================================================
+!! SUBROUTINE    : vmax
+!!
+!>\BRIEF         This subroutine computes vcmax photosynthesis parameters 
+!! given optimal vcmax parameter value and a leaf age-related efficiency.
+!!
+!! DESCRIPTION (functional, design, flags): 
+!! Leaf age classes are introduced to take into account the fact that photosynthetic activity depends on leaf age
+!! (Ishida et al., 1999). There are \f$nleafages\f$ classes (constant defined in pft_parameters.f90).
+!! This subroutine first calculates the new age of each leaf age-class based on fraction of leaf 
+!! that goes from one to another class.                                              
+!! Then calculation of the new fraction of leaf in each class is performed.      
+!! Last, leaf efficiency is calculated for each PFT and for each leaf age class.
+!! vcmax is defined as vcmax25 weighted by a mean leaf
+!! efficiency. vcmax25 is PFT-dependent constants defined in pft_parameters.f90.
+!!
+!! This routine is called once at the beginning by stomate_var_init and then at each stomate time step by stomateLpj.
+!!
+!! RECENT CHANGE(S): None
+!!
+!! MAIN OUTPUT VARIABLE(S): vcmax
+!!
+!! REFERENCE(S)	: 
+!! - Ishida, A., A. Uemura, N. Koike, Y. Matsumoto, and A. Lai Hoe (1999),
+!! Interactive effects of leaf age and self-shading on leaf structure, photosynthetic
+!! capacity and chlorophyll fluorescence in the rain forest tree,
+!! dryobalanops aromatica, Tree Physiol., 19, 741-747
+!!
+!! FLOWCHART    : None
+!!
+!! REVISION(S)	: None
+!! \n
+!_ ================================================================================================================================
+
+  SUBROUTINE vmax_diagnostic (npts, dt, &
+       leaf_age, leaf_frac, &
+       forest_managed, age_stand, &
+       vcmax)
+
+    !
+    !! 0. Variable and parameter declaration
+    !
+
+    !
+    !! 0.1 Input variables
+    !
+    INTEGER(i_std), INTENT(in)                                 :: npts                    !! Domain size (unitless)
+    REAL(r_std), INTENT(in)                                    :: dt                      !! time step of stomate (days)
+    INTEGER(i_std),DIMENSION(npts,nvm),INTENT(in)              :: age_stand               !! Age of stand (years)
+    INTEGER(i_std), DIMENSION (npts,nvm), INTENT(in)           :: forest_managed          !! forest management flag 
+                                                                                          !! (is the forest being managed?)
+    !
+    !! 0.2 Output variables 
+    !
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)              :: vcmax                   !! Maximum rate of carboxylation 
+                                                                                          !! @tex ($\mu mol m^{-2} s^{-1}$) @endtex
+ 
+  
+    !
+    !! 0.3 Modified variables
+    !
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_age                !! Leaf age (days)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_frac               !! fraction of leaves in leaf age 
+                                                                                          !! classes 
+                                                                                          !! (unitless)
+
+    !
+    !! 0.4 Local variables
+    !
+    REAL(r_std), DIMENSION(npts)                               :: leaf_efficiency         !! leaf efficiency (vcmax/vcmax25)
+                                                                                          !! (unitless)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages)                 :: d_leaf_frac             !! turnover between age classes
+                                                                                          !! (unitless)
+    REAL(r_std), DIMENSION(npts,nleafages)                     :: leaf_age_new            !! new leaf age (days)
+    REAL(r_std), DIMENSION(npts)                               :: sumfrac                 !! sum of leaf age fractions, 
+                                                                                          !! for normalization
+                                                                                          !! (unitless)
+    REAL(r_std), DIMENSION(npts)                               :: rel_age                 !! relative leaf age (age/critical age)
+                                                                                          !! (unitless)
+    INTEGER(i_std)                                             :: i,j,m                   !! indices (unitless)
+    REAL(r_std), DIMENSION(npts,nvm)                           :: age_decline             !! Age-related decline in photosynthesis efficiency 
+                                                                                          !! (as a proportion to vcmax and vjmax : 1 while age<60
+                                                                                          !! (cf. Gower 1996) 
+                                                                                          !!  and decline_max when age>140 (cf Gower 1996))
+    REAL(r_std), SAVE                                          :: ss_decl_max             !! Temporary variable for sensitivity study 
+!$OMP THREADPRIVATE(ss_decl_max)
+
+!_ ================================================================================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering vmax'
+
+    !
+    !! 1 Initialization
+    !
+
+    !
+    !! 1.1 first call: info about flags and parameters.
+    !
+
+    IF ( firstcall ) THEN
+
+! We do not think we need the FM stuff here anymore.  In theory,
+! the only difference between managed trees and unmanaged trees
+! should be the thinning operations.
+!!$       IF ( control%forest_management ) THEN
+!!$          
+!!$          ss_decl_max = 1.
+!!$          !Config Key   = 
+!!$          !Config Desc  = 
+!!$          !Config If    = 
+!!$          !Config Def   = 
+!!$          !Config Help  = 
+!!$          !Config Units = 
+!!$          CALL getin_p ('ss_decl_max',ss_decl_max)
+!!$         
+!!$       END IF ! control%forest_management
+
+       WRITE(numout,*) 'vmax:'
+
+       WRITE(numout,*) '   > offset (minimum vcmax/vmax_opt):' , vmax_offset
+       WRITE(numout,*) '   > relative leaf age at which vmax reaches 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 reaches its minimum:', leafage_old
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    !
+    !! 1.2 initialize output
+    !
+    age_decline(:,:) = zero
+    vcmax(:,:) = zero
+
+    !
+    !! 2 leaf age: general increase and turnover between age classes.
+    !
+
+    !
+    !! 2.1 increase leaf age
+    !
+!
+!! The age of the leaves in each leaf-age-class increases by 1 time step.
+    DO m = 1, nleafages	! Loop over # leaf age classes 
+       DO j = 2,nvm	! Loop over # PFTs
+          WHERE ( leaf_frac(:,j,m) .GT. min_stomate )
+
+             leaf_age(:,j,m) = leaf_age(:,j,m) + dt
+             
+          ENDWHERE
+       ENDDO	! Loop over # PFTs 
+
+    ENDDO	! Loop over # leaf age classes
+
+    !
+    !! 2.2 turnover between leaf age classes
+    !     d_leaf_frac(:,:,m) = what leaves m-1 and goes into m
+    !
+
+    DO j = 2,nvm	! Loop over # PFTs
+
+       !! 2.2.1 fluxes
+
+       !! nothing goes into first age class
+       d_leaf_frac(:,j,1) = zero
+
+       !! for others age classes (what goes from m-1 to m)
+       DO m = 2, nleafages 
+!! leaf_timecst is defined in pft_parameters.f90 as the quotient of the critical leaf age per the number of age classes.
+!! The critical leaf age is a PFT-dependent constant defined in pft_parameters.f90, that represents the leaf life span.
+!! This time constant (leaf_timecst) determines the turnover between the nleafages different leaf age classes
+!! (see section [118] in Krinner et al. (2005)).
+          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 loss) + fractional increase * age of the source class ) / new fraction
+       !!       The leaf age of the youngest class (m=1) is updated into stomate_alloc          
+       leaf_age_new(:,:) = zero
+
+       DO m = 2, nleafages-1       ! Loop over age classes
+	!! For all age classes except first and last 
+          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) )
+
+          ENDWHERE
+
+       ENDDO       ! Loop over age classes
+
+	!! For last age class, there is no leaf fraction leaving the class. 
+
+       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       ! Loop over age classes
+
+          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       ! Loop over age classes
+
+          ! 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       ! Loop over age classes
+
+       !! 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       ! Loop over age classes
+
+          sumfrac(:) = sumfrac(:) + leaf_frac(:,j,m)
+
+       ENDDO       ! Loop over age classes
+
+       ! normalize
+
+       DO m = 1, nleafages       ! Loop over age classes
+
+          WHERE ( sumfrac(:) .GT. min_stomate )
+
+             leaf_frac(:,j,m) = leaf_frac(:,j,m) / sumfrac(:) 
+
+          ELSEWHERE
+
+             leaf_frac(:,j,m) = zero
+
+          ENDWHERE
+
+       ENDDO       ! Loop over age classes
+
+    ENDDO         ! Loop over PFTs
+
+    !
+    !! 3 calculate vmax as a function of the age
+    !
+
+    DO j = 2,nvm
+
+       vcmax(:,j) = zero
+ 
+
+       ! sum up over the different age classes
+
+       DO m = 1, nleafages       ! Loop over age classes
+
+          !
+          !! 3.1 efficiency in each of the age classes
+          !!     it varies from vmax_offset to 1 
+          !!     linearly increases from vmax_offset to 1 for 0 < rel_age < leafage_firstmax
+          !!     is 1 when leafage_firstmax < rel_age < leafage_lastmax
+          !!     linearly decreases from 1 to vmax_offset for leafage_lastmax < rel_age < leafage_firstmax
+          !!     vmax_offset for rel_age >= leafage_old
+          !!     (Ishida et al., 1999)
+
+          rel_age(:) = leaf_age(:,j,m) / tau_leaf(j)
+
+          leaf_efficiency(:) = MAX( vmax_offset, MIN( un, &
+               vmax_offset + (un - vmax_offset) * rel_age(:) / leafage_firstmax, &
+               un - (un - vmax_offset) * ( rel_age(:) - leafage_lastmax ) / &
+               ( leafage_old - leafage_lastmax ) ) )
+
+
+          !! 3.2 add to mean vmax
+          vcmax(:,j) = vcmax(:,j) + Vcmax25(j) * leaf_efficiency(:) * leaf_frac(:,j,m)
+          
+
+
+       ENDDO     ! loop over age classes
+
+       !
+       !! 4 Modify vmax as a function of the age of the stand and management
+       !
+! We do not think we need the FM stuff here anymore.  In theory,
+! the only difference between managed trees and unmanaged trees
+! should be the thinning operations.
+!!$       IF ( control%forest_management ) THEN
+!!$
+!!$          IF (is_tree(j)) THEN
+!!$
+!!$             WHERE ( forest_managed(:,j) == 0 )
+!!$                age_decline(:,j) = 1.        !-ss_decl_max*decl_factor(j)*100.
+!!$             END WHERE
+!!$
+!!$             DO i = 1,npts
+!!$                IF (forest_managed(i,j) > 0) THEN
+!!$
+!!$                   ! If TCR, values from Calfapietra 2005
+!!$                   IF (forest_managed(i,j) == 4) THEN
+!!$                      vcmax(i,j) = vcmax(i,j)*79.1/vcmax_opt(j)
+!!$                      vjmax(i,j) = vjmax(i,j)*152.4/vjmax_opt(j)
+!!$                   END IF
+!!$                   ! Final age-related decline in photosynthesis efficiency
+!!$                   age_decline(i,j) = 1.-ss_decl_max*decl_factor(j)*REAL(MIN(MAX(age_stand(i,j)-50,0),100)) !**0.5
+!!$
+!!$                END IF
+!!$             END DO
+!!$
+!!$             vcmax(:,j) = age_decline(:,j)**4*opt_factor(j)*vcmax(:,j)
+!!$             vjmax(:,j) = age_decline(:,j)**4*opt_factor(j)*vjmax(:,j)
+!!$
+!!$          ENDIF
+!!$
+!!$       END IF ! (control%forest_management)
+
+    ENDDO       ! loop over PFTs
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving vmax'
+
+  END SUBROUTINE vmax_diagnostic
+
+END MODULE stomate_vmax
Index: branches/publications/ORCHIDEE_CAN_NHA/src_xml/field_def_orchidee.xml
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_xml/field_def_orchidee.xml	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_xml/field_def_orchidee.xml	(revision 7236)
@@ -0,0 +1,354 @@
+<!-- =========================================================================================================== -->
+<!-- field_def_orchidee.xml : Definition of all existing variables                                               -->
+<!-- This file must only be changed if a call xios_orchidee_send_field is added, changed or removed              -->
+<!-- =========================================================================================================== -->
+
+<field_definition id="orchidee" prec="4" domain_ref="domain_landpoints" operation="average" freq_op="1ts" enabled=".TRUE." default_value="9.96921e+36">
+
+
+  <!-- Definition of all variables in sechiba -->
+  <field_group id="sechiba">
+    <field id="mrsos" name="mrsos" long_name="Moisture in Upper 0.1 m of Soil Column" unit="kg m-2"/>
+    <field id="Areas" name="Areas" long_name="Mesh areas" unit="m2" operation="once"/>
+    <field id="LandPoints" name="LandPoints" long_name="Land Points" unit="1" operation="once"/>
+    <field id="Contfrac" name="Contfrac" long_name="Continental fraction" unit="1" operation="once"/>
+    <field id="mrro" name="mrro" long_name="Total Runoff" unit="kg m-2 s-1"/>
+    <field id="ptn" name="ptn" long_name="Deep ground temperature" unit="K" axis_ref="solth"/>
+    <field id="npp" name="npp" long_name="Net Primary Production" unit="gC/m^2/s" axis_ref="veget"/>
+    <field id="cdrag" name="cdrag" long_name="Drag coefficient for LE and SH" unit="?"/>
+    <field id="soilalb_vis" name="soilalb_vis" long_name="Soil Albedo visible" unit="1"/>
+    <field id="soilalb_nir" name="soilalb_nir" long_name="Soil Albedo near infrared" unit="1"/>
+    <field id="vegalb_vis" name="vegalb_vis" long_name="Vegetation Albedo visible" unit="1"/>
+    <field id="vegalb_nir" name="vegalb_nir" long_name="Vegetation Albedo near infrared" unit="1"/>
+    <field id="z0" name="z0" long_name="Surface roughness" unit="m"/>
+    <field id="evap" name="evap" long_name="Evaporation" unit="mm/d"/>
+    <field id="coastalflow" name="coastalflow" long_name="Diffuse coastal flow" unit="m^3/s"/>
+    <field id="riverflow" name="riverflow" long_name="River flow to the oceans" unit="m^3/s"/>
+    <field id="tsol_rad" name="tsol_rad" long_name="Radiative surface temperature" unit="C"/>
+    <field id="vevapnu" name="vevapnu" long_name="Bare soil evaporation" unit="mm/d"/>
+
+    <field id="temp_sol_C" name="temp_sol" long_name="New Surface Temperature" unit="C"/>
+    <field id="temp_sol_K" name="AvgSurfT" long_name="Average surface temperature" unit="K"/>
+    <field id="tsol_max" name="tsol_max" field_ref="temp_sol_C" long_name="Maximum Surface Temperature" unit="C" operation="maximum"/>
+    <field id="tsol_min" name="tsol_min" field_ref="temp_sol_C" long_name="Minimum Surface Temperature" unit="C" operation="minimum"/>
+    <field id="temp_sol_Cloc" name="temp_sol_Cloc" field_ref="temp_sol_K" long_name="New Surface Temperature" unit="C"> temp_sol_K - 273.15  </field>
+
+    <field id="qsurf" name="qsurf" long_name="Near surface specific humidity" unit="g/g"/>
+    <field id="albedo" name="albedo" long_name="Albedo" unit="1" axis_ref="albtyp"/>
+    <field id="fluxsens" name="fluxsens" long_name="Sensible Heat Flux" unit="W/m^2"/>
+    <field id="fluxlat" name="fluxlat" long_name="Latent Heat Flux" unit="W/m^2"/>
+    <field id="emis" name="emis" long_name="Surface emissivity" unit="1"/>
+    <field id="rain" name="rain" long_name="Rainfall" unit="mm/d"/>
+    <field id="snowf" name="snowf" long_name="Snowfall" unit="mm/d"/>
+    <field id="netrad" name="netrad" long_name="Net radiation" unit="W/m^2"/>
+    <field id="lai" name="lai" long_name="Leaf Area Index" unit="1" axis_ref="veget"/>
+    <field id="reinf_slope" name="reinf_slope" long_name="Slope index for each grid box" unit="1" operation="once"/>
+    <field id="soilindex" name="soilindex" long_name="Soil index" unit="1" operation="once"/>
+    <field id="basinmap" name="basinmap" long_name="Aproximate map of the river basins" operation="once"/>
+    <field id="nbrivers" name="nbrivers" long_name="Number or rivers in the outflow grid box" operation="once"/>
+    <field id="subli" name="subli" long_name="Sublimation" unit="mm/d"/>
+    <field id="runoff" name="runoff" long_name="Surface runoff" unit="mm/d"/>
+    <field id="drainage" name="drainage" long_name="Deep drainage" unit="mm/d"/>
+    <field id="riversret" name="riversret" long_name="Return from endorheic riversD" unit="mm/d"/>
+    <field id="hydrographs" name="hydrographs" long_name="Hydrographs of gridbox outflow" unit="m^3/s"/>
+    <field id="evapnu_soil" name="evapnu_soil" long_name="Bare soil evap for soil type" unit="mm/d" axis_ref="soiltyp"/>
+    <field id="drainage_soil" name="drainage_soil" long_name="Drainage for soil type" unit="mm/d" axis_ref="soiltyp"/>
+    <field id="transpir_soil" name="transpir_soil" long_name="Transpir for soil type" unit="mm/d" axis_ref="soiltyp"/>
+    <field id="runoff_soil" name="runoff_soil" long_name="Runoff for soil type" unit="mm/d" axis_ref="soiltyp"/>
+    <field id="tair" name="tair" long_name="Air Temperature" unit="K"/>
+    <field id="qair" name="qair" long_name="Air Humidity" unit="g/g"/>
+    <field id="q2m" name="q2m" long_name="2m Air Humidity" unit="g/g"/>
+    <field id="t2m" name="t2m" long_name="2m Air temperature" unit="K"/>
+    <field id="alb_vis" name="alb_vis" long_name="Albedo visible" unit="1"/>
+    <field id="alb_nir" name="alb_nir" long_name="Albedo near infrared" unit="1"/>
+    <field id="roughheight" name="roughheight" long_name="Effective roughness height" unit="m"/>
+    <field id="transpir" name="transpir" long_name="Transpiration" unit="mm/d" axis_ref="veget"/>
+    <field id="inter" name="inter" long_name="Interception loss" unit="mm/d" axis_ref="veget"/>
+    <field id="evapnu" name="evapnu" long_name="Bare soil evaporation" unit="mm/d"/>
+    <field id="snow" name="snow" long_name="Snow mass" unit="kg/m^2"/>
+    <field id="snowage" name="snowage" long_name="Snow age" unit="?"/>
+    <field id="snownobio" name="snownobio" long_name="Snow on other surfaces" unit="kg/m^2" axis_ref="nobio"/>
+    <field id="snownobioage" name="snownobioage" long_name="Snow age on other surfaces" unit="d" axis_ref="nobio"/>
+    <field id="vegetfrac" name="vegetfrac" long_name="Fraction of vegetation" unit="1" axis_ref="veget"/>
+    <field id="maxvegetfrac" name="maxvegetfrac" long_name="Maximum fraction of vegetation" unit="1" axis_ref="veget"/>
+    <field id="tot_bare_soil" name="tot_bare_soil" long_name="Total Bare Soil Fraction" unit="%"/>
+    <field id="nobiofrac" name="nobiofrac" long_name="Fraction of other surface types" unit="1" axis_ref="nobio"/>
+    <field id="flood_frac" name="flood_frac" long_name="Flooded fraction" unit="1"/>
+    <field id="reinfiltration" name="reinfiltration" long_name="Reinfiltration from floodplains" unit="mm/d"/>
+    <field id="frac_bare" name="frac_bare" long_name="Bare soil fraction for each tile" unit="-" axis_ref="veget"/>
+    <field id="soiltile" name="soiltile" long_name="Fraction of soil tiles" unit="%" axis_ref="soiltyp" operation="once"/>
+    <field id="dss" name="dss" long_name="Up-reservoir Height" unit="m" axis_ref="veget"/>
+    <field id="gqsb" name="gqsb" long_name="Upper Soil Moisture" unit="Kg/m^2"/>
+    <field id="bqsb" name="bqsb" long_name="Lower Soil Moisture" unit="Kg/m^2"/>
+    <field id="humtot" name="humtot" long_name="Soil Moisture for soil type" unit="Kg/m^2"/>
+    <field id="humtot_soil" name="humtot_soil" long_name="Soil Moisture for soil type" unit="Kg/m^2" axis_ref="soiltyp"/>
+    <field id="SWI" name="SWI" long_name="Soil wetness index" unit="-"/>
+    <field id="njsc" name="njsc" long_name="Soil class used for hydrology" unit="-" operation="once"/>
+    <field id="qsintveg" name="qsintveg" long_name="Water on canopy" unit="Kg/m^2" axis_ref="veget"/>
+    <field id="rstruct" name="rstruct" long_name="Structural resistance" unit="s/m" axis_ref="veget"/>
+    <field id="gpp" name="gpp" long_name="Net assimilation of carbon by the vegetation" unit="gC/m^2/s" axis_ref="veget"/>
+    <field id="nee" name="nee" long_name="Net Ecosystem Exchange" unit="gC/m^2/s" axis_ref="veget"/>
+    <field id="maint_resp" name="maint_resp" long_name="Maintenance respiration" unit="gC/m^2/s" axis_ref="veget"/>
+    <field id="hetero_resp" name="hetero_resp" long_name="Heterotrophic respiration" unit="gC/m^2/s" axis_ref="veget"/>
+    <field id="growth_resp" name="growth_resp" long_name="Growth respiration" unit="gC/m^2/s" axis_ref="veget"/>
+    <field id="precisol" name="precisol" long_name="Throughfall" unit="mm/d" axis_ref="veget"/>
+    <field id="drysoil_frac" name="drysoil_frac" long_name="Fraction of visibly dry soil" unit="1"/>
+    <field id="evapot" name="evapot" long_name="Potential evaporation" unit="mm/d"/>
+    <field id="evapot_corr" name="evapot_corr" long_name="Potential evaporation" unit="mm/d"/>
+    <field id="swnet" name="swnet" long_name="Net solar radiation" unit="W/m^2"/>
+    <field id="swdown" name="swdown" long_name="Incident solar radiation" unit="W/m^2"/>
+    <field id="lwdown" name="lwdown" long_name="Absorbed downward longwave radiation" unit="W/m^2"/>
+    <field id="lwnet" name="lwnet" long_name="Net surface longwave radiation" unit="W/m^2"/>
+    <field id="fastr" name="fastr" long_name="Fast flow reservoir" unit="kg/m^2"/>
+    <field id="slowr" name="slowr" long_name="Slow flow reservoir" unit="kg/m^2"/>
+    <field id="streamr" name="streamr" long_name="Stream flow reservoir" unit="kg/m^2"/>
+    <field id="lakevol" name="lakevol" long_name="Volume in lake reservoir" unit="kg/m^2"/>
+    <field id="pondr" name="pondr" long_name="Ponds reservoir" unit="kg/m^2"/>
+    <field id="swampmap" name="swampmap" long_name="Map of swamps" unit="m^2" operation="once"/>
+    <field id="irrigation" name="irrigation" long_name="Net irrigation" unit="mm/d"/>
+    <field id="netirrig" name="netirrig" long_name="Net irrigation requirement" unit="mm/d"/>
+    <field id="irrigmap" name="irrigmap" long_name="Map of irrigated surfaces" unit="m^2" operation="once"/>
+    <field id="floodmap" name="floodmap" long_name="Map of floodplains" unit="m^2" operation="once"/>
+    <field id="floodh" name="floodh" long_name="Floodplains height" unit="mm"/>
+    <field id="floodr" name="floodr" long_name="Floodplains reservoir" unit="kg/m^2"/>
+    <field id="floodout" name="floodout" long_name="Flow out of floodplains" unit="mm/d"/>
+    <field id="TotWater" name="TotWater" long_name="Total amount of water at end of time step" unit="mm/d"/>
+    <field id="TotWaterFlux" name="TotWater" long_name="Total water flux" unit="mm/d"/>
+    <field id="evapflo" name="evapflo" long_name="Floodplains evaporation" unit="mm/d"/>
+    <field id="k_litt" name="k_litt" long_name="Litter cond" unit="mm/d"/>
+    <field id="beta" name="beta" long_name="Beta Function" unit="1"/>
+    <field id="raero" name="raero" long_name="Aerodynamic resistance" unit="s/m"/>
+    <field id="Wind" name="Wind" long_name="Wind speed" unit="m/s"/>
+    <field id="qsatt" name="qsatt" long_name="Surface saturated humidity" unit="g/g"/>
+    <field id="vbeta1" name="vbeta1" long_name="Beta for sublimation" unit="1"/>
+    <field id="vbeta4" name="vbeta4" long_name="Beta for bare soil" unit="1"/>
+    <field id="vbeta5" name="vbeta5" long_name="Beta for floodplains" unit="1"/>
+    <field id="vbetaco2" name="vbetaco2" long_name="beta for CO2" unit="mm/d" axis_ref="veget"/>
+    <field id="humrel" name="humrel" long_name="Soil moisture stress" unit="-" axis_ref="veget"/>
+    <field id="cimean" name="cimean" long_name="Stomatal CO2 concentation" unit="mmole/m2/s" axis_ref="veget"/>
+    <field id="vbeta3" name="vbeta3" long_name="Beta for Transpiration" unit="mm/d" axis_ref="veget"/>
+    <field id="rveget" name="rveget" long_name="Canopy resistance" unit="s/m" axis_ref="veget"/>
+    <field id="rsol" name="rsol" long_name="Soil resistance" unit="s/m"/>
+    <field id="vbeta2" name="vbeta2" long_name="Beta for Interception loss" unit="mm/d" axis_ref="veget"/>
+    <field id="qsintmax" name="qsintmax" long_name="Maximum Interception capacity" unit="Kg/m^2" axis_ref="veget"/>
+    <field id="mrso" name="mrso" long_name="Total Soil Moisture Content" unit="kg m-2"/>
+    <field id="mrros" name="mrros" long_name="Surface Runoff" unit="kg m-2 s-1"/>
+    <field id="prveg" name="prveg" long_name="Precipitation onto Canopy" unit="kg m-2 s-1"/>
+    <field id="evspsblveg" name="evspsblveg" long_name="Evaporation from Canopy" unit="kg m-2 s-1"/>
+    <field id="evspsblsoi" name="evspsblsoi" long_name="Water Evaporation from Soil" unit="kg m-2 s-1"/>
+    <field id="tran" name="tran" long_name="Transpiration" unit="kg m-2 s-1"/>
+    <field id="treeFrac" name="treeFrac" long_name="Tree Cover Fraction" unit="%"/>
+    <field id="grassFrac" name="grassFrac" long_name="Natural Grass Fraction" unit="%"/>
+    <field id="cropFrac" name="cropFrac" long_name="Crop Fraction" unit="%"/>
+    <field id="baresoilFrac" name="baresoilFrac" long_name="Bare Soil Fraction" unit="%"/>
+    <field id="residualFrac" name="residualFrac" long_name="Fraction of Grid Cell that is Land but Neither Vegetation-Covered nor Bare Soil" unit="%"/>
+    <field id="PAR" name="PAR" long_name="PAR" unit="umol phot/m^2/s"/>
+    <field id="PARsun" name="PARsun" long_name="Sunlit Leaf PAR" unit="umol phot/m^2/s" axis_ref="veget"/>
+    <field id="PARsh" name="PARsh" long_name="Shaded Leaf Area PAR" unit="umol phot/m^2/s" axis_ref="veget"/>
+    <field id="laisun" name="laisun" long_name="Sunlit Leaf Area Index" unit="1" axis_ref="veget"/>
+    <field id="laish" name="laish" long_name="Shaded Leaf Area Index" unit="1" axis_ref="veget"/>
+    <field id="Fdf" name="Fdf" long_name="Fdf" unit="1"/>
+    <field id="PARsuntab" name="PARsuntab" long_name="Sunlit Leaf PAR" unit="umol phot/m^2/s" axis_ref="laiax"/>
+    <field id="PARshtab" name="PARshtab" long_name="Shaded Leaf Area PAR" unit="umol phot/m^2/s" axis_ref="laiax"/>
+    <field id="Sinang" name="Sinang" long_name="Sinang" unit="1"/>
+    <field id="PARdf" name="PARdf" long_name="PARdf" unit="1"/>
+    <field id="PARdr" name="PARdr" long_name="PARdr" unit="1"/>
+    <field id="Trans" name="Trans" long_name="Trans" unit="1"/>
+    <field id="Day" name="Day" long_name="Day" unit="1"/>
+    <field id="Year_length" name="Year_length" long_name="Year_length" unit="1"/>
+    <field id="flx_fertil_no" name="flx_fertil_no" long_name="flx_fertil_no" unit="ngN/m^2/s" axis_ref="veget"/>
+    <field id="CRF" name="CRF" long_name="CRF" unit="1"/>
+    <field id="flx_co2_bbg_year" name="flx_co2_bbg_year" long_name="flx_co2_bbg_year" unit="kgC/m^2/yr" operation="once"/>
+    <field id="N_qt_WRICE_year" name="N_qt_WRICE_year" long_name="N_qt_WRICE_year" unit="kgN/yr" operation="once"/>
+    <field id="N_qt_OTHER_year" name="N_qt_OTHER_year" long_name="N_qt_OTHER_year" unit="kgN/yr" operation="once"/>
+    <field id="ptnlev1" name="ptnlev1" long_name="ptnlev1" unit="K"/>
+    <field id="flx_iso" name="flx_iso" long_name="flx_iso" unit="kgC/m^2/s"/>
+    <field id="flx_mono" name="flx_mono" long_name="flx_mono" unit="kgC/m^2/s"/>
+    <field id="flx_ORVOC" name="flx_ORVOC" long_name="flx_ORVOC" unit="kgC/m^2/s"/>
+    <field id="flx_MBO" name="flx_MBO" long_name="flx_MBO" unit="kgC/m^2/s"/>
+    <field id="flx_methanol" name="flx_methanol" long_name="flx_methanol" unit="kgC/m^2/s"/>
+    <field id="flx_acetone" name="flx_acetone" long_name="flx_acetone" unit="kgC/m^2/s"/>
+    <field id="flx_acetal" name="flx_acetal" long_name="flx_acetal" unit="kgC/m^2/s"/>
+    <field id="flx_formal" name="flx_formal" long_name="flx_formal" unit="kgC/m^2/s"/>
+    <field id="flx_acetic" name="flx_acetic" long_name="flx_acetic" unit="kgC/m^2/s"/>
+    <field id="flx_formic" name="flx_formic" long_name="flx_formic" unit="kgC/m^2/s"/>
+    <field id="flx_no_soil" name="flx_no_soil" long_name="flx_no_soil" unit="ngN/m^2/s"/>
+    <field id="flx_no" name="flx_no" long_name="flx_no" unit="ngN/m^2/s"/>
+
+    <!-- ALMA -->
+    <field id="Qg" name="Qg" long_name="Ground heat flux" unit="W/m^2"/>
+    <field id="Qf" name="Qf" long_name="Energy of fusion" unit="W/m^2"/>
+    <field id="Qv" name="Qv" long_name="Energy of sublimation" unit="W/m^2"/>
+    <field id="DelSurfHeat" name="DelSurfHeat" long_name="Change in surface layer heat" unit="J/m^2" operation="accumulate"/>
+    <field id="DelColdCont" name="DelColdCont" long_name="Change in snow surface layer cold content" unit="J/m^2" operation="accumulate"/>
+    <field id="snowf_alma" name="Snowf" long_name="Snowfall rate" unit="kg/m^2/s"/>
+    <field id="rain_alma" name="Rainf" long_name="Rainfall rate" unit="kg/m^2/s"/>
+    <field id="evap_alma" name="evap_alma" long_name="Total Evapotranspiration" unit="kg/m^2/s"/>
+    <field id="Qs" name="Qs" long_name="Surface runoff" unit="kg/m^2/s"/>
+    <field id="Qsb" name="Qsb" long_name="Sub-surface runoff" unit="kg/m^2/s"/>
+    <field id="Qsm" name="Qsm" long_name="Snowmelt" unit="kg/m^2/s"/>
+    <field id="DelSoilMoist" name="DelSoilMoist" long_name="Change in soil moisture" unit="kg/m^2" operation="accumulate"/>
+    <field id="DelSurfStor" name="DelSurfStor" long_name="Change in Surface Water Storage" unit="kg/m^2" operation="accumulate"/>
+    <field id="DelIntercept" name="DelIntercept" long_name="Change in interception storage" unit="kg/m^2" operation="accumulate"/>
+    <field id="DelSWE" name="DelSWE" long_name="Change in Snow Water Equivalent" unit="kg/m^2" operation="accumulate"/>
+    <field id="irrigation_alma" name="Qirrig" long_name="Irrigation" unit="kg/m^2/s"/>
+    <field id="netirrig_alma" name="Qirrig_req" long_name="Irrigation requirement" unit="kg/m^2/s"/>
+    <field id="PotSurfT" name="PotSurfT" long_name="Potential (Unstressed) surface temperature" unit="K"/>
+    <field id="albedo_alma" name="Albedo" long_name="Albedo" unit="1"/>
+    <field id="SurfStor" name="SurfStor" long_name="Surface Water Storage" unit="kg/m^2"/>
+    <field id="SoilMoist" name="SoilMoist" long_name="3D average layer soil moisture" unit="kg/m^2" axis_ref="solay"/>
+    <field id="RootMoist" name="RootMoist" long_name="Root zone soil water" unit="kg/m^2"/>
+    <field id="SoilWet" name="SoilWet" long_name="Total soil wetness" unit="-"/>
+    <field id="evapot_corr_alma" name="PotEvap" long_name="Potential evapotranspiration" unit="kg/m^2/s"/>
+    <field id="evapot_alma" name="PotEvapOld" long_name="Potential evapotranspiration old method" unit="kg/m^2/s"/>
+    <field id="ECanop" name="ECanop" long_name="Interception evaporation" unit="kg/m^2/s"/>
+    <field id="TVeg" name="TVeg" long_name="Transpiration" unit="kg/m^2/s"/>
+    <field id="vevapnu_alma" name="ESoil" long_name="Bare soil evaporation" unit="kg/m^2/s"/>
+    <field id="evapflo_alma" name="EWater" long_name="Floodplains evaporation" unit="kg/m^2/s"/>
+    <field id="SubSnow" name="SubSnow" long_name="Snow sublimation" unit="kg/m^2/s"/>
+    <field id="ACond" name="ACond" long_name="Aerodynamic conductance" unit="m/s"/>
+    <field id="SAlbedo" name="SAlbedo" long_name="Snow albedo" unit="1"/>
+    <field id="SnowDepth" name="SnowDepth" long_name="3D snow depth" unit="m"/>
+    <field id="moistc_1" name="moistc_1" long_name="Soil Moisture profile for soil type 1" unit="m3/m3" axis_ref="solay"/>
+    <field id="moistc_2" name="moistc_2" long_name="Soil Moisture profile for soil type 2" unit="m3/m3" axis_ref="solay"/>
+    <field id="moistc_3" name="moistc_3" long_name="Soil Moisture profile for soil type 3" unit="m3/m3" axis_ref="solay"/>
+    <field id="kfactroot_1" name="kfactroot_1" long_name="Root fraction profile for soil type 1" unit="%" axis_ref="solay"/>
+    <field id="kfactroot_2" name="kfactroot_2" long_name="Root fraction profile for soil type 2" unit="%" axis_ref="solay"/>
+    <field id="kfactroot_3" name="kfactroot_3" long_name="Root fraction profile for soil type 3" unit="%" axis_ref="solay"/>
+    <field id="vegetsoil_1" name="vegetsoil_1" long_name="Fraction of vegetation on soil type 1" unit="%" axis_ref="veget"/>
+    <field id="vegetsoil_2" name="vegetsoil_2" long_name="Fraction of vegetation on soil type 2" unit="%" axis_ref="veget"/>
+    <field id="vegetsoil_3" name="vegetsoil_3" long_name="Fraction of vegetation on soil type 3" unit="%" axis_ref="veget"/>
+  </field_group>
+
+
+  <!-- Definition of all variables in stomate -->
+  <field_group id="stomate">
+    <field id="T2M_MONTH" name="T2M_MONTH" long_name="Monthly 2 m temperature" unit="K"/>
+    <field id="T2M_WEEK" name="T2M_WEEK" long_name="Weekly 2 m temperature" unit="K"/>
+    <field id="HET_RESP" name="HET_RESP" long_name="heterotr. resp. from ground" unit="gC/m^2 tot/pft/day" axis_ref="PFT"/>
+    <field id="FIREFRAC" name="FIREFRAC" long_name="Fire fraction on ground " unit="1/day" axis_ref="PFT"/>
+    <field id="CO2FLUX" name="CO2FLUX" long_name="CO2 flux " unit="gC/m^2/pft/mth" axis_ref="PFT"/>
+    <field id="CO2_FIRE" name="CO2_FIRE" long_name="Output CO2 flux from fire " unit="gC/day/m^2/pft" axis_ref="PFT"/>
+    <field id="CO2_TAKEN" name="CO2_TAKEN" long_name="CO2 taken from atmosphere for initiate growth " unit="gC/day/m^2/pft" axis_ref="PFT"/>
+    <field id="LAI" name="LAI" long_name="Leaf Area Index " unit="-" axis_ref="PFT"/>
+    <field id="VEGET_MAX" name="VEGET_MAX" long_name="Maximum vegetation fraction (LAI -&gt; infinity) " unit="-" axis_ref="PFT"/>
+    <field id="NPP_STOMATE" name="NPP" long_name="Net primary productivity " unit="gC/day/(m^2 tot)" axis_ref="PFT"/>
+    <field id="GPP" name="GPP" long_name="Gross primary productivity " unit="gC/day/m^2" axis_ref="PFT"/>
+    <field id="LEAF_M" name="LEAF_M" long_name="Leaf mass" unit="gC/m^2 " axis_ref="PFT"/>
+    <field id="SAP_M_AB" name="SAP_M_AB" long_name="Sap mass above ground" unit="gC/m^2" axis_ref="PFT"/>
+    <field id="SAP_M_BE" name="SAP_M_BE" long_name="Sap mass below ground" unit="gC/m^2" axis_ref="PFT"/>
+    <field id="HEART_M_AB" name="HEART_M_AB" long_name="Heartwood mass above ground" unit="gC/m^2" axis_ref="PFT"/>
+    <field id="HEART_M_BE" name="HEART_M_BE" long_name="Heartwood mass below ground" unit="gC/m^2" axis_ref="PFT"/>
+    <field id="ROOT_M" name="ROOT_M" long_name="Root mass" unit="gC/m^2" axis_ref="PFT"/>
+    <field id="FRUIT_M" name="FRUIT_M" long_name="Fruit mass" unit="gC/m^2" axis_ref="PFT"/>
+    <field id="RESERVE_M" name="RESERVE_M" long_name="Carbohydrate reserve mass" unit="gC/m^2" axis_ref="PFT"/>
+    <field id="MAINT_RESP" name="MAINT_RESP" long_name="Maintenance respiration" unit="gC/m^2/day" axis_ref="PFT"/>
+    <field id="GROWTH_RESP" name="GROWTH_RESP" long_name="Growth respiration" unit="gC/m^2/day" axis_ref="PFT"/>
+    <field id="IND" name="IND" long_name="Density of individuals" unit="1/ m^2" axis_ref="PFT"/>
+    <field id="ADAPTATION" name="ADAPTATION" long_name="Adaptation to climate (DGVM)" unit="-" axis_ref="PFT"/>
+    <field id="REGENERATION" name="REGENERATION" long_name="Probability from regenerative (DGVM)" unit="-" axis_ref="PFT"/>
+    <field id="CN_IND" name="CN_IND" long_name="crown area of individuals" unit="m^2" axis_ref="PFT"/>
+    <field id="WOODMASS_IND" name="WOODMASS_IND" long_name="Woodmass of individuals" unit="gC/pft" axis_ref="PFT"/>
+    <field id="TOTAL_M" name="TOTAL_M" long_name="Total living biomass" unit="gC/m^2/pft" axis_ref="PFT"/>
+    <field id="MOISTRESS" name="MOISTRESS" long_name="weekly moisture stress" unit="-" axis_ref="PFT"/>
+    <field id="TOTAL_TURN" name="TOTAL_TURN" long_name="total turnover rate" unit="gC/m^2/day " axis_ref="PFT"/>
+    <field id="LEAF_TURN" name="LEAF_TURN" long_name="Leaf turnover" unit="gC/m^2/day " axis_ref="PFT"/>
+    <field id="SAP_AB_TURN" name="SAP_AB_TURN" long_name="Sap turnover above" unit="gC/m^2/day " axis_ref="PFT"/>
+    <field id="ROOT_TURN" name="ROOT_TURN" long_name="Root turnover" unit="gC/m^2/day " axis_ref="PFT"/>
+    <field id="FRUIT_TURN" name="FRUIT_TURN" long_name="Fruit turnover" unit="gC/m^2/day" axis_ref="PFT"/>
+    <field id="TOTAL_BM_LITTER" name="TOTAL_BM_LITTER" long_name="total conversion of biomass to litter" unit="gC/m^2/day" axis_ref="PFT"/>
+    <field id="LEAF_BM_LITTER" name="LEAF_BM_LITTER" long_name="Leaf death" unit="gC/m^2/day" axis_ref="PFT"/>
+    <field id="SAP_AB_BM_LITTER" name="SAP_AB_BM_LITTER" long_name="Sap death above ground" unit="gC/m^2/day" axis_ref="PFT"/>
+    <field id="SAP_BE_BM_LITTER" name="SAP_BE_BM_LITTER" long_name="Sap death below ground" unit="gC/m^2/day" axis_ref="PFT"/>
+    <field id="HEART_AB_BM_LITTER" name="HEART_AB_BM_LITTER" long_name="Heartwood death above ground" unit="gC/m^2/day" axis_ref="PFT"/>
+    <field id="HEART_BE_BM_LITTER" name="HEART_BE_BM_LITTER" long_name="Heartwood death below ground" unit="gC/m^2/day" axis_ref="PFT"/>
+    <field id="ROOT_BM_LITTER" name="ROOT_BM_LITTER" long_name="Root death" unit="gC/m^2/day" axis_ref="PFT"/>
+    <field id="FRUIT_BM_LITTER" name="FRUIT_BM_LITTER" long_name="Fruit death" unit="gC/m^2/day" axis_ref="PFT"/>
+    <field id="RESERVE_BM_LITTER" name="RESERVE_BM_LITTER" long_name="Carbohydrate reserve death" unit="gC/m^2/day" axis_ref="PFT"/>
+    <field id="LITTER_STR_AB" name="LITTER_STR_AB" long_name="structural litter above ground" unit="gC/m^2/pft" axis_ref="PFT"/>
+    <field id="LITTER_MET_AB" name="LITTER_MET_AB" long_name="metabolic litter above ground" unit="gC/m^2/pft" axis_ref="PFT"/>
+    <field id="LITTER_STR_BE" name="LITTER_STR_BE" long_name="structural litter below ground" unit="gC/m^2/pft" axis_ref="PFT"/>
+    <field id="LITTER_MET_BE" name="LITTER_MET_BE" long_name="metabolic litter below ground" unit="gC/m^2/pft" axis_ref="PFT"/>
+    <field id="DEADLEAF_COVER" name="DEADLEAF_COVER" long_name="fraction of soil covered by dead leaves" unit="-"/>
+    <field id="TOTAL_SOIL_CARB" name="TOTAL_SOIL_CARB" long_name="total soil and litter carbon" unit="gC/m^2" axis_ref="PFT"/>
+    <field id="CARBON_ACTIVE" name="CARBON_ACTIVE" long_name="active soil carbon in ground " unit="gC/m^2/pft" axis_ref="PFT"/>
+    <field id="CARBON_SLOW" name="CARBON_SLOW" long_name="slow soil carbon in ground" unit="gC/m^2/pft" axis_ref="PFT"/>
+    <field id="CARBON_PASSIVE" name="CARBON_PASSIVE" long_name="passive soil carbon in ground" unit="gC/m^2/pft" axis_ref="PFT"/>
+    <field id="LITTERHUM" name="LITTERHUM" long_name="Litter humidity" unit="-"/>
+    <field id="BM_ALLOC_LEAF" name="BM_ALLOC_LEAF" long_name="biomass allocated to leaves" unit="gC/m**2/pft/dt" axis_ref="PFT"/>
+    <field id="BM_ALLOC_SAP_AB" name="BM_ALLOC_SAP_AB" long_name="biomass allocated to sapwood above ground" unit="gC/m**2/pft/dt" axis_ref="PFT"/>
+    <field id="BM_ALLOC_SAP_BE" name="BM_ALLOC_SAP_BE" long_name="biomass allocated to sapwood below ground" unit="gC/m**2/pft/dt" axis_ref="PFT"/>
+    <field id="BM_ALLOC_ROOT" name="BM_ALLOC_ROOT" long_name="biomass allocated to roots" unit="gC/m**2/pft/dt" axis_ref="PFT"/>
+    <field id="BM_ALLOC_FRUIT" name="BM_ALLOC_FRUIT" long_name="biomass allocated to fruits" unit="gC/m**2/pft/dt" axis_ref="PFT"/>
+    <field id="BM_ALLOC_RES" name="BM_ALLOC_RES" long_name="biomass allocated to carbohydrate reserve" unit="gC/m**2/pft/dt" axis_ref="PFT"/>
+    <field id="HERBIVORES" name="HERBIVORES" long_name="time constant of herbivore activity" unit="days" axis_ref="PFT"/>
+    <field id="TURNOVER_TIME" name="TURNOVER_TIME" long_name="turnover time for grass leaves" unit="days" axis_ref="PFT"/>
+    <field id="PROD10" name="PROD10" long_name="10 year wood product pool" unit="gC/m**2" axis_ref="P11"/>
+    <field id="FLUX10" name="FLUX10" long_name="annual flux for each 10 year wood product pool" unit="gC/m**2/yr" axis_ref="P10"/>
+    <field id="PROD100" name="PROD100" long_name="100 year wood product pool" unit="gC/m**2" axis_ref="P101"/>
+    <field id="FLUX100" name="FLUX100" long_name="annual flux for each 100 year wood product pool" unit="gC/m**2/yr" axis_ref="P100"/>
+    <field id="CONVFLUX" name="CONVFLUX" long_name="annual release right after deforestation" unit="gC/m**2/day"/>
+    <field id="CFLUX_PROD10" name="CFLUX_PROD10" long_name="annual release from all 10 year wood product pools" unit="gC/m**2/day"/>
+    <field id="CFLUX_PROD100" name="CFLUX_PROD100" long_name="annual release from all 100 year wood product pools" unit="gC/m**2/day"/>
+    <field id="HARVEST_ABOVE" name="HARVEST_ABOVE" long_name="annual release product after harvest" unit="gC/m**2/day"/>
+    <field id="RESOLUTION_X" name="RESOLUTION_X" long_name="E-W resolution" unit="m" operation="once"/>
+    <field id="RESOLUTION_Y" name="RESOLUTION_Y" long_name="N-S resolution" unit="m" operation="once"/>
+    <field id="CONTFRAC_STOMATE" name="CONTFRAC" long_name="Continental fraction" unit="1" operation="once"/>
+    <field id="VCMAX" name="VCMAX" long_name="Maximum rate of carboxylation" unit="-" axis_ref="PFT"/>
+    <field id="LEAF_AGE" name="LEAF_AGE" long_name="leaf age" unit="days" axis_ref="PFT"/>
+    <field id="MORTALITY" name="MORTALITY" long_name="Fraction of trees that dies (gap)" unit="1/day" axis_ref="PFT"/>
+    <field id="FIREDEATH" name="FIREDEATH" long_name="Fraction of plants killed by fire" unit="1/day" axis_ref="PFT"/>
+    <field id="IND_ESTAB" name="IND_ESTAB" long_name="Density of newly established saplings" unit="1/day" axis_ref="PFT"/>
+    <field id="ESTABTREE" name="ESTABTREE" long_name="Rate of tree establishement" unit="1/day"/>
+    <field id="ESTABGRASS" name="ESTABGRASS" long_name="Rate of grass establishement" unit="1/day"/>
+    <field id="LIGHT_DEATH" name="LIGHT_DEATH" long_name="Fraction of plants that dies (light competition)" unit="1/day" axis_ref="PFT"/>
+    <field id="AGE" name="AGE" long_name="age" unit="years" axis_ref="PFT"/>
+    <field id="HEIGHT" name="HEIGHT" long_name="height" unit="m" axis_ref="PFT"/>
+    <field id="WHEN_GROWTHINIT" name="WHEN_GROWTHINIT" long_name="Time elapsed from season beginning" unit="d" axis_ref="PFT"/>
+    <field id="PFTPRESENT" name="PFTPRESENT" long_name="PFT exists" unit="d" axis_ref="PFT"/>
+    <field id="GDD_MIDWINTER" name="GDD_MIDWINTER" long_name="Growing degree days, since midwinter" unit="degK" axis_ref="PFT"/>
+    <field id="GDD_M5_DORMANCE" name="GDD_M5_DORMANCE" long_name="Growing degree days threshold" unit="degK" axis_ref="PFT"/>
+    <field id="NCD_DORMANCE" name="NCD_DORMANCE" long_name="Number of chilling days, since leaves were lost" unit="d" axis_ref="PFT"/>
+    <field id="ALLOW_INITPHENO" name="ALLOW_INITPHENO" long_name="Allow to declare beginning of the growing season" unit="-" axis_ref="PFT"/>
+    <field id="BEGIN_LEAVES" name="BEGIN_LEAVES" long_name="Signal to start putting leaves on" unit="-" axis_ref="PFT"/>
+    <field id="T2M_LONGTERM" name="T2M_LONGTERM" long_name="Longterm 2 m temperature" unit="K"/>
+    <field id="BLACK_CARBON" name="BLACK_CARBON" long_name="black carbon on average total ground" unit="gC/m^2 tot"/>
+    <field id="FIREINDEX" name="FIREINDEX" long_name="Fire index on ground" unit="-" axis_ref="PFT"/>
+    <field id="cVeg" name="cVeg" long_name="Carbon in Vegetation" unit="kg C m-2"/>
+    <field id="cLitter" name="cLitter" long_name="Carbon in Litter Pool" unit="kg C m-2"/>
+    <field id="cSoil" name="cSoil" long_name="Carbon in Soil Pool" unit="kg C m-2"/>
+    <field id="cProduct" name="cProduct" long_name="Carbon in Products of Land Use Change" unit="kg C m-2"/>
+    <field id="cMassVariation" name="cMassVariation" long_name="Terrestrial Carbon Mass Variation" unit="kg C m-2 s-1"/>
+    <field id="lai_ipcc" name="lai" long_name="Leaf Area Fraction" unit="1"/>
+    <field id="gpp_ipcc" name="gpp" long_name="Gross Primary Production" unit="kg C m-2 s-1"/>
+    <field id="ra" name="ra" long_name="Autotrophic Respiration" unit="kg C m-2 s-1"/>
+    <field id="npp_ipcc" name="npp" long_name="Net Primary Production" unit="kg C m-2 s-1"/>
+    <field id="rh" name="rh" long_name="Heterotrophic Respiration" unit="kg C m-2 s-1"/>
+    <field id="fFire" name="fFire" long_name="CO2 Emission from Fire" unit="kg C m-2 s-1"/>
+    <field id="fHarvest" name="fHarvest" long_name="CO2 Flux to Atmosphere from Crop Harvesting" unit="kg C m-2 s-1"/>
+    <field id="fLuc" name="fLuc" long_name="CO2 Flux to Atmosphere from Land Use Change" unit="kg C m-2 s-1"/>
+    <field id="nbp" name="nbp" long_name="Net Biospheric Production" unit="kg C m-2 s-1"/>
+    <field id="fVegLitter" name="fVegLitter" long_name="Total Carbon Flux from Vegetation to Litter" unit="kg C m-2 s-1"/>
+    <field id="fLitterSoil" name="fLitterSoil" long_name="Total Carbon Flux from Litter to Soil" unit="kg C m-2 s-1"/>
+    <field id="cLeaf" name="cLeaf" long_name="Carbon in Leaves" unit="kg C m-2"/>
+    <field id="cWood" name="cWood" long_name="Carbon in Wood" unit="kg C m-2"/>
+    <field id="cRoot" name="cRoot" long_name="Carbon in Roots" unit="kg C m-2"/>
+    <field id="cMisc" name="cMisc" long_name="Carbon in Other Living Compartments" unit="kg C m-2"/>
+    <field id="cLitterAbove" name="cLitterAbove" long_name="Carbon in Above-Ground Litter" unit="kg C m-2"/>
+    <field id="cLitterBelow" name="cLitterBelow" long_name="Carbon in Below-Ground Litter" unit="kg C m-2"/>
+    <field id="cSoilFast" name="cSoilFast" long_name="Carbon in Fast Soil Pool" unit="kg C m-2"/>
+    <field id="cSoilMedium" name="cSoilMedium" long_name="Carbon in Medium Soil Pool" unit="kg C m-2"/>
+    <field id="cSoilSlow" name="cSoilSlow" long_name="Carbon in Slow Soil Pool" unit="kg C m-2"/>
+    <field id="landCoverFrac" name="landCoverFrac" long_name="Fractional Land Cover of PFT" unit="%" axis_ref="PFT"/>
+    <field id="treeFracPrimDec" name="treeFracPrimDec" long_name="Total Primary Deciduous Tree Cover Fraction" unit="%"/>
+    <field id="treeFracPrimEver" name="treeFracPrimEver" long_name="Total Primary Evergreen Tree Cover Fraction" unit="%"/>
+    <field id="c3PftFrac" name="c3PftFrac" long_name="Total C3 PFT Cover Fraction" unit="%"/>
+    <field id="c4PftFrac" name="c4PftFrac" long_name="Total C4 PFT Cover Fraction" unit="%"/>
+    <field id="rGrowth" name="rGrowth" long_name="Growth Autotrophic Respiration" unit="kg C m-2 s-1"/>
+    <field id="rMaint" name="rMaint" long_name="Maintenance Autotrophic Respiration" unit="kg C m-2 s-1"/>
+    <field id="nppLeaf" name="nppLeaf" long_name="CO2 Flux from Atmosphere due to NPP Allocation to Leaf" unit="kg C m-2 s-1"/>
+    <field id="nppWood" name="nppWood" long_name="CO2 Flux from Atmosphere due to NPP Allocation to Wood" unit="kg C m-2 s-1"/>
+    <field id="nppRoot" name="nppRoot" long_name="CO2 Flux from Atmosphere due to NPP Allocation to Root" unit="kg C m-2 s-1"/>
+    <field id="nep" name="nep" long_name="Net Carbon Mass Flux out of Atmophere due to Net Ecosystem Productivity." unit="kg C m-2 s-1"/>
+  </field_group>
+</field_definition>
Index: branches/publications/ORCHIDEE_CAN_NHA/src_xml/file_def_orchidee.xml
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_xml/file_def_orchidee.xml	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_xml/file_def_orchidee.xml	(revision 7236)
@@ -0,0 +1,630 @@
+<!-- =========================================================================================================== -->
+<!-- file_def_orchidee.xml : Definition of output files                                                          -->
+
+<!-- Definition of variables or groups included in the different files                                           -->
+<!-- Change this file by adding the files and/or variables you want to produce                                   -->
+<!-- Only variables and groups existing in field_def_orchidee.xml can be used                                    -->
+<!-- =========================================================================================================== -->
+
+<file_definition type="one_file" par_access="collective" enabled=".TRUE." min_digits="4">
+
+  <!-- Definition of files with sechiba diagnostics -->
+
+  <!-- Sechiba file 1 -->
+  <file id="sechiba1" name="sechiba_history_xios" output_level="11" output_freq="1800s" enabled=".TRUE.">
+    <!-- level 1 -->
+    <field field_ref="Areas" level="1"/>
+    <field field_ref="LandPoints" level="1"/>
+    <field field_ref="Contfrac" level="1"/>
+    <field field_ref="evap" level="1"/>
+    <field field_ref="coastalflow" level="1"/>
+    <field field_ref="riverflow" level="1"/>
+    <field field_ref="temp_sol_C" level="1"/>
+    <field field_ref="rain" level="1"/>
+    <field field_ref="snowf" level="1"/>
+    <field field_ref="netrad" level="1"/>
+    <field field_ref="lai" level="1"/>
+    <field field_ref="reinf_slope" level="1"/>
+    <field field_ref="soilindex" level="1"/>
+    <field field_ref="basinmap" level="1"/>
+    <field field_ref="nbrivers" level="1"/>
+    <field field_ref="npp" level="1"/>
+    <!-- level 2 -->
+    <field field_ref="subli" level="2"/>
+    <field field_ref="runoff" level="2"/>
+    <field field_ref="drainage" level="2"/>
+    <field field_ref="riversret" level="2"/>
+    <field field_ref="hydrographs" level="2"/>
+    <field field_ref="evapnu" level="2"/>
+    <field field_ref="evapnu_soil" level="2"/>
+    <field field_ref="drainage_soil" level="2"/>
+    <field field_ref="transpir_soil" level="2"/>
+    <field field_ref="runoff_soil" level="2"/>
+    <field field_ref="tair" level="2"/>
+    <field field_ref="qair" level="2"/>
+    <field field_ref="q2m" level="2"/>
+    <field field_ref="t2m" level="2"/>
+    <field field_ref="alb_vis" level="2"/>
+    <field field_ref="alb_nir" level="2"/>
+    <field field_ref="soilalb_vis" level="2"/>
+    <field field_ref="soilalb_nir" level="2"/>
+    <field field_ref="vegalb_vis" level="2"/>
+    <field field_ref="vegalb_nir" level="2"/>
+    <field field_ref="z0" level="2"/>
+    <field field_ref="roughheight" level="2"/>
+    <field field_ref="transpir" level="2"/>
+    <field field_ref="inter" level="2"/>
+    <!-- level 3 -->
+    <field field_ref="tsol_max" level="3"/>
+    <field field_ref="tsol_min" level="3"/>
+    <field field_ref="fluxsens" level="3"/>
+    <field field_ref="fluxlat" level="3"/>
+    <field field_ref="snow" level="3"/>
+    <field field_ref="snowage" level="3"/>
+    <field field_ref="snownobio" level="3"/>
+    <field field_ref="snownobioage" level="3"/>
+    <field field_ref="vegetfrac" level="3"/>
+    <field field_ref="maxvegetfrac" level="3"/>
+    <field field_ref="tot_bare_soil" level="3"/>
+    <field field_ref="nobiofrac" level="3"/>
+    <field field_ref="flood_frac" level="3"/>
+    <field field_ref="reinfiltration" level="3"/>
+    <field field_ref="frac_bare" level="3"/>
+    <field field_ref="soiltile" level="3"/>
+    <field field_ref="moistc_1" level="3"/>
+    <field field_ref="moistc_2" level="3"/>
+    <field field_ref="moistc_3" level="3"/>
+    <field field_ref="kfactroot_1" level="3"/>
+    <field field_ref="kfactroot_2" level="3"/>
+    <field field_ref="kfactroot_3" level="3"/>
+    <field field_ref="vegetsoil_1" level="3"/>
+    <field field_ref="vegetsoil_2" level="3"/>
+    <field field_ref="vegetsoil_3" level="3"/>
+    <!-- level 4 -->
+    <field field_ref="dss" level="4"/>
+    <field field_ref="gqsb" level="4"/>
+    <field field_ref="bqsb" level="4"/>
+    <field field_ref="humtot" level="4"/>
+    <field field_ref="humtot_soil" level="4"/>
+    <field field_ref="SWI" level="4"/>
+    <field field_ref="njsc" level="4"/>
+    <field field_ref="qsintveg" level="4"/>
+    <field field_ref="rstruct" level="4"/>
+    <field field_ref="gpp" level="4"/>
+    <field field_ref="nee" level="4"/>
+    <field field_ref="maint_resp" level="4"/>
+    <field field_ref="hetero_resp" level="4"/>
+    <field field_ref="growth_resp" level="4"/>
+    <field field_ref="precisol" level="4"/>
+    <field field_ref="drysoil_frac" level="4"/>
+    <field field_ref="evapot" level="4"/>
+    <field field_ref="evapot_corr" level="4"/>
+    <!-- level 5 -->
+    <field field_ref="swnet" level="5"/>
+    <field field_ref="swdown" level="5"/>
+    <field field_ref="lwdown" level="5"/>
+    <field field_ref="lwnet" level="5"/>
+    <!-- level 6 -->
+    <field field_ref="ptn" level="6"/>
+    <!-- level 7 -->
+    <field field_ref="fastr" level="7"/>
+    <field field_ref="slowr" level="7"/>
+    <field field_ref="streamr" level="7"/>
+    <field field_ref="lakevol" level="7"/>
+    <!-- level 8 -->
+    <field field_ref="pondr" level="8"/>
+    <field field_ref="swampmap" level="8"/>
+    <field field_ref="irrigation" level="8"/>
+    <field field_ref="netirrig" level="8"/>
+    <field field_ref="irrigmap" level="8"/>
+    <field field_ref="floodmap" level="8"/>
+    <field field_ref="floodh" level="8"/>
+    <field field_ref="floodr" level="8"/>
+    <field field_ref="floodout" level="8"/>
+    <field field_ref="evapflo" level="8"/>
+    <field field_ref="k_litt" level="8"/>
+    <field field_ref="beta" level="8"/>
+    <field field_ref="raero" level="8"/>
+    <field field_ref="cdrag" level="8"/>
+    <field field_ref="Wind" level="8"/>
+    <field field_ref="qsatt" level="8"/>
+    <field field_ref="vbeta1" level="8"/>
+    <field field_ref="vbeta4" level="8"/>
+    <field field_ref="vbeta5" level="8"/>
+    <field field_ref="vbetaco2" level="8"/>
+    <field field_ref="humrel" level="8"/>
+    <!-- level 10 -->
+    <field field_ref="cimean" level="10"/>
+    <field field_ref="vbeta3" level="10"/>
+    <field field_ref="rveget" level="10"/>
+    <field field_ref="rsol" level="10"/>
+    <field field_ref="vbeta2" level="10"/>
+    <field field_ref="qsintmax" level="10"/>
+    <!-- level 11 -->
+    <field field_ref="mrsos" level="11"/>
+    <field field_ref="mrso" level="11"/>
+    <field field_ref="mrros" level="11"/>
+    <field field_ref="mrro" level="11"/>
+    <field field_ref="prveg" level="11"/>
+    <field field_ref="evspsblveg" level="11"/>
+    <field field_ref="evspsblsoi" level="11"/>
+    <field field_ref="tran" level="11"/>
+    <field field_ref="treeFrac" level="11"/>
+    <field field_ref="grassFrac" level="11"/>
+    <field field_ref="cropFrac" level="11"/>
+    <field field_ref="baresoilFrac" level="11"/>
+    <field field_ref="residualFrac" level="11"/>
+    <field field_ref="PAR" level="11"/>
+    <field field_ref="PARsun" level="11"/>
+    <field field_ref="PARsh" level="11"/>
+    <field field_ref="laisun" level="11"/>
+    <field field_ref="laish" level="11"/>
+    <field field_ref="Fdf" level="11"/>
+    <field field_ref="PARsuntab" level="11"/>
+    <field field_ref="PARshtab" level="11"/>
+    <field field_ref="Sinang" level="11"/>
+    <field field_ref="PARdf" level="11"/>
+    <field field_ref="PARdr" level="11"/>
+    <field field_ref="Trans" level="11"/>
+    <field field_ref="Day" level="11"/>
+    <field field_ref="Year_length" level="11"/>
+    <field field_ref="flx_fertil_no" level="11"/>
+    <field field_ref="CRF" level="11"/>
+    <field field_ref="flx_co2_bbg_year" level="11"/>
+    <field field_ref="N_qt_WRICE_year" level="11"/>
+    <field field_ref="N_qt_OTHER_year" level="11"/>
+    <field field_ref="ptnlev1" level="11"/>
+    <field field_ref="flx_iso" level="11"/>
+    <field field_ref="flx_mono" level="11"/>
+    <field field_ref="flx_ORVOC" level="11"/>
+    <field field_ref="flx_MBO" level="11"/>
+    <field field_ref="flx_methanol" level="11"/>
+    <field field_ref="flx_acetone" level="11"/>
+    <field field_ref="flx_acetal" level="11"/>
+    <field field_ref="flx_formal" level="11"/>
+    <field field_ref="flx_acetic" level="11"/>
+    <field field_ref="flx_formic" level="11"/>
+    <field field_ref="flx_no_soil" level="11"/>
+    <field field_ref="flx_no" level="11"/>
+  </file>
+
+
+  <!-- Sechiba file 2 -->
+  <file id="sechiba2" name="sechiba_out_2_xios" output_level="10" output_freq="1800s" enabled=".TRUE.">
+    <!-- level 1 -->
+    <field field_ref="Areas" level="1"/>
+    <field field_ref="LandPoints" level="1"/>
+    <field field_ref="Contfrac" level="1"/>
+    <field field_ref="mrsos" level="1"/>
+    <field field_ref="mrro" level="1"/>
+    <field field_ref="ptn" level="1"/>
+    <!-- level 2 -->
+    <field field_ref="cdrag" level="2"/>
+    <field field_ref="soilalb_vis" level="2"/>
+    <field field_ref="soilalb_nir" level="2"/>
+    <field field_ref="vegalb_vis" level="2"/>
+    <field field_ref="vegalb_nir" level="2"/>
+    <field field_ref="z0" level="2"/>
+    <field field_ref="coastalflow" level="2"/>
+    <field field_ref="riverflow" level="2"/>
+    <field field_ref="tsol_rad" level="2"/>
+    <field field_ref="vevapnu" level="2"/>
+    <field field_ref="temp_sol_C" level="2"/>
+    <field field_ref="qsurf" level="2"/>
+    <field field_ref="albedo" level="2"/>
+    <field field_ref="fluxsens" level="2"/>
+    <field field_ref="fluxlat" level="2"/>
+    <field field_ref="emis" level="2"/>
+    <field field_ref="riversret" level="2"/>
+    <field field_ref="hydrographs" level="2"/>
+    <!-- level 3 -->
+    <field field_ref="evap" level="3"/>
+    <field field_ref="rain" level="3"/>
+    <field field_ref="snowf" level="3"/>
+    <field field_ref="netrad" level="3"/>
+    <field field_ref="lai" level="3"/>
+    <field field_ref="basinmap" level="3"/>
+    <field field_ref="nbrivers" level="3"/>
+    <field field_ref="moistc_1" level="3"/>
+    <field field_ref="moistc_2" level="3"/>
+    <field field_ref="moistc_3" level="3"/>
+    <!-- level 4 -->
+    <field field_ref="subli" level="4"/>
+    <field field_ref="runoff" level="4"/>
+    <field field_ref="drainage" level="4"/>
+    <field field_ref="tair" level="4"/>
+    <field field_ref="qair" level="4"/>
+    <field field_ref="q2m" level="4"/>
+    <field field_ref="t2m" level="4"/>
+    <field field_ref="alb_vis" level="4"/>
+    <field field_ref="alb_nir" level="4"/>
+    <field field_ref="roughheight" level="4"/>
+    <field field_ref="transpir" level="4"/>
+    <field field_ref="inter" level="4"/>
+    <field field_ref="evapnu_soil" level="4"/>
+    <field field_ref="drainage_soil" level="4"/>
+    <field field_ref="transpir_soil" level="4"/>
+    <field field_ref="runoff_soil" level="4"/>
+    <!-- level 5 -->
+    <field field_ref="tsol_max" level="5"/>
+    <field field_ref="tsol_min" level="5"/>
+    <field field_ref="snow" level="5"/>
+    <field field_ref="snowage" level="5"/>
+    <field field_ref="snownobio" level="5"/>
+    <field field_ref="snownobioage" level="5"/>
+    <field field_ref="vegetfrac" level="5"/>
+    <field field_ref="maxvegetfrac" level="5"/>
+    <field field_ref="nobiofrac" level="5"/>
+    <field field_ref="kfactroot_1" level="5"/>
+    <field field_ref="kfactroot_2" level="5"/>
+    <field field_ref="kfactroot_3" level="5"/>
+    <field field_ref="vegetsoil_1" level="5"/>
+    <field field_ref="vegetsoil_2" level="5"/>
+    <field field_ref="vegetsoil_3" level="5"/>
+    <!-- level 6 -->
+    <field field_ref="dss" level="6"/>
+    <field field_ref="gqsb" level="6"/>
+    <field field_ref="bqsb" level="6"/>
+    <field field_ref="humtot" level="6"/>
+    <field field_ref="humtot_soil" level="6"/>
+    <field field_ref="SWI" level="6"/>
+    <field field_ref="qsintveg" level="6"/>
+    <field field_ref="rstruct" level="6"/>
+    <field field_ref="gpp" level="6"/>
+    <field field_ref="nee" level="6"/>
+    <field field_ref="maint_resp" level="6"/>
+    <field field_ref="hetero_resp" level="6"/>
+    <field field_ref="growth_resp" level="6"/>
+    <field field_ref="npp" level="6"/>
+    <field field_ref="precisol" level="6"/>
+    <field field_ref="drysoil_frac" level="6"/>
+    <field field_ref="evapot" level="6"/>
+    <field field_ref="evapot_corr" level="6"/>
+    <!-- level 7 -->
+    <field field_ref="swnet" level="7"/>
+    <field field_ref="swdown" level="7"/>
+    <field field_ref="lwdown" level="7"/>
+    <field field_ref="lwnet" level="7"/>
+    <!-- level 8 -->
+    <field field_ref="fastr" level="8"/>
+    <field field_ref="slowr" level="8"/>
+    <field field_ref="streamr" level="8"/>
+    <field field_ref="floodr" level="8"/>
+    <field field_ref="floodh" level="8"/>
+    <field field_ref="pondr" level="8"/>
+    <field field_ref="lakevol" level="8"/>
+    <field field_ref="irrigation" level="8"/>
+    <field field_ref="netirrig" level="8"/>
+    <field field_ref="irrigmap" level="8"/>
+    <field field_ref="floodmap" level="8"/>
+    <field field_ref="swampmap" level="8"/>
+    <!-- level 9 -->
+    <field field_ref="beta" level="9"/>
+    <field field_ref="raero" level="9"/>
+    <field field_ref="Wind" level="9"/>
+    <field field_ref="qsatt" level="9"/>
+    <field field_ref="vbeta1" level="9"/>
+    <field field_ref="vbeta4" level="9"/>
+    <field field_ref="vbetaco2" level="9"/>
+    <field field_ref="vbeta5" level="9"/>
+    <field field_ref="reinf_slope" level="9"/>
+    <field field_ref="soilindex" level="9"/>
+    <field field_ref="humrel" level="9"/>
+    <!-- level 10 -->
+    <field field_ref="cimean" level="10"/>
+    <field field_ref="vbeta3" level="10"/>
+    <field field_ref="rveget" level="10"/>
+    <field field_ref="rsol" level="10"/>
+    <field field_ref="vbeta2" level="10"/>
+    <field field_ref="qsintmax" level="10"/>
+    <field field_ref="PAR" level="10"/>
+    <field field_ref="PARsun" level="10"/>
+    <field field_ref="PARsh" level="10"/>
+    <field field_ref="laisun" level="10"/>
+    <field field_ref="laish" level="10"/>
+    <field field_ref="Fdf" level="10"/>
+    <field field_ref="PARsuntab" level="10"/>
+    <field field_ref="PARshtab" level="10"/>
+    <field field_ref="Sinang" level="10"/>
+    <field field_ref="PARdf" level="10"/>
+    <field field_ref="PARdr" level="10"/>
+    <field field_ref="Trans" level="10"/>
+    <field field_ref="Day" level="10"/>
+    <field field_ref="Year_length" level="10"/>
+    <field field_ref="flx_fertil_no" level="10"/>
+    <field field_ref="CRF" level="10"/>
+    <field field_ref="flx_co2_bbg_year" level="10"/>
+    <field field_ref="N_qt_WRICE_year" level="10"/>
+    <field field_ref="N_qt_OTHER_year" level="10"/>
+    <field field_ref="ptnlev1" level="10"/>
+    <field field_ref="flx_iso" level="10"/>
+    <field field_ref="flx_mono" level="10"/>
+    <field field_ref="flx_ORVOC" level="10"/>
+    <field field_ref="flx_MBO" level="10"/>
+    <field field_ref="flx_methanol" level="10"/>
+    <field field_ref="flx_acetone" level="10"/>
+    <field field_ref="flx_acetal" level="10"/>
+    <field field_ref="flx_formal" level="10"/>
+    <field field_ref="flx_acetic" level="10"/>
+    <field field_ref="flx_formic" level="10"/>
+    <field field_ref="flx_no_soil" level="10"/>
+    <field field_ref="flx_no" level="10"/>
+  </file>
+
+  <!-- Sechiba alma file 1 -->
+  <file id="sechiba_alma_history" name="sechiba_alma_history_xios" output_level="10" output_freq="1800s" enabled=".FALSE.">
+    <field field_ref="Areas" level="1"/>
+    <field field_ref="LandPoints" level="1"/>
+    <field field_ref="Contfrac" level="1"/>
+    <field field_ref="Qg" level="1"/>
+    <field field_ref="Qv" level="1"/>
+    <field field_ref="Qs" level="1"/>
+    <field field_ref="Qsb" level="1"/>
+    <field field_ref="DelSurfHeat" level="1"/>
+    <field field_ref="DelColdCont" level="1"/>
+    <field field_ref="fluxsens" name="Qh" level="1"/>
+    <field field_ref="fluxlat" name="Qle" level="1"/>
+    <field field_ref="lwnet" name="LWnet" level="1"/>
+    <field field_ref="swnet" name="SWnet" level="1"/>
+    <field field_ref="snowf_alma" level="1"/>
+    <field field_ref="rain_alma" level="1"/>
+    <field field_ref="evap_alma" name="Evap" level="1"/>
+    <field field_ref="Qsm" level="1"/>
+    <field field_ref="irrigation_alma" level="1"/>
+    <field field_ref="netirrig_alma" level="1"/>
+    <field field_ref="temp_sol_K" level="1"/>
+    <field field_ref="PotSurfT" level="1"/>
+    <field field_ref="albedo_alma" level="1"/>
+    <field field_ref="SurfStor" level="1"/>
+    <field field_ref="snow" name="SWE" long_name="Snow Water Equivalent" level="1"/>
+    <field field_ref="SoilWet" level="1"/>
+    <field field_ref="evapot_corr_alma" level="1"/>
+    <field field_ref="evapot_alma" level="1"/>
+    <field field_ref="ECanop" level="1"/>
+    <field field_ref="TVeg" level="1"/>
+    <field field_ref="SubSnow" level="1"/>
+    <field field_ref="irrigmap" name="IrrigationMap" level="1"/>
+    <field field_ref="floodmap" name="FloodplainsMap" level="1"/>
+    <field field_ref="swampmap" name="SwampMap" level="1"/>
+    <field field_ref="hydrographs" name="Dis" level="1"/>
+    <field field_ref="gpp" name="GPP" level="1"/>
+    <field field_ref="nee" name="NEE" level="1"/>
+    <field field_ref="maint_resp" level="1"/>
+    <field field_ref="hetero_resp" level="1"/>
+    <field field_ref="growth_resp" level="1"/>
+    <field field_ref="npp" level="1"/>
+    <field field_ref="z0" name="Z0" long_name="Roughness height" level="1"/>
+    <field field_ref="roughheight" name="EffectHeight" long_name="Effective displacement height (h-d)" level="1"/>
+    <field field_ref="DelSoilMoist" level="1"/>
+    <field field_ref="DelSurfStor" level="1"/>
+    <field field_ref="DelIntercept" level="1"/>
+    <field field_ref="DelSWE" level="1"/>
+    <field field_ref="vevapnu_alma" level="1"/>
+    <field field_ref="evapflo_alma" level="1"/>
+    <field field_ref="ACond" level="1"/>
+    <field field_ref="tair" name="Tair" level="2"/>
+    <field field_ref="qair" name="Qair" level="2"/>
+    <field field_ref="Qf" level="2"/>
+    <field field_ref="vegetfrac" level="3"/>
+    <field field_ref="maxvegetfrac" level="3"/>
+    <field field_ref="nobiofrac" level="3"/>
+    <field field_ref="SoilMoist" level="7"/>
+    <field field_ref="RootMoist" level="1"/>
+    <field field_ref="ptn" name="SoilTemp" level="7"/>
+    <field field_ref="vbeta1" name="SnowFrac" level="7"/>
+    <field field_ref="SAlbedo" level="7"/>
+    <field field_ref="SnowDepth" level="7"/>
+    <field field_ref="temp_sol_K" name="RadT" level="1"/>
+  </file>
+
+  <!-- Sechiba alma file 2 -->
+  <file id="sechiba_alma_out_2" name="sechiba_alma_out_2_xios" output_level="10" output_freq="1800s" enabled=".FALSE.">
+    <field field_ref="Areas" level="1"/>
+    <field field_ref="LandPoints" level="1"/>
+    <field field_ref="Contfrac" level="1"/>
+    <field field_ref="Qg" level="1"/>
+    <field field_ref="Qv" level="1"/>
+    <field field_ref="Qs" level="1"/>
+    <field field_ref="Qsb" level="1"/>
+    <field field_ref="DelSurfHeat" level="1"/>
+    <field field_ref="DelColdCont" level="1"/>
+    <field field_ref="fluxsens" name="Qh" level="1"/>
+    <field field_ref="fluxlat" name="Qle" level="1"/>
+    <field field_ref="lwnet" name="LWnet" level="1"/>
+    <field field_ref="swnet" name="SWnet" level="1"/>
+    <field field_ref="snowf_alma" level="1"/>
+    <field field_ref="rain_alma" level="1"/>
+    <field field_ref="evap_alma" name="Evap" level="1"/>
+    <field field_ref="Qsm" level="1"/>
+    <field field_ref="irrigation_alma" level="1"/>
+    <field field_ref="netirrig_alma" level="1"/>
+    <field field_ref="temp_sol_K" level="1"/>
+    <field field_ref="albedo_alma" level="1"/>
+    <field field_ref="SurfStor" level="1"/>
+    <field field_ref="snow" name="SWE" long_name="Snow Water Equivalent" level="1"/>
+    <field field_ref="SoilWet" level="1"/>
+    <field field_ref="evapot_corr_alma" level="1"/>
+    <field field_ref="ECanop" level="1"/>
+    <field field_ref="TVeg" level="1"/>
+    <field field_ref="SubSnow" level="1"/>
+    <field field_ref="irrigmap" name="IrrigationMap" level="1"/>
+    <field field_ref="floodmap" name="FloodplainsMap" level="1"/>
+    <field field_ref="swampmap" name="SwampMap" level="1"/>
+    <field field_ref="hydrographs" name="Dis" level="1"/>
+    <field field_ref="gpp" name="GPP" level="1"/>
+    <field field_ref="nee" name="NEE" level="1"/>
+    <field field_ref="maint_resp" level="1"/>
+    <field field_ref="hetero_resp" level="1"/>
+    <field field_ref="growth_resp" level="1"/>
+    <field field_ref="npp" level="1"/>
+    <field field_ref="DelSoilMoist" level="1"/>
+    <field field_ref="DelSurfStor" level="1"/>
+    <field field_ref="DelIntercept" level="1"/>
+    <field field_ref="DelSWE" level="1"/>
+    <field field_ref="vevapnu_alma" level="1"/>
+    <field field_ref="evapflo_alma" level="1"/>
+    <field field_ref="ACond" level="1"/>
+    <field field_ref="SoilMoist" level="7"/>
+    <field field_ref="RootMoist" level="1"/>
+    <field field_ref="ptn" name="SoilTemp" level="7"/>
+    <field field_ref="vbeta1" name="SnowFrac" level="7"/>
+    <field field_ref="SAlbedo" level="7"/>
+    <field field_ref="SnowDepth" level="7"/>
+    <field field_ref="Qf" level="2"/>
+    <field field_ref="vegetfrac" level="3"/>
+    <field field_ref="maxvegetfrac" level="3"/>
+    <field field_ref="nobiofrac" level="3"/>
+    <field field_ref="temp_sol_K" name="RadT" level="5"/>
+  </file>
+
+  <!-- Definition of files with stomate diagnostics -->
+  <!-- Stomate file 1 -->
+  <file id="stomate1" name="stomate_history_xios" output_level="10" output_freq="86400s">
+    <!-- level 1 -->
+    <field field_ref="RESOLUTION_X" level="1"/>
+    <field field_ref="RESOLUTION_Y" level="1"/>
+    <field field_ref="CONTFRAC_STOMATE" level="1"/>
+    <field field_ref="Areas" level="1"/>
+    <field field_ref="T2M_MONTH" level="1"/>
+    <field field_ref="T2M_WEEK" level="1"/>
+    <field field_ref="FIREFRAC" level="1"/>
+    <field field_ref="CO2FLUX" level="1"/>
+    <field field_ref="CO2_FIRE" level="1"/>
+    <field field_ref="CO2_TAKEN" level="1"/>
+    <field field_ref="LAI" level="1"/>
+    <field field_ref="VEGET_MAX" level="1"/>
+    <field field_ref="NPP_STOMATE" level="1"/>
+    <field field_ref="GPP" level="1"/>
+    <!-- level 2 -->
+    <field field_ref="LEAF_M" level="2"/>
+    <field field_ref="SAP_M_AB" level="2"/>
+    <field field_ref="SAP_M_BE" level="2"/>
+    <field field_ref="HEART_M_AB" level="2"/>
+    <field field_ref="HEART_M_BE" level="2"/>
+    <field field_ref="ROOT_M" level="2"/>
+    <field field_ref="FRUIT_M" level="2"/>
+    <field field_ref="RESERVE_M" level="2"/>
+    <field field_ref="MAINT_RESP" level="2"/>
+    <field field_ref="GROWTH_RESP" level="2"/>
+    <!-- level 3 -->
+    <field field_ref="IND" level="3"/>
+    <field field_ref="ADAPTATION" level="3"/>
+    <field field_ref="REGENERATION" level="3"/>
+    <field field_ref="CN_IND" level="3"/>
+    <field field_ref="WOODMASS_IND" level="3"/>
+    <field field_ref="MOISTRESS" level="3"/>
+    <field field_ref="HET_RESP" level="3"/>
+    <!-- level 4 -->
+    <field field_ref="SAP_AB_TURN" level="4"/>
+    <field field_ref="ROOT_TURN" level="4"/>
+    <field field_ref="FRUIT_TURN" level="4"/>
+    <field field_ref="TOTAL_BM_LITTER" level="4"/>
+    <field field_ref="LEAF_BM_LITTER" level="4"/>
+    <field field_ref="SAP_AB_BM_LITTER" level="4"/>
+    <field field_ref="SAP_BE_BM_LITTER" level="4"/>
+    <field field_ref="HEART_AB_BM_LITTER" level="4"/>
+    <field field_ref="HEART_BE_BM_LITTER" level="4"/>
+    <field field_ref="ROOT_BM_LITTER" level="4"/>
+    <field field_ref="FRUIT_BM_LITTER" level="4"/>
+    <field field_ref="RESERVE_BM_LITTER" level="4"/>
+    <field field_ref="TOTAL_M" level="4"/>
+    <field field_ref="TOTAL_TURN" level="4"/>
+    <field field_ref="LEAF_TURN" level="4"/>
+    <!-- level 5 -->
+    <field field_ref="LITTER_STR_AB" level="5"/>
+    <field field_ref="LITTER_MET_AB" level="5"/>
+    <field field_ref="LITTER_STR_BE" level="5"/>
+    <field field_ref="LITTER_MET_BE" level="5"/>
+    <field field_ref="DEADLEAF_COVER" level="5"/>
+    <field field_ref="TOTAL_SOIL_CARB" level="5"/>
+    <field field_ref="CARBON_ACTIVE" level="5"/>
+    <field field_ref="CARBON_SLOW" level="5"/>
+    <field field_ref="CARBON_PASSIVE" level="5"/>
+    <field field_ref="LITTERHUM" level="5"/>
+    <field field_ref="BM_ALLOC_LEAF" level="5"/>
+    <field field_ref="BM_ALLOC_SAP_AB" level="5"/>
+    <field field_ref="BM_ALLOC_SAP_BE" level="5"/>
+    <field field_ref="BM_ALLOC_ROOT" level="5"/>
+    <field field_ref="BM_ALLOC_FRUIT" level="5"/>
+    <field field_ref="BM_ALLOC_RES" level="5"/>
+    <field field_ref="HERBIVORES" level="5"/>
+    <field field_ref="TURNOVER_TIME" level="5"/>
+    <field field_ref="PROD10" level="5"/>
+    <field field_ref="FLUX10" level="5"/>
+    <field field_ref="PROD100" level="5"/>
+    <field field_ref="FLUX100" level="5"/>
+    <field field_ref="CONVFLUX" level="5"/>
+    <field field_ref="CFLUX_PROD10" level="5"/>
+    <field field_ref="CFLUX_PROD100" level="5"/>
+    <field field_ref="HARVEST_ABOVE" level="5"/>
+    <!-- level 6 -->
+    <field field_ref="VCMAX" level="6"/>
+    <field field_ref="LEAF_AGE" level="6"/>
+    <field field_ref="MORTALITY" level="6"/>
+    <field field_ref="FIREDEATH" level="6"/>
+    <field field_ref="IND_ESTAB" level="6"/>
+    <field field_ref="ESTABTREE" level="6"/>
+    <field field_ref="ESTABGRASS" level="6"/>
+    <field field_ref="LIGHT_DEATH" level="6"/>
+    <!-- level 7 -->
+    <field field_ref="AGE" level="7"/>
+    <field field_ref="HEIGHT" level="7"/>
+    <!-- level 9 -->
+    <field field_ref="WHEN_GROWTHINIT" level="9"/>
+    <field field_ref="PFTPRESENT" level="9"/>
+    <field field_ref="GDD_MIDWINTER" level="9"/>
+    <field field_ref="GDD_M5_DORMANCE" level="9"/>
+    <field field_ref="NCD_DORMANCE" level="9"/>
+    <field field_ref="ALLOW_INITPHENO" level="9"/>
+    <field field_ref="BEGIN_LEAVES" level="9"/>
+    <field field_ref="T2M_LONGTERM" level="9"/>
+    <!-- level 10 -->
+    <field field_ref="BLACK_CARBON" level="10"/>
+    <field field_ref="FIREINDEX" level="10"/>
+  </file>
+
+  <!-- Stomate file 2 -->
+  <file id="stomate2" name="stomate_ipcc_history_xios" output_level="1" output_freq="86400s">
+    <!-- level 1 -->
+    <field field_ref="RESOLUTION_X" level="1"/>
+    <field field_ref="RESOLUTION_Y" level="1"/>
+    <field field_ref="CONTFRAC_STOMATE" level="1"/>
+    <field field_ref="Areas" level="1"/>
+    <field field_ref="cVeg" level="1"/>
+    <field field_ref="cLitter" level="1"/>
+    <field field_ref="cSoil" level="1"/>
+    <field field_ref="cProduct" level="1"/>
+    <field field_ref="cMassVariation" level="1"/>
+    <field field_ref="lai_ipcc" level="1"/>
+    <field field_ref="gpp_ipcc" level="1"/>
+    <field field_ref="ra" level="1"/>
+    <field field_ref="npp_ipcc" level="1"/>
+    <field field_ref="rh" level="1"/>
+    <field field_ref="fFire" level="1"/>
+    <field field_ref="fHarvest" level="1"/>
+    <field field_ref="fLuc" level="1"/>
+    <field field_ref="nbp" level="1"/>
+    <field field_ref="fVegLitter" level="1"/>
+    <field field_ref="fLitterSoil" level="1"/>
+    <field field_ref="cLeaf" level="1"/>
+    <field field_ref="cWood" level="1"/>
+    <field field_ref="cRoot" level="1"/>
+    <field field_ref="cMisc" level="1"/>
+    <field field_ref="cLitterAbove" level="1"/>
+    <field field_ref="cLitterBelow" level="1"/>
+    <field field_ref="cSoilFast" level="1"/>
+    <field field_ref="cSoilMedium" level="1"/>
+    <field field_ref="cSoilSlow" level="1"/>
+    <field field_ref="landCoverFrac" level="1"/>
+    <field field_ref="treeFracPrimDec" level="1"/>
+    <field field_ref="treeFracPrimEver" level="1"/>
+    <field field_ref="c3PftFrac" level="1"/>
+    <field field_ref="c4PftFrac" level="1"/>
+    <field field_ref="rGrowth" level="1"/>
+    <field field_ref="rMaint" level="1"/>
+    <field field_ref="nppLeaf" level="1"/>
+    <field field_ref="nppWood" level="1"/>
+    <field field_ref="nppRoot" level="1"/>
+    <field field_ref="nep" level="1"/>
+  </file>
+</file_definition>
Index: branches/publications/ORCHIDEE_CAN_NHA/src_xml/iodef.xml
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/src_xml/iodef.xml	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/src_xml/iodef.xml	(revision 7236)
@@ -0,0 +1,77 @@
+<?xml version="1.0"?>
+<!-- =========================================================================================================== -->
+<!-- iodef.xml : Configuration file for production of output files using XIOS                                    -->
+<!--             This file includes the files :                                                                  -->
+<!--                  field_def_orchidee.xml    Definition of all existing variables                             -->
+<!--                  file_def_orchidee.xml     USER SPECIFICATION FILE :                                        -->
+<!--                         		        Definition of output files and variables produced                -->
+<!-- =========================================================================================================== -->
+
+<simulation>
+
+  <!-- =========================================================================================================== -->
+  <!-- XIOS context                                                                                                -->
+  <!-- =========================================================================================================== -->
+  <context id="xios">
+    <variable_definition>
+      <variable_group id="buffer">
+            buffer_size = 80000000
+            buffer_server_factor_size = 2 
+         </variable_group>
+      <variable_group id="parameters">
+        <variable id="using_server" type="boolean">false</variable>
+        <variable id="info_level" type="int">0</variable>
+      </variable_group>
+    </variable_definition>
+  </context>
+
+  <!-- =========================================================================================================== -->
+  <!-- ORCHIDEE context                                                                                            -->
+  <!-- =========================================================================================================== -->
+  <context id="orchidee">
+
+
+    <!-- =========================================================================================================== -->
+    <!-- Definition of all existing variables                                                                        -->
+    <!-- DO NOT CHANGE THIS FILE                                                                                     -->
+    <!-- =========================================================================================================== -->
+    <field_definition src="./field_def_orchidee.xml"/>
+
+
+    <!-- =========================================================================================================== -->
+    <!-- Definition of output files                                                                                  -->
+    <!-- Definition of variables or groups included in the different files                                           -->
+    <!-- CHANGE THIS FILE BY ADDING THE FILES AND/OR VARIABLES YOU WANT TO PRODUCE                                   -->
+    <!-- Only variables and groups existing in field_def_orchidee.xml can be used                                    -->
+    <!-- =========================================================================================================== -->
+    <file_definition src="./file_def_orchidee.xml"/>
+
+
+    <!-- =========================================================================================================== -->
+    <!-- Definition of horizontal domain                                                                             -->
+    <!-- =========================================================================================================== -->
+    <domain_definition>
+      <domain id="domain_landpoints"/>
+    </domain_definition>
+
+    <!-- =========================================================================================================== -->
+    <!-- Definition of vertical axis and extra dimensions                                                            -->
+    <!-- =========================================================================================================== -->
+    <axis_definition>
+      <!-- Vertical axis and extra dimensions in sechiba -->
+      <axis id="veget" standard_name="model_level_number" long_name="Vegetation types" unit="1"/>
+      <axis id="laiax" standard_name="model_level_number" long_name="Nb LAI" unit="1"/>
+      <axis id="solth" standard_name="model_level_number" long_name="Soil levels" unit="m"/>
+      <axis id="soiltyp" standard_name="model_level_number" long_name="Soil types" unit="1"/>
+      <axis id="nobio" standard_name="model_level_number" long_name="Other surface types" unit="1"/>
+      <axis id="albtyp" standard_name="model_level_number" long_name="Albedo types" unit="1"/>
+      <axis id="solay" standard_name="model_level_number" long_name="Hydrol soil levels" unit="m"/>
+      <!-- Vertical axis and extra dimensions in stomate -->
+      <axis id="PFT" standard_name="model_level_number" long_name="Plant functional type" unit="1"/>
+      <axis id="P10" standard_name="model_level_number" long_name="Pool 10 years" unit="1"/>
+      <axis id="P100" standard_name="model_level_number" long_name="Pool 100 years" unit="1"/>
+      <axis id="P11" standard_name="model_level_number" long_name="Pool 10 years + 1" unit="1"/>
+      <axis id="P101" standard_name="model_level_number" long_name="Pool 100 years + 1" unit="1"/>
+    </axis_definition>
+  </context>
+</simulation>
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/COPYRIGHT.txt
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/COPYRIGHT.txt	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/COPYRIGHT.txt	(revision 7236)
@@ -0,0 +1,109 @@
+!------------------------------------------------------------------------------!
+!              Flexible Configuration Management Software License              !
+!                                                                              !
+!     Please read this Software Licence as you will be bound by its terms      !
+!                           if you use the Software                            !
+!------------------------------------------------------------------------------!
+
+The Licensor:
+-------------
+
+The Met Office of FitzRoy Road, Exeter EX1 3PB, United Kingdom
+--------------------------------------------------------------------------------
+
+1. Licence.
+-----------
+
+The Met Office grants you a non-exclusive, royalty free; world-wide,
+transferable Licence to use, modify, copy and distribute the Flexible
+Configuration Management software ("the software") accompanying this License
+providing:
+
+a. you undertake to provide to the Met Office a copy of any modifications made
+   by you on the same terms contained within this licence agreement;
+
+b. modified files carry prominent notices stating that you changed the files
+   and the date of change;
+
+c. distribution of original or modified files is made free of charge under the
+   terms of this Licence;
+
+d. the appropriate copyright notices, the above copyright notice and a
+   disclaimer of warranty is included with the distribution.
+
+2. Ownership.
+-------------
+
+The Flexible Configuration Management software is Crown copyright and is
+reproduced with the permission of Met Office under delegated authority from
+the Controller of HMSO. The software and documentation are provided to you to
+allow you to exercise your rights under this License, which is granted to you.
+
+3. Duration.
+------------
+
+This license will remain in effect until terminated.
+ 
+4. Termination.
+---------------
+
+You may terminate this license at any time by removing all copies of the
+software from your system.  This License will terminate immediately without
+notice from us if you fail to comply with any of the provisions of this
+License or in the event of your breaching the terms of this licence you are
+given notice that the license has been terminated.  Upon termination you will
+delete all copies of the software and any related documentation.
+
+5. Disclaimer of Warranty.
+--------------------------
+
+a. THE MET OFFICE DISCLAIMS ALL WARRANTIES, REPRESENTATIONS AND PROMISES,
+   INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF SATISFACTORY QUALITY
+   AND FIT FOR THE PURPOSE.  NEITHER DOES THE MET OFFICE MAKE ANY
+   REPRESENTATIONS AS TO COMPATABILITY WITH YOUR OPERATING SYSTEMS AND
+   PLATFORMS.
+
+b. In no event does the Met Office warrant that the software or related
+   documentation will satisfy your requirements, that the software and
+   documentation will be without errors or defects or that the operation of
+   the software will be uninterrupted.
+
+c. IN NO EVENT WILL THE MET OFFICE BE LIABLE FOR ANY OTHER DAMAGES, INCLUDING
+   BUT NOT LIMITED TO DAMAGES FOR LOSS OF PROFITS DATA OR USE OF THE SOFTWARE
+   OR FOR ANY INDIRECT, INCIDENTAL OR CONSEQUENTIAL DAMAGES, EVEN IF THE MET
+   OFFICE HAS BEEN SPECIFICALLY ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
+
+6. General Provisions.
+----------------------
+
+a. You will not do anything, relating to this software that will bring the Met
+   Office into disrepute.
+
+b. You will not use the name of the Met Office or any other contributor to
+   endorse or promote any products derived from the software without the
+   written permission of the Met Office.
+
+7. Acknowledgements.
+--------------------
+
+The Fortran 9X Interface Generator found in file
+./src/lib/Ecmwf/Fortran90_stuff.pm is adapted from a script developed at ECMWF
+and is provided by kind permission of ECMWF under the same terms of this
+Licence.
+
+8. Entire Agreement.
+--------------------
+
+This License constitutes the entire agreement between us with respect to your
+rights or warranties for using the software and related documentation.  If any
+provision of this agreement is determined to be invalid or unenforceable the
+remaining provisions shall continue in full force.
+
+9. Governing Law.
+-----------------
+
+This Agreement is governed by and construed in accordance with the Laws of
+England.
+
+--------------------------------------------------------------------------------
+                                               © British Crown copyright 2006-7.
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/LICENSE.html
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/LICENSE.html	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/LICENSE.html	(revision 7236)
@@ -0,0 +1,150 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+
+<html>
+<head>
+  <title>Flexible Configuration Management Software License</title>
+  <meta name="copyright" content="&copy; British Crown Copyright">
+  <style type="text/css">
+  <!--
+  body {
+    font: normal normal 10pt Arial, sans-serif;
+  }
+
+  h1 {
+    text-align: center;
+    text-decoration: underline;
+    font: normal bold 14pt Arial, sans-serif;
+  }
+
+  h2 {
+    text-align: left;
+    text-decoration: none;
+    font: normal normal 14pt Arial, sans-serif;
+  }
+
+  h3 {
+    text-align: left;
+    text-decoration: none;
+    font: normal bold 10pt Arial, sans-serif;
+  }
+
+  .copyright {
+    text-align: right;
+    font: normal bold 11pt Arial, sans-serif;
+  }
+
+  ol li {
+    list-style: lower-alpha;
+  }
+  //-->
+  </style>
+</head>
+
+<body>
+  <h1>Flexible Configuration Management Software License</h1>
+
+  <h1>Please read this Software Licence as you will be bound by its terms if
+  you use the Software</h1>
+
+  <h2>The Licensor:</h2>
+
+  <h2>The Met Office of FitzRoy Road, Exeter EX1 3PB, United Kingdom</h2>
+
+  <h3>1. Licence.</h3>
+
+  <p>The Met Office grants you a non-exclusive, royalty free; world-wide,
+  transferable Licence to use, modify, copy and distribute the Flexible
+  Configuration Management software ("the software") accompanying this License
+  providing:</p>
+
+  <ol>
+    <li>you undertake to provide to the Met Office a copy of any modifications
+    made by you on the same terms contained within this licence agreement;</li>
+
+    <li>modified files carry prominent notices stating that you changed the
+    files and the date of change;</li>
+
+    <li>distribution of original or modified files is made free of charge under
+    the terms of this Licence;</li>
+
+    <li>the appropriate copyright notices, the above copyright notice and a
+    disclaimer of warranty is included with the distribution.</li>
+  </ol>
+
+  <h3>2. Ownership.</h3>
+
+  <p>The Flexible Configuration Management software is Crown copyright and is
+  reproduced with the permission of Met Office under delegated authority from
+  the Controller of HMSO. The software and documentation are provided to you to
+  allow you to exercise your rights under this License, which is granted to
+  you.</p>
+
+  <h3>3. Duration.</h3>
+
+  <p>This license will remain in effect until terminated.</p>
+
+  <h3>4. Termination.</h3>
+
+  <p>You may terminate this license at any time by removing all copies of the
+  software from your system. This License will terminate immediately without
+  notice from us if you fail to comply with any of the provisions of this
+  License or in the event of your breaching the terms of this licence you are
+  given notice that the license has been terminated. Upon termination you will
+  delete all copies of the software and any related documentation.</p>
+
+  <h3>5. Disclaimer of Warranty.</h3>
+
+  <ol>
+    <li>THE MET OFFICE DISCLAIMS ALL WARRANTIES, REPRESENTATIONS AND PROMISES,
+    INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF SATISFACTORY QUALITY
+    AND FIT FOR THE PURPOSE. NEITHER DOES THE MET OFFICE MAKE ANY
+    REPRESENTATIONS AS TO COMPATABILITY WITH YOUR OPERATING SYSTEMS AND
+    PLATFORMS.</li>
+
+    <li>In no event does the Met Office warrant that the software or related
+    documentation will satisfy your requirements, that the software and
+    documentation will be without errors or defects or that the operation of
+    the software will be uninterrupted.</li>
+
+    <li>IN NO EVENT WILL THE MET OFFICE BE LIABLE FOR ANY OTHER DAMAGES,
+    INCLUDING BUT NOT LIMITED TO DAMAGES FOR LOSS OF PROFITS DATA OR USE OF THE
+    SOFTWARE OR FOR ANY INDIRECT, INCIDENTAL OR CONSEQUENTIAL DAMAGES, EVEN IF
+    THE MET OFFICE HAS BEEN SPECIFICALLY ADVISED OF THE POSSIBILITY OF SUCH
+    DAMAGES.</li>
+  </ol>
+
+  <h3>6. General Provisions.</h3>
+
+  <ol>
+    <li>You will not do anything, relating to this software that will bring the
+    Met Office into disrepute.</li>
+
+    <li>You will not use the name of the Met Office or any other contributor to
+    endorse or promote any products derived from the software without the
+    written permission of the Met Office.</li>
+  </ol>
+
+  <h3>7. Acknowledgements.</h3>
+
+  <p>The Fortran 9X Interface Generator found in file
+  ./src/lib/Ecmwf/Fortran90_stuff.pm is adapted from a script developed at
+  ECMWF and is provided by kind permission of ECMWF under the same terms of
+  this Licence.</p>
+
+  <h3>8. Entire Agreement.</h3>
+
+  <p>This License constitutes the entire agreement between us with respect to
+  your rights or warranties for using the software and related documentation.
+  If any provision of this agreement is determined to be invalid or
+  unenforceable the remaining provisions shall continue in full force.</p>
+
+  <h3>9. Governing Law.</h3>
+
+  <p>This Agreement is governed by and construed in accordance with the Laws of
+  England.</p>
+
+  <div class="copyright">
+    <p>&copy; British Crown copyright 2006-7.</p>
+  </div>
+</body>
+</html>
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/README
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/README	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/README	(revision 7236)
@@ -0,0 +1,4 @@
+FCM release 1-2 created from revision 2131
+
+For further details please refer to the release notes
+which can be found in the directory doc/release_notes.
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm	(revision 7236)
@@ -0,0 +1,794 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   fcm
+#
+# SYNOPSIS
+#   fcm SUBCOMMAND [OPTIONS...] ARGS...
+#
+# DESCRIPTION
+#   The fcm command is the frontend of the FCM system. The first argument to the
+#   command must be a recognised subcommand. See "fcm help" for a full list of
+#   functionalities.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+# Standard pragmas:
+use warnings;
+use strict;
+
+# Standard modules:
+use File::Basename;
+use File::Spec;
+use Getopt::Long;
+use Cwd;
+
+# FCM component modules:
+use lib File::Spec->catfile (dirname (dirname ($0)), 'lib');
+use Fcm::Config;
+use Fcm::Extract;
+use Fcm::Build;
+use Fcm::Util;
+
+BEGIN {
+  eval {
+    require Fcm::Cm;
+    import Fcm::Cm;
+
+    require Fcm::CmUrl;
+    import Fcm::CmUrl;
+  }
+}
+
+# Function declaration:
+sub cmp_ext_cfg;
+sub invoke_build_system;
+sub invoke_extract_system;
+sub invoke_cfg_printer;
+sub invoke_cm_system;
+sub invoke_www_browser;
+sub invoke_help;
+
+# ------------------------------------------------------------------------------
+
+my $prog      = basename $0;
+my $year      = (localtime)[5] + 1900;
+my $copyright = <<EOF;
+
+(C) Crown copyright $year Met Office. All rights reserved.
+EOF
+
+# List of sub-commands recognised by FCM
+my %subcommand = (
+  HLP => [qw/help ? h/],
+  BLD => [qw/build bld/],
+  EXT => [qw/extract ext/],
+  CFG => [qw/cfg/],
+  GUI => [qw/gui/],
+  CM  => [qw/
+    branch    br
+    conflicts cf
+    add
+    blame     praise annotate ann
+    cat
+    checkout  co
+    cleanup
+    commit    ci
+    copy      cp
+    delete    del    remove   rm
+    diff      di
+    export
+    import
+    info
+    list      ls
+    lock
+    log
+    merge
+    mkdir
+    mkpatch
+    move      mv     rename   ren
+    propdel   pdel   pd
+    propedit  pedit  pe
+    propget   pget   pg
+    proplist  plist  pl
+    propset   pset   ps
+    resolved
+    revert
+    status    stat   st
+    switch    sw
+    unlock
+    update    up
+  /],
+  CMP => [qw/cmp-ext-cfg/],
+  WWW => [qw/www trac/],
+);
+
+# Get configuration settings
+my $config = Fcm::Config->new ();
+$config->get_config ();
+
+# Determine the functionality of this invocation of the command
+my $function = @ARGV ? shift @ARGV : '';
+
+# Run command accordingly
+if (grep {$_ eq $function} @{ $subcommand{BLD} }) {
+  invoke_build_system;
+
+} elsif (grep {$_ eq $function} @{ $subcommand{EXT} }) {
+  invoke_extract_system;
+
+} elsif (grep {$_ eq $function} @{ $subcommand{CFG} }) {
+  invoke_cfg_printer;
+
+} elsif (grep {$_ eq $function} @{ $subcommand{GUI} }) {
+  &run_command (['fcm_gui', @ARGV], METHOD => 'exec');
+
+} elsif (grep {$_ eq $function} @{ $subcommand{CM} }) {
+  invoke_cm_system;
+
+} elsif (grep {$_ eq $function} @{ $subcommand{CMP} }) {
+  cmp_ext_cfg;
+
+} elsif (grep {$_ eq $function} @{ $subcommand{WWW} }) {
+  invoke_www_browser;
+
+} elsif ($function =~ /^\s*$/ or grep {$_ eq $function} @{ $subcommand{HLP} }) {
+  invoke_help;
+
+} else {
+  w_report 'Unknown command: ', $function;
+  e_report 'Type "', $prog, ' help" for usage';
+}
+
+exit;
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cfg = &main::cfg ();
+#
+# DESCRIPTION
+#   Return the $config variable.
+# ------------------------------------------------------------------------------
+
+sub cfg {
+  return $config;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &cmp_ext_cfg ();
+#
+# DESCRIPTION
+#   Compare two similar extract configuration files.
+# ------------------------------------------------------------------------------
+
+sub cmp_ext_cfg {
+  # Check options
+  # ----------------------------------------------------------------------------
+  my ($wiki, $verbose);
+
+  GetOptions ('wiki|w=s' => \$wiki, 'verbose|v' => \$verbose);
+
+  # Check arguments
+  # ----------------------------------------------------------------------------
+  e_report $prog, ' ', $function,
+           ': 2 extract config files must be specified, abort.'
+    if @ARGV < 2;
+
+  # Invoke 2 new instances of the Fcm::Extract class
+  # ----------------------------------------------------------------------------
+  my (@cfg, $rc);
+  for my $i (0 .. 1) {
+    $cfg[$i] = Fcm::Extract->new (CFG_SRC => $ARGV[$i]);
+
+    # Read the extract configuration file
+    $rc = $cfg[$i]->decipher_cfg;
+    $rc = $cfg[$i]->expand_cfg if $rc;
+
+    last if not $rc;
+  }
+
+  # Throw error if command has failed
+  # ----------------------------------------------------------------------------
+  e_report $prog, ' ', $function,
+           ': cannot read extract configuration file, abort' if not $rc;
+
+  # Get list of URLs
+  # ----------------------------------------------------------------------------
+  my @urls = ();
+  for my $i (0 .. 1) {
+    # List of branches in each extract configuration file
+    my @branches = $cfg[$i]->branches;
+
+    for my $branch (@branches) {
+      # Ignore declarations of local directories
+      next if $branch->type eq 'user';
+
+      # List of SRC declarations in each branch
+      my %dirs = $branch->dirs;
+
+      for my $dir (values %dirs) {
+        # Set up a new instance of Fcm::CmUrl object for each SRC declaration
+        my $cm_url = Fcm::CmUrl->new (
+          URL => $dir . ($branch->version ? '@' . $branch->version : ''),
+        );
+
+        $urls[$i]{$cm_url->branch_url}{$dir} = $cm_url;
+      }
+    }
+  }
+
+  # Compare
+  # ----------------------------------------------------------------------------
+  my %log;
+  for my $i (0 .. 1) {
+    # Compare the first file with the second one and then vice versa
+    my $j = ($i == 0) ? 1 : 0;
+
+    for my $branch (sort keys %{ $urls[$i] }) {
+      if (exists $urls[$j]{$branch}) {
+        # Same REPOS declarations in both files
+        for my $dir (sort keys %{ $urls[$i]{$branch} }) {
+          if (exists $urls[$j]{$branch}{$dir}) {
+            # Same SRC declarations in both files, only need to compare once
+            next if $i == 1;
+
+            my $this_url = $urls[$i]{$branch}{$dir};
+            my $that_url = $urls[$j]{$branch}{$dir};
+
+            # Check whether their last changed revisions are the same
+            my $this_rev = $this_url->svninfo (FLAG => 'Last Changed Rev');
+            my $that_rev = $that_url->svninfo (FLAG => 'Last Changed Rev');
+
+            # Make sure last changed revisions differ
+            next if $this_rev eq $that_rev;
+
+            # Not interested in the log before the minimum revision
+            my $min_rev = ($this_url->pegrev > $that_url->pegrev)
+                          ? $that_url->pegrev : $this_url->pegrev;
+
+            $this_rev = $min_rev if $this_rev < $min_rev;
+            $that_rev = $min_rev if $that_rev < $min_rev;
+
+            # Get list of changed revisions using the commit log
+            my $u   = ($this_rev > $that_rev) ? $this_url : $that_url;
+            my %revs = $u->svnlog (REV => [$this_rev, $that_rev]);
+
+            for my $rev (keys %revs) {
+              # Check if revision is already in the list
+              next if exists $log{$branch}{$rev};
+
+              # Not interested in the minimum revision
+              next if $rev == $min_rev;
+
+              # Get list of changed paths. Accept this revision only if it
+              # contains changes in the current branch
+              my %paths  = %{ $revs{$rev}{paths} };
+
+              for my $path (keys %paths) {
+                my $change_url = Fcm::CmUrl->new (URL => $u->root . $path);
+
+                if ($change_url->branch eq $u->branch) {
+                  $log{$branch}{$rev} = $u;
+                  last;
+                }
+              }
+            }
+
+          } else {
+            # Report SRC declaration in one file but not in another
+            print $urls[$i]{$branch}{$dir}->url_peg, ':', "\n";
+            print '  in    : ', $ARGV[$i], "\n";
+            print '  not in: ', $ARGV[$j], "\n\n";
+          }
+        }
+
+      } else {
+        # Report REPOS declaration in one file but not in another
+        print $branch, ':', "\n";
+        print '  in    : ', $ARGV[$i], "\n";
+        print '  not in: ', $ARGV[$j], "\n\n";
+      }
+    }
+  }
+
+  # Report modifications
+  # ----------------------------------------------------------------------------
+  print 'Revisions at which declared source directories are modified:', "\n\n"
+    if keys %log;
+
+  if (defined $wiki) {
+    # Output in wiki format
+    my $wiki_url  = Fcm::CmUrl->new (URL => &expand_url_keyword (URL => $wiki));
+    my $base_trac = $wiki
+                    ? &get_browser_url (URL => $wiki_url->project_url)
+                    : $wiki_url;
+    $base_trac    = $wiki_url if not $base_trac;
+
+    for my $branch (sort keys %log) {
+      # Name of the branch
+      my $branch_trac = &get_browser_url (URL => $branch);
+      $branch_trac =~ s#^$base_trac(?:/*|$)#source:#;
+
+      print '[', $branch_trac, ']:', "\n";
+
+      # Revision table
+      for my $rev (sort {$b <=> $a} keys %{ $log{$branch} }) {
+        print $log{$branch}{$rev}->display_svnlog ($rev, $base_trac), "\n";
+      }
+
+      print "\n";
+    }
+
+  } else {
+    my $separator = '-' x 80 . "\n";
+
+    for my $branch (sort keys %log) {
+      # Output in plain text format
+      print $branch, ':', "\n";
+
+      if ($verbose or &cfg->verbose > 1) {
+        # Verbose mode, print revision log
+        for my $rev (sort {$b <=> $a} keys %{ $log{$branch} }) {
+          print $separator, $log{$branch}{$rev}->display_svnlog ($rev), "\n";
+        }
+
+      } else {
+        # Normal mode, print list of revisions
+        print join (' ', sort {$b <=> $a} keys %{ $log{$branch} }), "\n";
+      }
+
+      print $separator, "\n";
+    }
+  }
+
+  return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &invoke_build_system ();
+#
+# DESCRIPTION
+#   Invoke the build system.
+# ------------------------------------------------------------------------------
+
+sub invoke_build_system {
+  my ($archive, $full, $ignore_lock, $jobs, $stage, @targets, $verbose);
+
+  GetOptions (
+    'archive|a'   => \$archive,     # switch on archive mode?
+    'full|f'      => \$full,        # full build?
+    'ignore-lock' => \$ignore_lock, # ignore lock file?
+    'jobs|j=i'    => \$jobs,        # number of parallel jobs in make
+    'stage|s=s'   => \$stage,       # build up to and including this stage
+    'targets|t=s' => \@targets,     # make targets
+    'verbose|v=i' => \$verbose,     # verbose level
+  );
+
+  # Verbose level
+  $config->verbose ($verbose) if defined $verbose;
+
+  # Invoke a new instance of the Fcm::Build class
+  my $bld = Fcm::Build->new (CFG_SRC  => @ARGV ? join (' ', @ARGV) : cwd ());
+
+  # Perform build
+  $bld->build (
+    ARCHIVE     => $archive,
+    FULL        => $full,
+    IGNORE_LOCK => $ignore_lock,
+    JOBS        => $jobs ? $jobs : 1,
+    STAGE       => $stage ? $stage : 5,
+    TARGETS     => (@targets ? [split (/:/, join (':', @targets))] : [qw/all/]),
+  );
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &invoke_extract_system ();
+#
+# DESCRIPTION
+#   Invoke the extract system.
+# ------------------------------------------------------------------------------
+
+sub invoke_extract_system {
+  my ($full, $ignore_lock, $verbose);
+
+  GetOptions (
+    'full|f'      => \$full,        # full extract?
+    'ignore-lock' => \$ignore_lock, # ignore lock file?
+    'verbose|v=i' => \$verbose,     # verbose level
+  );
+
+  $config->verbose ($verbose) if defined $verbose;
+
+  # Invoke a new instance of the Fcm::Extract class
+  my $ext = Fcm::Extract->new (CFG_SRC => @ARGV ? join (' ', @ARGV) : cwd ());
+
+  # Perform extract
+  $ext->extract (FULL => $full, IGNORE_LOCK => $ignore_lock);
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &invoke_cfg_printer ();
+#
+# DESCRIPTION
+#   Invoke the CFG file pretty printer.
+# ------------------------------------------------------------------------------
+
+sub invoke_cfg_printer {
+
+  use Fcm::CfgFile;
+
+  my $out_file;
+  GetOptions (
+    'output|o=s'  => \$out_file,  # output file for print
+  );
+
+  my $file = join (' ', @ARGV);
+  e_report $prog, ' ', $function, ': file not specified, abort.' if ! $file;
+
+  # Invoke a new Fcm::CfgFile instance
+  my $cfg = Fcm::CfgFile->new (SRC => $file);
+
+  # Read the cfg file
+  my $read = $cfg->read_cfg;
+  e_report if not $read;
+
+  # Pretty print CFG file
+  $cfg->print_cfg ($out_file);
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &invoke_cm_system ();
+#
+# DESCRIPTION
+#   Invoke a code management system command.
+# ------------------------------------------------------------------------------
+
+sub invoke_cm_system {
+
+  &cm_command ($function);
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &invoke_www_browser ();
+#
+# DESCRIPTION
+#   Invoke a web browser on the specified PATH.
+# ------------------------------------------------------------------------------
+
+sub invoke_www_browser {
+
+  # Options
+  my ($browser);
+  GetOptions (
+    'browser|b=s' => \$browser, # browser command
+  );
+
+  $browser = &cfg->setting (qw/MISC WEB_BROWSER/) unless $browser;
+
+  # Arguments
+  my ($arg) = @ARGV ? $ARGV[0] : (&is_wc () ? '.' : '');
+  e_report $prog, ' ', $function,
+           ': input URL not specified and . not a working copy, abort.'
+    if not $arg;
+
+  # Local PATH?
+  $arg = &expand_tilde ($arg);
+  $arg = &get_url_of_wc ($arg) if -e $arg;
+
+  # Expand URL and revision keywords
+  my $www_url = &expand_url_keyword (URL => $arg);
+  my $rev     = 'HEAD';
+
+  if ($www_url =~ m#^(\w+://\S+)@(\S+)$#) {
+    $www_url = $1;
+    $rev     = $2;
+  }
+
+  $rev = &expand_rev_keyword (URL => $www_url, REV => $rev, HEAD => 1)
+    unless uc ($rev) eq 'HEAD';
+
+  # Get web browser URL
+  $www_url = &get_browser_url (URL => $www_url);
+  die 'WWW URL not defined for "', $arg, '", abort' unless $www_url;
+
+  $www_url = $www_url . '?rev=' . $rev;
+
+  # Execute command
+  my @command = (split (/\s+/, $browser), $www_url);
+  &run_command (\@command, METHOD => 'exec', PRINT => 1);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &invoke_help ();
+#
+# DESCRIPTION
+#   Invoke help.
+# ------------------------------------------------------------------------------
+
+sub invoke_help {
+
+  my $cmd = @ARGV ? shift @ARGV : undef;
+
+  if ($cmd) {
+    if (grep {$_ eq $cmd} @{ $subcommand{BLD} }) {
+      print <<EOF;
+$prog $cmd: invoke the build system.
+usage: $prog $cmd [OPTIONS...] [CFGFILE]
+
+  The path to a CFG file may be provided. Otherwise, the build system
+  searches the default locations for a bld cfg file.
+
+  If no option is specified, the options "-s 5 -t all -j 1 -v 1" are assumed.
+
+  If the option for full build is specified, the sub-directories created by
+  previous builds will be removed, so that the current build can start cleanly.
+
+  The -s option can be used to limit the actions performed by the build system
+  up to a named stage. The stages are:
+    "1", "s" or "setup"                - stage 1, setup
+    "2", "pp" or "pre_process"         - stage 2, pre-process
+    "3", "gd" or "generate_dependency" - stage 3, generate dependency
+    "4", "gi" or "generate_interface"  - stage 4, generate Fortran 9X interface
+    "5", "m", "make"                   - stage 5, make
+
+  If a colon separated list of targets is specified using the -t option, the
+  default targets specified in the configuration file will not be used.
+
+  If archive mode is switched on, build sub-directories that are only used
+  in the build process will be archived to TAR files. The default is off.
+
+  If specified, the verbose level must be an integer greater than 0. Verbose
+  level 0 is the quiet mode. Increasing the verbose level will increase the
+  amount of diagnostic output.
+
+  When a build is invoked, it sets up a lock file in the build root directory.
+  The lock is normally removed at the end of the build. While the lock file is
+  in place, othe build commands invoked in the same root directory will fail.
+  If you need to bypass this check for whatever reason, you can invoke the
+  build system with the --ignore-lock option.
+
+Valid options:
+  -a [--archive]     : archive build sub-directories?
+  -f [--full]        : full build
+  --ignore-lock      : ignore lock files in build root directory
+  -j [--jobs] arg    : number of parallel jobs that "make" can handle
+  -s [--stage] arg   : perform build up to a named stage
+  -t [--targets] arg : build a colon (:) separated list of targets
+  -v [--verbose] arg : verbose level
+$copyright
+EOF
+
+    } elsif (grep {$_ eq $cmd} @{ $subcommand{EXT} }) {
+      print <<EOF;
+$prog $cmd: invoke the extract system.
+usage: $prog $cmd [OPTIONS...] [CFGFILE]
+
+  The path to a CFG file may be provided. Otherwise, the extract system
+  searches the default locations for an ext cfg file.
+
+  If no option is specified, the system will attempt an incremental extract
+  where appropriate.
+
+  If specified, the verbose level must be an integer greater than 0. Verbose
+  level 0 is the quiet mode. Increasing the verbose level will increase the
+  amount of diagnostic output.
+
+  When an extract is invoked, it sets up a lock file in the extract destination
+  root directory. The lock is normally removed at the end of the extract. While
+  the lock file is in place, othe extract commands invoked in the same
+  destination root directory will fail. If you need to bypass this check for
+  whatever reason, you can invoke the extract system with the --ignore-lock
+  option.
+
+Valid options:
+  -f [--full]        : perform a full/clean extract
+  --ignore-lock      : ignore lock files in build root directory
+  -v [--verbose] arg : verbose level
+$copyright
+EOF
+
+    } elsif (grep {$_ eq $cmd} @{ $subcommand{CFG} }) {
+      print <<EOF;
+$prog $cmd: invoke the CFG file pretty printer.
+usage: $prog $cmd [OPTIONS...] FILE
+
+  If no option is specified, the output will be sent to standard output.
+
+Valid options:
+  -o [--output] arg : send output to a file as specified by arg.
+$copyright
+EOF
+
+    } elsif (grep {$_ eq $cmd} @{ $subcommand{GUI} }) {
+      print <<EOF;
+$prog $cmd: invoke the GUI wrapper for CM commands.
+usage: $prog $cmd DIR
+
+  The optional argument DIR modifies the initial working directory.
+$copyright
+EOF
+
+    } elsif (grep {$_ eq $cmd} @{ $subcommand{CM} }) {
+      @ARGV = qw(--help);
+      cm_command ($cmd);
+
+    } elsif (grep {$_ eq $cmd} @{ $subcommand{CMP} }) {
+      print <<EOF;
+$prog $cmd: compare two similar extract configuration files.
+usage: $prog $cmd [OPTIONS...] CFG1 CFG2
+
+  Compares the extract configurations of two similar extract configuration
+  files CFG1 and CFG2.
+
+Valid options:
+  -v [--verbose]  : print revision tables in verbose mode. In particular,
+                    display the change log of each revision.
+  -w [--wiki] arg : print revision tables in wiki format. The argument to this
+                    option must be the Subversion URL or FCM URL keyword of a
+                    FCM project associated with the intended Trac system. This
+                    option overrides the -v option.
+$copyright
+EOF
+
+    } elsif (grep {$_ eq $cmd} @{ $subcommand{WWW} }) {
+      print <<EOF;
+$prog $cmd: invoke the web repository browser on a Subversion URL.
+usage: $prog $cmd [OPTIONS...] [PATH]
+
+  If PATH is specified, it must be a FCM URL keyword, a Subversion URL or the
+  PATH to a local working copy. If not specified, the current working directory
+  is assumed to be a working copy. If the --browser option is specified, the
+  specified web browser command is used to launch the repository browser.
+  Otherwise, it attempts to use the default browser from the configuration
+  setting.
+
+Valid options:
+  -b [--browser] arg : specify a command arg for the web browser.
+$copyright
+EOF
+
+    } elsif (grep {$_ eq $cmd} @{ $subcommand{HLP} }) {
+      print <<EOF;
+help (?, h): Describe the usage of $prog or its subcommands.
+usage: $prog help [SUBCOMMAND...]
+$copyright
+EOF
+
+      &run_command ([qw/svn help/, $cmd, @ARGV], PRINT => 1);
+
+    } else {
+      warn $prog, ' help: "', $cmd, '" not recognised';
+      $cmd = undef;
+    }
+  }
+
+  if (not $cmd) {
+    # Get output from "svn help"
+    my @lines = &run_command (
+      [qw/svn help/], DEVNULL => 1, METHOD => 'qx', ERROR => 'ignore',
+    );
+
+    # Get release number, (and revision number from revision number file)
+    my $release  = &cfg->setting ('RELEASE');
+    my $rev_file = &cfg->setting ('REV_FILE');
+
+    if (-r $rev_file) {
+      open FILE, '<', $rev_file;
+      my $rev = readline 'FILE';
+      close FILE;
+
+      chomp $rev;
+      $release .= '-dev (r' . $rev . ')' if $rev;
+    }
+
+    # Print common help
+    print <<EOF;
+usage: $prog <subcommand> [options] [args]
+Flexible configuration management system, release $release.
+Type "$prog help <subcommand>" for help on a specific subcommand.
+
+Available subcommands:
+  help       (h, ?) - help
+  build      (bld)  - build system
+EOF
+
+    # The following are only available on platforms with "svn" installed
+    if (@lines) {
+      print <<EOF;
+  branch     (br)   - cm system: branch info & creation
+  cfg               - CFG file pretty printer
+  cmp-ext-cfg       - compare two similar extract configuration files
+  conflicts  (cf)   - cm system: resolve conflicts
+  extract    (ext)  - extract system
+  mkpatch           - create patches from specified revisions of a URL
+  trac       (www)  - cm system: browse a path using the web browser
+  <SVN COMMANDS>    - any Subversion sub-commands
+EOF
+    }
+
+    # Print FCM copyright notice
+    print $copyright;
+
+    # Print output from "svn help"
+    if (@lines) {
+      print "\n";
+      &print_command ([qw/svn help/]);
+      print @lines;
+    }
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ans = &main::get_input (MESSAGE => $mesg, TYPE => $type, DEFAULT => $def);
+#
+# DESCRIPTION
+#   Get an input string from the user and return it as $ans. MESSAGE is the
+#   main message printed on screen to prompt the user for an input.  If TYPE is
+#   'YN', print message to prompt user to enter either 'y' or 'n'. If TYPE is
+#   'YNA', then 'a' is given as a third option. If DEFAULT is set, print message
+#   to inform user that the return value will be set to the $def (if nothing is
+#   entered).
+# ------------------------------------------------------------------------------
+
+sub get_input {
+  my %args = @_;
+  my $type  = exists $args{TYPE}    ? $args{TYPE}    : '';
+  my $mesg  = exists $args{MESSAGE} ? $args{MESSAGE} : '';
+  my $def   = exists $args{DEFAULT} ? $args{DEFAULT} : '';
+
+  my $ans;
+
+  while (1) {
+    # Print the prompt
+    print $mesg;
+    print "\n", 'Enter "y" or "n"' if uc ($type) eq 'YN';
+    print "\n", 'Enter "y", "n" or "a"' if uc ($type) eq 'YNA';
+    print ' (or just press <return> for "', $def, '")' if $def;
+    print ': ';
+
+    # Get answer from STDIN
+    $ans = <STDIN>;
+    chomp $ans;
+
+    # Set answer to default, if necessary
+    $ans = $def if ($def and not $ans);
+
+    if ($type =~ /^yna?$/i) {
+      # For YN and YNA type dialog boxes,
+      # check that the answer is in the correct form
+      my $pat = (uc ($type) eq 'YN' ? 'y|n' : 'y|n|a');
+      last if $ans =~ /^(?:$pat)/i;
+
+    } else {
+      last;
+    }
+  }
+
+  return $ans;
+}
+
+# ------------------------------------------------------------------------------
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_graphic_diff
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_graphic_diff	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_graphic_diff	(revision 7236)
@@ -0,0 +1,90 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   fcm_graphic_diff
+#
+# SYNOPSIS
+#   fcm_graphic_diff [-u] [-L OLD_DESC] [-L NEW_DESC] OLD NEW
+#
+# DESCRIPTION
+#   Wrapper script which invokes a graphical diff tool. Its interface is
+#   compatible with the "svn diff" command and can be used in combination with
+#   its "--diff-cmd" option. The command prints the OLD_DESC and NEW_DESC if
+#   they are both set. The two arguments OLD and NEW must be set and are the
+#   files to compare. The graphical diff tool invoked depends on the value of
+#   the FCM_GRAPHIC_DIFF environment variable. The command exits if the
+#   environment variable is not set.
+#
+# COPYRIGHT
+#   This program is part of the FCM system.
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+# Standard pragmas:
+use warnings;
+use strict;
+
+use Getopt::Long;
+
+# ------------------------------------------------------------------------------
+
+my ($u, @label);
+GetOptions ('u' => \$u, 'L=s' => \@label);
+
+# Check existence of files
+for my $i (0 .. 1) {
+  die $ARGV[$i], ': not found, abort' unless $ARGV[$i] and -f $ARGV[$i];
+}
+
+my ($old, $new) = @ARGV;
+
+if ($old =~ m#.svn/empty-file$#) {
+  print 'Skipping new file', "\n\n";
+
+} elsif ($new =~ m#.svn/empty-file$#) {
+  print 'Skipping deleted file', "\n\n";
+
+} elsif (-z $old) {
+  print 'Skipping as old file is empty (or does not exist)', "\n\n";
+
+} elsif (-z $new) {
+  print 'Skipping as new file is empty (or deleted)', "\n\n";
+
+} elsif (-B $new) {
+  print 'Skipping binary file', "\n\n";
+
+} else {
+  # Print descriptions of files
+  if (@label >= 2) {
+    print '--- ', $label[0], "\n", '+++ ', $label[1], "\n\n";
+  }
+
+  # FCM_GRAPHIC_DIFF is the graphical diff tool command
+  my $cmd = (exists $ENV{FCM_GRAPHIC_DIFF} ? $ENV{FCM_GRAPHIC_DIFF} : 'xxdiff');
+
+  if ($cmd) {
+    my @options = ();
+
+    # Set options for labels if appropriate
+    if (@label >= 2) {
+      if ($cmd eq 'tkdiff') {
+        # Use tkdiff
+        @options = ('-L', $label[0], '-L', $label[1]);
+
+      } elsif ($cmd eq 'xxdiff') {
+        # Use xxdiff
+        @options = ('--title1', $label[0], '--title2', $label[1]);
+      }
+    }
+
+    # Execute the command
+    my @command = ($cmd, @options, $old, $new);
+    exec (@command) or die 'Cannot execute: ', join (' ', @command);
+  }
+
+  exit;
+}
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_gui
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_gui	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_gui	(revision 7236)
@@ -0,0 +1,1321 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   fcm_gui
+#
+# SYNOPSIS
+#   fcm_gui [DIR]
+#
+# DESCRIPTION
+#   The fcm_gui command is a simple graphical user interface for some of the
+#   commands of the FCM system. The optional argument DIR modifies the initial
+#   working directory.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+# Standard pragmas
+use warnings;
+use strict;
+
+# Standard modules
+use File::Basename;
+use File::Spec::Functions;
+use Cwd;
+use Tk;
+use Tk::ROText;
+
+# FCM component modules:
+use lib catfile (dirname (dirname ($0)), 'lib');
+use Fcm::Config;
+use Fcm::Util;
+use Fcm::Timer;
+
+# ------------------------------------------------------------------------------
+
+# Argument
+if (@ARGV) {
+  my $dir = shift @ARGV;
+  chdir $dir if -d $dir;
+}
+
+# Get configuration settings
+my $config = Fcm::Config->new ();
+$config->get_config ();
+
+# ------------------------------------------------------------------------------
+
+# FCM subcommands
+my @subcmds = qw/CHECKOUT BRANCH STATUS DIFF ADD DELETE MERGE CONFLICTS COMMIT
+                 UPDATE SWITCH/;
+
+# Subcommands allowed when CWD is not a WC
+my @nwc_subcmds = qw/CHECKOUT BRANCH/;
+
+# Subcommands allowed, when CWD is a WC
+my @wc_subcmds = qw/STATUS BRANCH DIFF ADD DELETE MERGE CONFLICTS COMMIT UPDATE
+                    SWITCH/;
+
+# Subcommands that apply to WC only
+my @wco_subcmds = qw/BRANCH STATUS DIFF ADD DELETE MERGE CONFLICTS COMMIT UPDATE
+                     SWITCH/;
+
+# Subcommands that apply to top level WC only
+my @wcto_subcmds = qw/BRANCH MERGE COMMIT UPDATE SWITCH/;
+
+# Selected subcommand
+my $selsubcmd = '';
+
+# Selected subcommand is running?
+my $cmdrunning = 0;
+
+# PID of running subcommand
+my $cmdpid = undef;
+
+# List of subcommand frames
+my %subcmd_f;
+
+# List of subcommand buttons
+my %subcmd_b;
+
+# List of subcommand button help strings
+my %subcmd_help = (
+  BRANCH    => 'list information about, create or delete a branch.',
+  CHECKOUT  => 'check out a working copy from a repository.',
+  STATUS    => 'print the status of working copy files and directories.',
+  DIFF      => 'display the differences in modified files.',
+  ADD       => 'put files and directories under version control.',
+  DELETE    => 'remove files and directories from version control.',
+  MERGE     => 'merge changes into your working copy.',
+  CONFLICTS => 'use "xxdiff" to resolve any conflicts within your working copy.',
+  COMMIT    => 'send changes from your working copy to the repository.',
+  UPDATE    => 'bring changes from the repository into your working copy.',
+  SWITCH    => 'update your working copy to a different URL.',
+);
+
+for (keys %subcmd_help) {
+  $subcmd_help{$_} = 'Select the "' . lc ($_) . '" sub-command - ' .
+                     $subcmd_help{$_};
+}
+
+# List of subcommand button bindings (key name and underline position)
+my %subcmd_bind = (
+  BRANCH    => {KEY => '<Alt-Key-b>', U => 0},
+  CHECKOUT  => {KEY => '<Alt-Key-o>', U => 5},
+  STATUS    => {KEY => '<Alt-Key-s>', U => 0},
+  DIFF      => {KEY => '<Alt-Key-d>', U => 0},
+  ADD       => {KEY => '<Alt-Key-a>', U => 0},
+  DELETE    => {KEY => '<Alt-Key-t>', U => 4},
+  MERGE     => {KEY => '<Alt-Key-m>', U => 0},
+  CONFLICTS => {KEY => '<Alt-Key-f>', U => 3},
+  COMMIT    => {KEY => '<Alt-Key-c>', U => 0},
+  UPDATE    => {KEY => '<Alt-Key-u>', U => 0},
+  SWITCH    => {KEY => '<Alt-Key-w>', U => 1},
+);
+
+# List of subcommand variables
+my %subcmdvar = (
+  CWD       => cwd (),
+  WCT       => '',
+  CWD_URL   => '',
+  WCT_URL   => '',
+
+  BRANCH    => {
+    OPT     => 'info',
+    URL     => '',
+    NAME    => '',
+    TYPE    => 'DEV',
+    REVFLAG => 'NORMAL',
+    REV     => '',
+    TICKET  => '',
+    SRCTYPE => 'trunk',
+    S_CHD   => 0,
+    S_SIB   => 0,
+    S_OTH   => 0,
+    VERBOSE => 0,
+    OTHER   => '',
+  },
+
+  CHECKOUT  => {
+    URL     => '',
+    REV     => 'HEAD',
+    PATH    => '',
+    OTHER   => '',
+  },
+
+  STATUS    => {
+    USEWCT  => 0,
+    UPDATE  => 0,
+    VERBOSE => 0,
+    OTHER   => '',
+  },
+
+  DIFF      => {
+    USEWCT  => 0,
+    GRAPHIC => 1,
+    BRANCH  => 0,
+    URL     => '',
+    OTHER   => '',
+  },
+
+  ADD       => {
+    USEWCT  => 0,
+    CHECK   => 1,
+    OTHER   => '',
+  },
+
+  DELETE    => {
+    USEWCT  => 0,
+    CHECK   => 1,
+    OTHER   => '',
+  },
+
+  MERGE     => {
+    USEWCT  => 1,
+    SRC     => '',
+    MODE    => 'automatic',
+    DRYRUN  => 0,
+    VERBOSE => 0,
+    REV     => '',
+    OTHER   => '',
+  },
+
+  CONFLICTS => {
+    USEWCT  => 0,
+    OTHER   => '',
+  },
+
+  COMMIT    => {
+    USEWCT  => 1,
+    DRYRUN  => 0,
+    OTHER   => '',
+  },
+
+  UPDATE    => {
+    USEWCT  => 1,
+    OTHER   => '',
+  },
+
+  SWITCH    => {
+    USEWCT  => 1,
+    URL     => '',
+    OTHER   => '',
+  },
+);
+
+# List of action buttons
+my %action_b;
+
+# List of action button help strings
+my %action_help = (
+  QUIT  => 'Quit fcm gui',
+  HELP  => 'Print help to the output text box for the selected sub-command',
+  CLEAR => 'Clear the output text box',
+  RUN   => 'Run the selected sub-command',
+);
+
+# List of action button bindings
+my %action_bind = (
+  QUIT  => {KEY => '<Control-Key-q>', U => undef},
+  HELP  => {KEY => '<F1>'           , U => undef},
+  CLEAR => {KEY => '<Alt-Key-l>'    , U => 1},
+  RUN   => {KEY => '<Alt-Key-r>'    , U => 0},
+);
+
+# List of branch subcommand options
+my %branch_opt = (
+  INFO   => undef,
+  CREATE => undef,
+  DELETE => undef,
+  LIST   => undef,
+);
+
+# List of branch create types
+my %branch_type = (
+  'DEV'         => undef,
+  'DEV::SHARE'  => undef,
+  'TEST'        => undef,
+  'TEST::SHARE' => undef,
+  'PKG'         => undef,
+  'PKG::SHARE'  => undef,
+  'PKG::CONFIG' => undef,
+  'PKG::REL'    => undef,
+);
+
+# List of branch create source type
+my %branch_srctype = (
+  TRUNK  => undef,
+  BRANCH => undef,
+);
+
+# List of branch create revision prefix option
+my %branch_revflag = (
+  NORMAL => undef,
+  NUMBER => undef,
+  NONE   => undef,
+);
+
+# List of branch info/delete options
+my %branch_info_opt = (
+  S_CHD   => 'Show children',
+  S_SIB   => 'Show siblings',
+  S_OTH   => 'Show other',
+  VERBOSE => 'Print extra information',
+);
+
+# Text in the status bar
+my $statustext = '';
+
+# ------------------------------------------------------------------------------
+
+my $mw = MainWindow->new ();
+
+my $mw_title = 'FCM GUI';
+$mw->title ($mw_title);
+
+# Frame containing subcommand selection buttons
+my $top_f = $mw->Frame ()->grid (
+  '-row'    => 0,
+  '-column' => 0,
+  '-sticky' => 'w',
+);
+
+# Frame containing subcommand options
+my $mid_f = $mw->Frame ()->grid (
+  '-row'    => 1,
+  '-column' => 0,
+  '-sticky' => 'ew',
+);
+
+# Frame containing action buttons
+my $bot_f = $mw->Frame ()->grid (
+  '-row'    => 2,
+  '-column' => 0,
+  '-sticky' => 'ew',
+);
+
+# Text box to display output
+my $out_t  = $mw->Scrolled ('ROText', '-scrollbars' => 'osow')->grid (
+  '-row'    => 3,
+  '-column' => 0,
+  '-sticky' => 'news',
+);
+
+# Text box - allow scroll with mouse wheel
+$out_t->bind (
+  '<4>' => sub {
+    $_[0]->yview ('scroll', -1, 'units') unless $Tk::strictMotif;
+  },
+);
+
+$out_t->bind (
+  '<5>' => sub {
+    $_[0]->yview ('scroll', +1, 'units') unless $Tk::strictMotif;
+  },
+);
+
+# Status bar
+$mw->Label (
+  '-textvariable' => \$statustext,
+  '-relief'       => 'groove',
+)->grid (
+  '-row'    => 4,
+  '-column' => 0,
+  '-sticky' => 'ews',
+);
+
+# Main window grid configure
+{
+  my ($cols, $rows) = $mw->gridSize ();
+  $mw->gridColumnconfigure ($_, '-weight' => 1) for (0 .. $cols - 1);
+  $mw->gridRowconfigure    ( 3, '-weight' => 1);
+}
+
+# Frame grid configure
+{
+  my ($cols, $rows) = $mid_f->gridSize ();
+  $bot_f->gridColumnconfigure (3, '-weight' => 1);
+}
+
+$mid_f->gridRowconfigure    (0, '-weight' => 1);
+$mid_f->gridColumnconfigure (0, '-weight' => 1);
+
+# ------------------------------------------------------------------------------
+
+# Buttons to select subcommands
+{
+  my $col = 0;
+  for my $name (@subcmds) {
+    $subcmd_b{$name} = $top_f->Button (
+      '-text'    => uc (substr ($name, 0, 1)) . lc (substr ($name, 1)),
+      '-command' => [\&button_clicked, $name],
+      '-width'   => 8,
+    )->grid (
+      '-row'    => 0,
+      '-column' => $col++,
+      '-sticky' => 'w',
+    );
+
+    $subcmd_b{$name}->bind ('<Enter>', sub {$statustext = $subcmd_help{$name}});
+    $subcmd_b{$name}->bind ('<Leave>', sub {$statustext = ''});
+
+    $subcmd_b{$name}->configure ('-underline' => $subcmd_bind{$name}{U})
+      if defined $subcmd_bind{$name}{U};
+
+    $mw->bind ($subcmd_bind{$name}{KEY}, sub {$subcmd_b{$name}->invoke});
+  }
+}
+
+# ------------------------------------------------------------------------------
+
+# Frames to contain subcommands options
+{
+  my %row = ();
+
+  for my $name (@subcmds) {
+    $subcmd_f{$name} = $mid_f->Frame ();
+    $subcmd_f{$name}->gridColumnconfigure (1, '-weight' => 1);
+
+    $row{$name} = 0;
+
+    # Widgets common to all sub-commands
+    $subcmd_f{$name}->Label ('-text' => 'Current working directory: ')->grid (
+      '-row'    => $row{$name},
+      '-column' => 0,
+      '-sticky' => 'w',
+    );
+    $subcmd_f{$name}->Label ('-textvariable' => \($subcmdvar{CWD}))->grid (
+      '-row'    => $row{$name}++,
+      '-column' => 1,
+      '-sticky' => 'w',
+    );
+  }
+
+  # Widgets common to all sub-commands that apply to working copies
+  for my $name (@wco_subcmds) {
+    my @labtxts = (
+      'Corresponding URL: ',
+      'Working copy top: ',
+      'Corresponding URL: ',
+    );
+    my @varrefs = \(
+      $subcmdvar{URL_CWD},
+      $subcmdvar{WCT},
+      $subcmdvar{URL_WCT},
+    );
+
+    for my $i (0 .. $#varrefs) {
+      $subcmd_f{$name}->Label ('-text' => $labtxts[$i])->grid (
+        '-row'    => $row{$name},
+        '-column' => 0,
+        '-sticky' => 'w',
+      );
+      $subcmd_f{$name}->Label ('-textvariable' => $varrefs[$i])->grid (
+        '-row'    => $row{$name}++,
+        '-column' => 1,
+        '-sticky' => 'w',
+      );
+    }
+
+    $subcmd_f{$name}->Checkbutton (
+      '-text'     => 'Apply sub-command to working copy top',
+      '-variable' => \($subcmdvar{$name}{USEWCT}),
+      '-state'    => (grep ({$_ eq $name} @wcto_subcmds) ? 'disabled' : 'normal'),
+    )->grid (
+      '-row'        => $row{$name}++,
+      '-column'     => 0,
+      '-columnspan' => 2,
+      '-sticky'     => 'w',
+    );
+  }
+
+  # Widget for the Branch sub-command
+  {
+    my $name = 'BRANCH';
+
+    # Radio buttons to select the sub-option of the branch sub-command
+    my $opt_f = $subcmd_f{$name}->Frame ()->grid (
+      '-row'        => $row{$name}++,
+      '-column'     => 0,
+      '-columnspan' => 2,
+      '-sticky'     => 'w',
+    );
+
+    my $col = 0;
+    for my $key (sort keys %branch_opt) {
+      my $opt = lc $key;
+
+      $branch_opt{$key} = $opt_f->Radiobutton (
+        '-text'     => $opt,
+        '-value'    => $opt,
+        '-variable' => \($subcmdvar{$name}{OPT}),
+        '-state'    => 'normal',
+      )->grid (
+        '-row'      => 0,
+        '-column'   => $col++,
+        '-sticky'   => 'w',
+      );
+    }
+
+    # Label and entry box for specifying URL
+    $subcmd_f{$name}->Label ('-text' => 'URL: ')->grid (
+      '-row'    => $row{$name},
+      '-column' => 0,
+      '-sticky' => 'w',
+    );
+    $subcmd_f{$name}->Entry (
+      '-textvariable' => \($subcmdvar{$name}{URL}),
+    )->grid (
+      '-row'    => $row{$name}++,
+      '-column' => 1,
+      '-sticky' => 'ew',
+    );
+
+    # Label and entry box for specifying create branch name
+    $subcmd_f{$name}->Label (
+      '-text' => 'Branch name (create only): ',
+    )->grid (
+      '-row'    => $row{$name},
+      '-column' => 0,
+      '-sticky' => 'w',
+    );
+    $subcmd_f{$name}->Entry (
+      '-textvariable' => \($subcmdvar{$name}{NAME}),
+    )->grid (
+      '-row'    => $row{$name}++,
+      '-column' => 1,
+      '-sticky' => 'ew',
+    );
+
+    # Label and entry box for specifying create branch source revision
+    $subcmd_f{$name}->Label (
+      '-text' => 'Source revision (create/list only): ',
+    )->grid (
+      '-row'    => $row{$name},
+      '-column' => 0,
+      '-sticky' => 'w',
+    );
+    $subcmd_f{$name}->Entry (
+      '-textvariable' => \($subcmdvar{$name}{REV}),
+    )->grid (
+      '-row'    => $row{$name}++,
+      '-column' => 1,
+      '-sticky' => 'ew',
+    );
+
+    # Label and radio buttons box for specifying create branch type
+    $subcmd_f{$name}->Label (
+      '-text' => 'Branch type (create only): ',
+    )->grid (
+      '-row'    => $row{$name},
+      '-column' => 0,
+      '-sticky' => 'w',
+    );
+
+    {
+      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
+        '-row'    => $row{$name}++,
+        '-column' => 1,
+        '-sticky' => 'w',
+      );
+
+      my $col = 0;
+      for my $key (sort keys %branch_type) {
+        my $txt = lc $key;
+        my $opt = $key;
+
+        $branch_opt{$key} = $opt_f->Radiobutton (
+          '-text'     => $txt,
+          '-value'    => $opt,
+          '-variable' => \($subcmdvar{$name}{TYPE}),
+          '-state'    => 'normal',
+        )->grid (
+          '-row'      => 0,
+          '-column'   => $col++,
+          '-sticky'   => 'w',
+        );
+      }
+    }
+
+    # Label and radio buttons box for specifying create source type
+    $subcmd_f{$name}->Label (
+      '-text' => 'Source type (create only): ',
+    )->grid (
+      '-row'    => $row{$name},
+      '-column' => 0,
+      '-sticky' => 'w',
+    );
+
+    {
+      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
+        '-row'    => $row{$name}++,
+        '-column' => 1,
+        '-sticky' => 'w',
+      );
+
+      my $col = 0;
+      for my $key (sort keys %branch_srctype) {
+        my $txt = lc $key;
+        my $opt = lc $key;
+
+        $branch_opt{$key} = $opt_f->Radiobutton (
+          '-text'     => $txt,
+          '-value'    => $opt,
+          '-variable' => \($subcmdvar{$name}{SRCTYPE}),
+          '-state'    => 'normal',
+        )->grid (
+          '-row'      => 0,
+          '-column'   => $col++,
+          '-sticky'   => 'w',
+        );
+      }
+    }
+
+    # Label and radio buttons box for specifying create prefix option
+    $subcmd_f{$name}->Label (
+      '-text' => 'Prefix option (create only): ',
+    )->grid (
+      '-row'    => $row{$name},
+      '-column' => 0,
+      '-sticky' => 'w',
+    );
+
+    {
+      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
+        '-row'    => $row{$name}++,
+        '-column' => 1,
+        '-sticky' => 'w',
+      );
+
+      my $col = 0;
+      for my $key (sort keys %branch_revflag) {
+        my $txt = lc $key;
+        my $opt = $key;
+
+        $branch_opt{$key} = $opt_f->Radiobutton (
+          '-text'     => $txt,
+          '-value'    => $opt,
+          '-variable' => \($subcmdvar{$name}{REVFLAG}),
+          '-state'    => 'normal',
+        )->grid (
+          '-row'      => 0,
+          '-column'   => $col++,
+          '-sticky'   => 'w',
+        );
+      }
+    }
+
+    # Label and entry box for specifying ticket number
+    $subcmd_f{$name}->Label (
+      '-text' => 'Related Trac ticket(s) (create only): ',
+    )->grid (
+      '-row'    => $row{$name},
+      '-column' => 0,
+      '-sticky' => 'w',
+    );
+    $subcmd_f{$name}->Entry (
+      '-textvariable' => \($subcmdvar{$name}{TICKET}),
+    )->grid (
+      '-row'    => $row{$name}++,
+      '-column' => 1,
+      '-sticky' => 'ew',
+    );
+
+    # Check button for info/delete
+    # --show-children, --show-siblings, --show-other, --verbose
+    $subcmd_f{$name}->Label (
+      '-text' => 'Options for info/delete only: ',
+    )->grid (
+      '-row'    => $row{$name},
+      '-column' => 0,
+      '-sticky' => 'w',
+    );
+
+    {
+      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
+        '-row'    => $row{$name}++,
+        '-column' => 1,
+        '-sticky' => 'w',
+      );
+
+      my $col = 0;
+
+      for my $key (sort keys %branch_info_opt) {
+        $opt_f->Checkbutton (
+          '-text'     => $branch_info_opt{$key},
+          '-variable' => \($subcmdvar{$name}{$key}),
+        )->grid (
+          '-row'    => 0,
+          '-column' => $col++,
+          '-sticky' => 'w',
+        );
+      }
+    }
+  }
+
+  # Widget for the Checkout sub-command
+  {
+    my $name = 'CHECKOUT';
+
+    # Label and entry boxes for specifying URL and revision
+    my @labtxts = (
+      'URL: ',
+      'Revision: ',
+      'Path: ',
+    );
+    my @varrefs = \(
+      $subcmdvar{$name}{URL},
+      $subcmdvar{$name}{REV},
+      $subcmdvar{$name}{PATH},
+    );
+
+    for my $i (0 .. $#varrefs) {
+      $subcmd_f{$name}->Label ('-text' => $labtxts[$i])->grid (
+        '-row'    => $row{$name},
+        '-column' => 0,
+        '-sticky' => 'w',
+      );
+      $subcmd_f{$name}->Entry (
+        '-textvariable' => $varrefs[$i],
+      )->grid (
+        '-row'    => $row{$name}++,
+        '-column' => 1,
+        '-sticky' => 'ew',
+      );
+    }
+  }
+
+  # Widget for the Status sub-command
+  {
+    my $name = 'STATUS';
+
+    # Checkbuttons for various options
+    my @labtxts = (
+      'Display update information',
+      'Print extra information',
+    );
+    my @varrefs = \(
+      $subcmdvar{$name}{UPDATE},
+      $subcmdvar{$name}{VERBOSE},
+    );
+
+    for my $i (0 .. $#varrefs) {
+      $subcmd_f{$name}->Checkbutton (
+        '-text'     => $labtxts[$i],
+        '-variable' => $varrefs[$i],
+      )->grid (
+        '-row'        => $row{$name}++,
+        '-column'     => 0,
+        '-columnspan' => 2,
+        '-sticky'     => 'w',
+      );
+    }
+  }
+
+  # Widget for the Diff sub-command
+  {
+    my $name = 'DIFF';
+
+    # Checkbuttons for various options
+    $subcmd_f{$name}->Checkbutton (
+      '-text'     => 'Use xxdiff to display differences',
+      '-variable' => \($subcmdvar{$name}{GRAPHIC}),
+    )->grid (
+      '-row'        => $row{$name}++,
+      '-column'     => 0,
+      '-columnspan' => 2,
+      '-sticky'     => 'w',
+    );
+
+    my $entry;
+    $subcmd_f{$name}->Checkbutton (
+      '-text'     => 'Show differences relative to the base of the branch',
+      '-variable' => \($subcmdvar{$name}{BRANCH}),
+      '-command'  => sub {
+        $entry->configure (
+          '-state' => ($subcmdvar{$name}{BRANCH} ? 'normal' : 'disabled'),
+        );
+      },
+    )->grid (
+      '-row'        => $row{$name}++,
+      '-column'     => 0,
+      '-columnspan' => 2,
+      '-sticky'     => 'w',
+    );
+
+    $subcmd_f{$name}->Label ('-text' => 'Branch URL')->grid (
+      '-row'    => $row{$name},
+      '-column' => 0,
+      '-sticky' => 'w',
+    );
+
+    $entry = $subcmd_f{$name}->Entry (
+      '-textvariable' => \($subcmdvar{$name}{URL}),
+      '-state'        => ($subcmdvar{$name}{BRANCH} ? 'normal' : 'disabled'),
+    )->grid (
+      '-row'    => $row{$name}++,
+      '-column' => 1,
+      '-sticky' => 'ew',
+    );
+  }
+
+  # Widget for the Add/Delete sub-command
+  for my $name (qw/ADD DELETE/) {
+
+    # Checkbuttons for various options
+    $subcmd_f{$name}->Checkbutton (
+      '-text'     => 'Check for files or directories not under version control',
+      '-variable' => \($subcmdvar{$name}{CHECK}),
+    )->grid (
+      '-row'        => $row{$name}++,
+      '-column'     => 0,
+      '-columnspan' => 2,
+      '-sticky'     => 'w',
+    );
+  }
+
+  # Widget for the Merge sub-command
+  {
+    my $name = 'MERGE';
+
+    # Label and radio buttons box for specifying merge mode
+    $subcmd_f{$name}->Label (
+      '-text' => 'Mode: ',
+    )->grid (
+      '-row'    => $row{$name},
+      '-column' => 0,
+      '-sticky' => 'w',
+    );
+
+    {
+      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
+        '-row'    => $row{$name}++,
+        '-column' => 1,
+        '-sticky' => 'w',
+      );
+
+      my $col = 0;
+      for my $key (qw/automatic custom reverse/) {
+        my $txt = lc $key;
+        my $opt = $key;
+
+        $branch_opt{$key} = $opt_f->Radiobutton (
+          '-text'     => $txt,
+          '-value'    => $opt,
+          '-variable' => \($subcmdvar{$name}{MODE}),
+          '-state'    => 'normal',
+        )->grid (
+          '-row'      => 0,
+          '-column'   => $col++,
+          '-sticky'   => 'w',
+        );
+      }
+    }
+
+    # Check buttons for dry-run
+    $subcmd_f{$name}->Checkbutton (
+      '-text'     => 'Dry run',
+      '-variable' => \($subcmdvar{$name}{DRYRUN}),
+    )->grid (
+      '-row'        => $row{$name}++,
+      '-column'     => 0,
+      '-columnspan' => 2,
+      '-sticky'     => 'w',
+    );
+
+    # Check buttons for verbose mode
+    $subcmd_f{$name}->Checkbutton (
+      '-text'     => 'Print extra information',
+      '-variable' => \($subcmdvar{$name}{VERBOSE}),
+    )->grid (
+      '-row'        => $row{$name}++,
+      '-column'     => 0,
+      '-columnspan' => 2,
+      '-sticky'     => 'w',
+    );
+
+    # Label and entry boxes for specifying merge source
+    $subcmd_f{$name}->Label (
+      '-text' => 'Source (automatic/custom only): ',
+    )->grid (
+      '-row'    => $row{$name},
+      '-column' => 0,
+      '-sticky' => 'w',
+    );
+    $subcmd_f{$name}->Entry (
+      '-textvariable' => \($subcmdvar{$name}{SRC}),
+    )->grid (
+      '-row'    => $row{$name}++,
+      '-column' => 1,
+      '-sticky' => 'ew',
+    );
+
+    # Label and entry boxes for specifying merge revision (range)
+    $subcmd_f{$name}->Label (
+      '-text' => 'Revision (custom/reverse only): ',
+    )->grid (
+      '-row'    => $row{$name},
+      '-column' => 0,
+      '-sticky' => 'w',
+    );
+    $subcmd_f{$name}->Entry (
+      '-textvariable' => \($subcmdvar{$name}{REV}),
+    )->grid (
+      '-row'    => $row{$name}++,
+      '-column' => 1,
+      '-sticky' => 'ew',
+    );
+  }
+
+  # Widget for the Commit sub-command
+  {
+    my $name = 'COMMIT';
+
+    # Checkbuttons for various options
+    $subcmd_f{$name}->Checkbutton (
+      '-text'     => 'Dry run',
+      '-variable' => \($subcmdvar{$name}{DRYRUN}),
+    )->grid (
+      '-row'        => $row{$name}++,
+      '-column'     => 0,
+      '-columnspan' => 2,
+      '-sticky'     => 'w',
+    );
+  }
+
+  # Widget for the Switch sub-command
+  {
+    my $name = 'SWITCH';
+
+    # Label and entry boxes for specifying switch URL
+    $subcmd_f{$name}->Label ('-text' => 'URL: ')->grid (
+      '-row'    => $row{$name},
+      '-column' => 0,
+      '-sticky' => 'w',
+    );
+    $subcmd_f{$name}->Entry (
+      '-textvariable' => \($subcmdvar{$name}{URL}),
+    )->grid (
+      '-row'    => $row{$name}++,
+      '-column' => 1,
+      '-sticky' => 'ew',
+    );
+  }
+
+  # Widgets common to all sub-commands
+  for my $name (@subcmds) {
+    $subcmd_f{$name}->Label ('-text' => 'Other options: ')->grid (
+      '-row'    => $row{$name},
+      '-column' => 0,
+      '-sticky' => 'w',
+    );
+    $subcmd_f{$name}->Entry (
+      '-textvariable' => \($subcmdvar{$name}{OTHER}),
+    )->grid (
+      '-row'    => $row{$name}++,
+      '-column' => 1,
+      '-sticky' => 'ew',
+    );
+  }
+}
+
+# ------------------------------------------------------------------------------
+
+# Buttons to perform main actions
+{
+  my $col = 0;
+  for my $name (qw/QUIT HELP CLEAR RUN/) {
+    $action_b{$name} = $bot_f->Button (
+      '-text'    => uc (substr ($name, 0, 1)) . lc (substr ($name, 1)),
+      '-command' => [\&button_clicked, $name],
+      '-width'   => 8,
+    )->grid (
+      '-row'    => 0,
+      '-column' => $col++,
+      '-sticky' => ($name eq 'RUN' ? 'ew' : 'w'),
+    );
+
+    $action_b{$name}->bind ('<Enter>', sub {$statustext = $action_help{$name}});
+    $action_b{$name}->bind ('<Leave>', sub {$statustext = ''});
+
+    $action_b{$name}->configure ('-underline' => $action_bind{$name}{U})
+      if defined $action_bind{$name}{U};
+
+    $mw->bind ($action_bind{$name}{KEY}, sub {$action_b{$name}->invoke});
+  }
+}
+
+&change_cwd ($subcmdvar{CWD});
+
+# ------------------------------------------------------------------------------
+
+# Handle the situation when the user attempts to quit the window while a
+# sub-command is running
+
+$mw->protocol ('WM_DELETE_WINDOW', sub {
+  if (defined $cmdpid) {
+    my $ans = $mw->messageBox (
+      '-title'   => $mw_title,
+      '-message' => $selsubcmd . ' is still running. Really quit?',
+      '-type'    => 'YesNo',
+      '-default' => 'No',
+    );
+
+    if ($ans eq 'Yes') {
+      kill 9, $cmdpid; # Need to kill the sub-process before quitting
+
+    } else {
+      return; # Do not quit
+    }
+  }
+
+  exit;
+});
+
+MainLoop;
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cfg = &main::cfg ();
+#
+# DESCRIPTION
+#   Return the $config variable.
+# ------------------------------------------------------------------------------
+
+sub cfg {
+  return $config;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &change_cwd ($dir);
+#
+# DESCRIPTION
+#   Change current working directory to $dir
+# ------------------------------------------------------------------------------
+
+sub change_cwd {
+  my $dir = $_[0];
+  my @allowed_subcmds = (&is_wc ($dir) ? @wc_subcmds : @nwc_subcmds);
+
+  for my $subcmd (@subcmds) {
+    if (grep {$_ eq $subcmd} @allowed_subcmds) {
+      $subcmd_b{$subcmd}->configure ('-state' => 'normal');
+
+    } else {
+      $subcmd_b{$subcmd}->configure ('-state' => 'disabled');
+    }
+  }
+
+  &display_subcmd_frame ($allowed_subcmds[0])
+    if not grep {$_ eq $selsubcmd} @allowed_subcmds;
+
+  chdir $dir;
+  $subcmdvar{CWD} = $dir;
+
+  if (&is_wc ($dir)) {
+    $subcmdvar{WCT}     = &get_wct ($dir);
+    $subcmdvar{URL_CWD} = &get_url_of_wc ($dir);
+    $subcmdvar{URL_WCT} = &get_url_of_wc ($subcmdvar{WCT});
+
+    $branch_opt{INFO}  ->configure ('-state' => 'normal');
+    $branch_opt{DELETE}->configure ('-state' => 'normal');
+    $subcmdvar{BRANCH}{OPT} = 'info';
+
+  } else {
+    $branch_opt{INFO}  ->configure ('-state' => 'disabled');
+    $branch_opt{DELETE}->configure ('-state' => 'disabled');
+    $subcmdvar{BRANCH}{OPT} = 'create';
+  }
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &button_clicked ($name);
+#
+# DESCRIPTION
+#   Call back function to handle a click on a command button named $name.
+# ------------------------------------------------------------------------------
+
+sub button_clicked {
+  my $name = $_[0];
+
+  if (grep {$_ eq $name} keys %subcmd_b) {
+    &display_subcmd_frame ($name);
+
+  } elsif ($name eq 'CLEAR') {
+    $out_t->delete ('1.0', 'end');
+
+  } elsif ($name eq 'QUIT') {
+    exit;
+
+  } elsif ($name eq 'HELP') {
+    &invoke_cmd ('help ' . lc ($selsubcmd));
+
+  } elsif ($name eq 'RUN') {
+    &invoke_cmd (&setup_cmd ($selsubcmd));
+
+  } else {
+    $out_t->insert ('end', $name . ': function to be implemented' . "\n");
+    $out_t->yviewMoveto (1);
+  }
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &display_subcmd_frame ($name);
+#
+# DESCRIPTION
+#   Change selected subcommand to $name, and display the frame containing the
+#   widgets for configuring the options and arguments of that subcommand.
+# ------------------------------------------------------------------------------
+
+sub display_subcmd_frame {
+  my $name = $_[0];
+
+  if ($selsubcmd ne $name and not $cmdrunning) {
+    $subcmd_b{$name     }->configure ('-relief' => 'sunken');
+    $subcmd_b{$selsubcmd}->configure ('-relief' => 'raised') if $selsubcmd;
+
+    $subcmd_f{$name     }->grid ('-sticky' => 'new');
+    $subcmd_f{$selsubcmd}->gridForget if $selsubcmd;
+
+    $selsubcmd = $name;
+  }
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $pos = &get_wm_pos ();
+#
+# DESCRIPTION
+#   Returns the position part of the geometry string of the main window.
+# ------------------------------------------------------------------------------
+
+sub get_wm_pos {
+  my $geometry = $mw->geometry ();
+  $geometry =~ /^=?(?:\d+x\d+)?([+-]\d+[+-]\d+)$/;
+  return $1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $command = &setup_cmd ($name);
+#
+# DESCRIPTION
+#   Setup the the system command for the sub-command $name.
+# ------------------------------------------------------------------------------
+
+sub setup_cmd {
+  my $name = $_[0];
+  my $cmd  = '';
+
+  if ($name eq 'BRANCH') {
+    $cmd .= lc ($name);
+    if ($subcmdvar{$name}{OPT} eq 'create') {
+      $cmd .= ' -c --svn-non-interactive';
+      $cmd .= ' -n '     . $subcmdvar{$name}{NAME} if $subcmdvar{$name}{NAME};
+      $cmd .= ' -t '     . $subcmdvar{$name}{TYPE};
+      $cmd .= ' --rev-flag ' . $subcmdvar{$name}{REVFLAG};
+      $cmd .= ' -r ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
+      $cmd .= ' -k ' . $subcmdvar{$name}{TICKET} if $subcmdvar{$name}{TICKET};
+      $cmd .= ' --branch-of-branch ' if $subcmdvar{$name}{SRCTYPE} eq 'branch';
+
+    } elsif ($subcmdvar{$name}{OPT} eq 'delete') {
+      $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
+      $cmd .= ' -d --svn-non-interactive';
+
+    } elsif ($subcmdvar{$name}{OPT} eq 'list') {
+      $cmd .= ' -l';
+      $cmd .= ' -r ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
+
+    } else {
+      $cmd .= ' -i';
+      $cmd .= ' --show-children' if $subcmdvar{$name}{S_CHD};
+      $cmd .= ' --show-siblings' if $subcmdvar{$name}{S_SIB};
+      $cmd .= ' --show-other'    if $subcmdvar{$name}{S_OTH};
+      $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
+    }
+    $cmd .= ' ' . $subcmdvar{$name}{URL}   if $subcmdvar{$name}{URL};
+    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+  } elsif ($name eq 'CHECKOUT') {
+    $cmd .= lc ($name);
+    $cmd .= ' -r' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
+    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+    $cmd .= ' ' . $subcmdvar{$name}{URL};
+    $cmd .= ' ' . $subcmdvar{$name}{PATH} if $subcmdvar{$name}{PATH};
+
+  } elsif ($name eq 'STATUS') {
+    $cmd .= lc ($name);
+    $cmd .= ' -u' if $subcmdvar{$name}{UPDATE};
+    $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
+    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+  } elsif ($name eq 'DIFF') {
+    $cmd .= lc ($name);
+    $cmd .= ' -g' if $subcmdvar{$name}{GRAPHIC};
+
+    if ($subcmdvar{$name}{BRANCH}) {
+      $cmd .= ' -b';
+      $cmd .= ' ' . $subcmdvar{$name}{URL} if $subcmdvar{$name}{URL};
+    }
+
+    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+  } elsif ($name eq 'ADD' or $name eq 'DELETE') {
+    $cmd .= lc ($name);
+    $cmd .= ' -c' if $subcmdvar{$name}{CHECK};
+    $cmd .= ' --non-interactive'
+      if $name eq 'DELETE' and not $subcmdvar{$name}{CHECK};
+    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+  } elsif ($name eq 'MERGE') {
+    $cmd .= lc ($name);
+
+    if ($subcmdvar{$name}{MODE} ne 'automatic') {
+      $cmd .= ' --' . $subcmdvar{$name}{MODE};
+      $cmd .= ' --revision ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
+    }
+
+    $cmd .= ' --dry-run' if $subcmdvar{$name}{DRYRUN};
+    $cmd .= ' -v'        if $subcmdvar{$name}{VERBOSE};
+    $cmd .= ' ' . $subcmdvar{$name}{SRC}   if $subcmdvar{$name}{SRC};
+    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+  } elsif ($name eq 'CONFLICTS') {
+    $cmd .= lc ($name);
+    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+  } elsif ($name eq 'COMMIT') {
+    $cmd .= lc ($name);
+    $cmd .= ' --dry-run' if $subcmdvar{$name}{DRYRUN};
+    $cmd .= ' --svn-non-interactive';
+    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+  } elsif ($name eq 'SWITCH') {
+    $cmd .= lc ($name);
+    $cmd .= ' ' . $subcmdvar{$name}{URL}   if $subcmdvar{$name}{URL};
+    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+  } elsif ($name eq 'UPDATE') {
+    $cmd .= lc ($name);
+    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
+
+  }
+
+  return $cmd;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &invoke_cmd ($cmd);
+#
+# DESCRIPTION
+#   Invoke the command $cmd.
+# ------------------------------------------------------------------------------
+
+sub invoke_cmd {
+  my $cmd      = $_[0];
+  return unless $cmd;
+
+  my $disp_cmd = 'fcm ' . $cmd;
+  $cmd         = (index ($cmd, 'help ') == 0)
+                 ? $disp_cmd
+                 : ('fcm_gui_internal ' . &get_wm_pos () . ' ' . $cmd);
+
+  # Change directory to working copy top if necessary
+  if ($subcmdvar{$selsubcmd}{USEWCT} and $subcmdvar{WCT} ne $subcmdvar{CWD}) {
+    chdir $subcmdvar{WCT};
+    $out_t->insert ('end', 'cd ' . $subcmdvar{WCT} . "\n");
+    $out_t->yviewMoveto (1);
+  }
+
+  # Report start of command
+  $out_t->insert ('end', timestamp_command ($disp_cmd, 'Start'));
+  $out_t->yviewMoveto (1);
+
+  # Open the command as a pipe
+  if ($cmdpid = open CMD, '-|', $cmd . ' 2>&1') {
+    # Disable all action buttons
+    $action_b{$_}->configure ('-state' => 'disabled') for (keys %action_b);
+    $cmdrunning = 1;
+
+    # Set up a file event to read output from the command
+    $mw->fileevent (\*CMD, readable => sub {
+      if (sysread CMD, my ($buf), 1024) {
+        # Insert text into the output text box as it becomes available
+        $out_t->insert ('end', $buf);
+        $out_t->yviewMoveto (1);
+
+      } else {
+        # Delete the file event and close the file when the command finishes
+        $mw->fileevent(\*CMD, readable => '');
+        close CMD;
+        $cmdpid = undef;
+
+        # Check return status
+        if ($?) {
+          $out_t->insert (
+            'end', '"' . $disp_cmd . '" failed (' . $? . ')' . "\n",
+          );
+          $out_t->yviewMoveto (1);
+        }
+
+        # Report end of command
+        $out_t->insert ('end', timestamp_command ($disp_cmd, 'End'));
+        $out_t->yviewMoveto (1);
+
+        # Change back to CWD if necessary
+        if ($subcmdvar{$selsubcmd}{USEWCT} and
+            $subcmdvar{WCT} ne $subcmdvar{CWD}) {
+          chdir $subcmdvar{CWD};
+          $out_t->insert ('end', 'cd ' . $subcmdvar{CWD} . "\n");
+          $out_t->yviewMoveto (1);
+        }
+
+        # Enable all action buttons again
+        $action_b{$_}->configure ('-state' => 'normal') for (keys %action_b);
+        $cmdrunning = 0;
+
+        # If the command is "checkout", change directory to working copy
+        if (lc ($selsubcmd) eq 'checkout') {
+          my $url = expand_url_keyword (URL => $subcmdvar{CHECKOUT}{URL});
+          my $dir = $subcmdvar{CHECKOUT}{PATH}
+                  ? $subcmdvar{CHECKOUT}{PATH}
+                  : basename $url;
+          $dir    = File::Spec->rel2abs ($dir);
+          &change_cwd ($dir);
+
+        # If the command is "switch", change URL
+        } elsif (lc ($selsubcmd) eq 'switch') {
+          $subcmdvar{URL_CWD} = &get_url_of_wc ($subcmdvar{CWD}, 1);
+          $subcmdvar{URL_WCT} = &get_url_of_wc ($subcmdvar{WCT}, 1);
+        }
+      }
+      1;
+    });
+
+  } else {
+    $mw->messageBox (
+      '-title'   => 'Error',
+      '-message' => 'Error running "' . $cmd . '"',
+      '-icon'    => 'error',
+    );
+  }
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_gui_internal
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_gui_internal	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_gui_internal	(revision 7236)
@@ -0,0 +1,272 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   fcm_gui_internal
+#
+# SYNOPSIS
+#   fcm_gui_internal POS FUNCTION
+#
+# DESCRIPTION
+#   The fcm_gui_internal command is part of a simple graphical user interface
+#   for some of the commands of the FCM system. The argument POS is a geometry
+#   string used by the &Main::get_input method to determine the location of the
+#   pop up window. The argument FUNCTION must be a keyword recognised by the
+#   &Fcm::Cm::cm_command function.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+# Standard pragmas
+use warnings;
+use strict;
+
+# Standard modules
+use Tk;
+use File::Basename;
+use File::Spec::Functions;
+
+# FCM component modules:
+use lib catfile (dirname (dirname ($0)), 'lib');
+use Fcm::Cm;
+use Fcm::Config;
+
+# ------------------------------------------------------------------------------
+
+# Get configuration settings
+my $config = Fcm::Config->new ();
+$config->get_config ();
+
+my $pos      = shift @ARGV;
+my $function = shift @ARGV;
+cm_command $function;
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cfg = &main::cfg ();
+#
+# DESCRIPTION
+#   Return the $config variable.
+# ------------------------------------------------------------------------------
+
+sub cfg {
+  return $config;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ans = &main::get_input (
+#     TITLE   => $title,
+#     MESSAGE => $mesg,
+#     TYPE    => $type,
+#     DEFAULT => $def,
+#   );
+#
+# DESCRIPTION
+#   Get an input string from the user and return it as $ans. If TYPE is 'YN', a
+#   'YesNo' type message box will be displayed to prompt the user to click
+#   either the 'yes' or 'no' button. If TYPE is 'YNA', then an 'all' button is
+#   provided as a third option. Otherwise, a dialog box with an entry box for
+#   the user to type in a string will be displayed. TITLE is the title of the
+#   dialog box, and MESSAGE is the main message of the dialog box. If DEFAULT is
+#   set, $ans is set to the default value when the dialog box is invoked.
+# ------------------------------------------------------------------------------
+
+sub get_input {
+  my %args  = @_;
+  my $title = exists $args{TITLE}   ? $args{TITLE}   : '';
+  my $mesg  = exists $args{MESSAGE} ? $args{MESSAGE} : '';
+  my $type  = exists $args{TYPE}    ? $args{TYPE}    : '';
+  my $def   = exists $args{DEFAULT} ? $args{DEFAULT} : '';
+  my $ans   = '';
+
+  # Create a main window
+  my $mw = MainWindow->new;
+  $mw->title ($title);
+
+  # Define the default which applies if the dialog box is just closed or
+  # the user selects 'cancel'
+  $ans = $def ? $def : '';
+
+  if ($type =~ /^yn/i) {
+    # Create a yes-no(-all) dialog box
+
+    # If TYPE is YNA then add a third button: 'all'
+    my $buttons;
+    if ($type =~ /a$/i) {
+      $buttons = 3;
+
+    } else {
+      $buttons = 2;
+    }
+
+    # Message of the dialog box
+    $mw->Label ('-text' => $mesg)->grid (
+      '-row'        => 0,
+      '-column'     => 0,
+      '-columnspan' => $buttons,
+      '-padx'       => 10,
+      '-pady'       => 10,
+    );
+
+    # The "yes" button
+    my $y_b = $mw->Button (
+      '-text'      => 'Yes',
+      '-underline' => 0,
+      '-command'   => sub {$ans = 'y'; $mw->destroy},
+    )->grid (
+      '-row'    => 1,
+      '-column' => 0,
+      '-padx'   => 5,
+      '-pady'   => 5,
+    );
+
+    # The "no" button
+    my $n_b = $mw->Button (
+      '-text'      => 'No',
+      '-underline' => 0,
+      '-command'   => sub {$ans = 'n'; $mw->destroy},
+    )->grid (
+      '-row'    => 1,
+      '-column' => 1,
+      '-padx'   => 5,
+      '-pady'   => 5,
+    );
+
+    # The "all" button
+    my $a_b;
+    if ($buttons == 3) {
+      $a_b = $mw->Button (
+        '-text'      => 'All',
+        '-underline' => 0,
+        '-command'   => sub {$ans = 'a'; $mw->destroy},
+      )->grid (
+        '-row'    => 1,
+        '-column' => 2,
+        '-padx'   => 5,
+        '-pady'   => 5,
+      );
+    }
+
+    # Keyboard binding
+    if ($buttons == 3) {
+      $mw->bind ('<Key>' => sub {
+	if ($Tk::event->K eq 'Y' or $Tk::event->K eq 'y') {
+	  $y_b->invoke;
+
+	} elsif ($Tk::event->K eq 'N' or $Tk::event->K eq 'n') {
+	  $n_b->invoke;
+
+	} elsif ($Tk::event->K eq 'A' or $Tk::event->K eq 'a') {
+	  $a_b->invoke;
+	}
+      });
+
+    } else {
+      $mw->bind ('<Key>' => sub {
+	if ($Tk::event->K eq 'Y' or $Tk::event->K eq 'y') {
+	  $y_b->invoke;
+
+	} elsif ($Tk::event->K eq 'N' or $Tk::event->K eq 'n') {
+	  $n_b->invoke;
+	}
+      });
+    }
+
+    # Handle the situation when the user attempts to quit the window
+    $mw->protocol ('WM_DELETE_WINDOW', sub {
+      $ans = $def if $def;
+      $mw->destroy;
+    });
+
+  } else {
+    # Create a dialog box to obtain an input string
+
+    # Message of the dialog box
+    $mw->Label ('-text' => $mesg)->grid (
+      '-row'    => 0,
+      '-column' => 0,
+      '-padx'   => 5,
+      '-pady'   => 5,
+    );
+
+    # Entry box for the user to type in the input string
+    my $entry   = $ans;
+    my $input_e = $mw->Entry (
+      '-textvariable'    => \$entry,
+      '-width'           => 40,
+    )->grid (
+      '-row'    => 0,
+      '-column' => 1,
+      '-sticky' => 'ew',
+      '-padx'   => 5,
+      '-pady'   => 5,
+    );
+
+    my $b_f = $mw->Frame->grid (
+      '-row'        => 1,
+      '-column'     => 0,
+      '-columnspan' => 2,
+      '-sticky'     => 'e',
+    );
+
+    # An OK button to accept the input string
+    my $ok_b = $b_f->Button (
+      '-text' => 'OK',
+      '-command' => sub {$ans = $entry; $mw->destroy},
+    )->grid (
+      '-row'        => 0,
+      '-column'     => 0,
+      '-padx'       => 5,
+      '-pady'       => 5,
+    );
+
+    # A Cancel button to reject the input string
+    my $cancel_b = $b_f->Button (
+      '-text' => 'Cancel',
+      '-command' => sub {$ans = undef; $mw->destroy},
+    )->grid (
+      '-row'        => 0,
+      '-column'     => 1,
+      '-padx'       => 5,
+      '-pady'       => 5,
+    );
+
+    # Keyboard binding
+    $mw->bind ('<Key>' => sub {
+      if ($Tk::event->K eq 'Return' or $Tk::event->K eq 'KP_Enter') {
+        $ok_b->invoke;
+
+      } elsif ($Tk::event->K eq 'Escape') {
+        $cancel_b->invoke;
+      }
+    });
+
+    # Allow the entry box to expand
+    $mw->gridColumnconfigure (1, '-weight' => 1);
+
+    # Set initial focus on the entry box
+    $input_e->focus;
+    $input_e->icursor ('end');
+  }
+
+  $mw->geometry ($pos);
+
+  # Switch on "always on top" property for $mw
+  $mw->property (
+    qw/set _NET_WM_STATE ATOM/,
+    32,
+    ['_NET_WM_STATE_STAYS_ON_TOP'],
+    ($mw->toplevel->wrapper)[0],
+  );
+
+  MainLoop;
+
+  return $ans;
+}
+
+# ------------------------------------------------------------------------------
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_internal
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_internal	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_internal	(revision 7236)
@@ -0,0 +1,581 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   fcm_internal
+#
+# SYNOPSIS
+#   fcm_internal SUBCOMMAND ARGS
+#
+# DESCRIPTION
+#   The fcm_internal command is a frontend for some of the internal commands of
+#   the FCM build system. The subcommand can be "compile", "load" or "archive"
+#   for invoking the compiler, loader and library archiver respectively. If
+#   "compile" is specified, it can be suffixed with ":TYPE" to specify the
+#   nature of the source file. If TYPE is not specified, it is set to F by
+#   default (for Fortran source). For compile and load, the other arguments are
+#   the 1) name of the container package of the source file, 2) the path to the
+#   source file and 3) the target name after compiling or loading the source
+#   file. For compile, the 4th argument is a flag to indicate whether
+#   pre-processing is required for compiling the source file. For load, the 4th
+#   and the rest of the arguments is a list of object files that cannot be
+#   archived into the temporary load library and must be linked into the target
+#   through the linker command. (E.g. Fortran BLOCKDATA program units must be
+#   linked this way.) If archive is specified, the first argument should be the
+#   name of the library archive target and the rest should be the object files
+#   to be included in the archive. This command is invoked via the build system
+#   and should never be called directly by the user.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+# Standard pragmas:
+use warnings;
+use strict;
+
+# FCM component modules
+use Fcm::Timer;
+
+# Function declarations
+sub catfile;
+sub basename;
+sub dirname;
+
+# ------------------------------------------------------------------------------
+
+# Module level variables
+my %unusual_tool_name = ();
+
+# ------------------------------------------------------------------------------
+
+MAIN: {
+  # Name of program
+  my $this = basename $0;
+
+  # Arguments
+  my $subcommand = shift @ARGV;
+  my ($function, $type) = split /:/, $subcommand; 
+  my ($srcpackage, $src, $target, $requirepp, @objects, @blockdata);
+  
+  if ($subcommand eq 'archive') {
+    ($target, @objects) = @ARGV;
+
+  } elsif ($subcommand eq 'load') {
+    ($srcpackage, $src, $target, @blockdata) = @ARGV;
+
+  } else {
+    ($srcpackage, $src, $target, $requirepp) = @ARGV;
+  }
+
+  # Set up hash reference for all the required information
+  my %info = (
+    SRCPACKAGE => $srcpackage,
+    SRC        => $src,
+    TYPE       => $type,
+    TARGET     => $target,
+    REQUIREPP  => $requirepp,
+    OBJECTS    => \@objects,
+    BLOCKDATA  => \@blockdata,
+  );
+
+  # Get list of unusual tools
+  my $i = 0;
+  while (my $label = &get_env ('FCM_UNUSUAL_TOOL_LABEL' . $i)) {
+    my $value = &get_env ('FCM_UNUSUAL_TOOL_VALUE' . $i);
+    $unusual_tool_name{$label} = $value;
+    $i++;
+  }
+
+  # Invoke the action
+  my $rc = 0;
+  if ($function eq 'compile') {
+    $rc = &compile (\%info);
+
+  } elsif ($function eq 'load') {
+    $rc = &load (\%info);
+
+  } elsif ($function eq 'archive') {
+    $rc = &archive (\%info);
+
+  } else {
+    print STDERR $this, ': incorrect usage, abort';
+    $rc = 1;
+  }
+
+  # Throw error if action failed
+  if ($rc) {
+    print STDERR $this, ' ', $function, ' failed (', $rc, ')', "\n";
+    exit 1;
+
+  } else {
+    exit;
+  }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rc = &compile (\%info);
+#
+# DESCRIPTION
+#   This method invokes the correct compiler with the correct options to
+#   compile the source file into the required target. The argument $info is a
+#   hash reference set up in MAIN. The following environment variables are
+#   used, where * is the source file type (F for Fortran, and C for C/C++):
+# 
+#   *C          - compiler command
+#   *C_OUTPUT   - *C option to specify the name of the output file
+#   *C_DEFINE   - *C option to declare a pre-processor def
+#   *C_INCLUDE  - *C option to declare an include directory
+#   *C_COMPILE  - *C option to ask the compiler to perform compile only
+#   *CFLAGS     - *C user options
+#   *PPKEYS     - list of pre-processor defs (may have sub-package suffix)
+#   FCM_VERBOSE - verbose level
+#   FCM_OBJDIR  - destination directory of object file
+#   FCM_TMPDIR  - temporary destination directory of object file
+# ------------------------------------------------------------------------------
+
+sub compile {
+  my $info = shift;
+
+  # Verbose mode
+  my $verbose = &get_env ('FCM_VERBOSE');
+  $verbose    = 1 unless defined ($verbose);
+
+  my @command = ();
+
+  # Only support C and Fortran source files at the moment
+  my $type = $info->{TYPE};
+  $type    = ($info->{SRC} =~ /\.c(\w+)?$/i) ? 'C' : 'F' if not $type;
+
+  # Compiler
+  push @command, &get_env ($type . 'C', 1);
+
+  # Compile output target (typical -o option)
+  push @command, &get_env ($type . 'C_OUTPUT', 1), $info->{TARGET};
+
+  # Pre-processor definition macros
+  if ($info->{REQUIREPP}) {
+    my @ppkeys = split /\s+/, &select_flags ($info, $type . 'PPKEYS');
+    my $defopt = &get_env ($type . 'C_DEFINE', 1);
+
+    push @command, (map {$defopt . $_} @ppkeys);
+  }
+
+  # Include search path
+  my $incopt  = &get_env ($type . 'C_INCLUDE', 1);
+  my @incpath = split /:/, &get_env ('FCM_INCPATH');
+  push @command, (map {$incopt . $_} @incpath);
+
+  # Other compiler flags
+  my $flags = &select_flags ($info, $type . 'FLAGS');
+  push @command, $flags if $flags;
+
+  my $compile_only = &get_env ($type . 'C_COMPILE');
+  if ($flags !~ /(?:^|\s)$compile_only\b/) {
+    push @command, &get_env ($type . 'C_COMPILE');
+  }
+
+  # Name of source file
+  push @command, $info->{SRC};
+
+  # Execute command
+  my $objdir = &get_env ('FCM_OBJDIR', 1);
+  my $tmpdir = &get_env ('FCM_TMPDIR', 1);
+  chdir $tmpdir;
+
+  my $command = join ' ', @command;
+  if ($verbose > 1) {
+    print 'cd ', $tmpdir, "\n";
+    print &timestamp_command ($command, 'Start');
+
+  } elsif ($verbose) {
+    print $command, "\n";
+  }
+
+  my $rc = system $command;
+
+  print &timestamp_command ($command, 'End  ') if $verbose > 1;
+
+  # Move temporary output to correct location on success
+  # Otherwise, remove temporary output
+  if ($rc) { # error
+    unlink $info->{TARGET};
+
+  } else {   # success
+    print 'mv ', $info->{TARGET}, ' ', $objdir, "\n" if $verbose > 1;
+    rename $info->{TARGET}, &catfile ($objdir, $info->{TARGET});
+  }
+
+  # Move any Fortran module definition files to the INC directory
+  my @modfiles = <*.mod *.MOD>;
+  for my $file (@modfiles) {
+    rename $file, &catfile ($incpath[0], $file);
+  }
+
+  return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rc = &load (\%info);
+#
+# DESCRIPTION
+#   This method invokes the correct loader with the correct options to link
+#   the main program object into an executable. The argument $info is a hash
+#   reference set up in MAIN. The following environment variables are used:
+# 
+#   LD           - linker command
+#   LD_OUTPUT    - LD option to specify the name of the output file
+#   LD_LIBSEARCH - LD option to declare a directory in the library search path
+#   LD_LIBLINK   - LD option to declare an object library
+#   LDFLAGS      - LD user options
+#   FCM_VERBOSE  - verbose level
+#   FCM_LIBDIR   - destination directory of object libraries
+#   FCM_OBJDIR   - destination directory of object files
+#   FCM_BINDIR   - destination directory of executable file
+#   FCM_TMPDIR   - temporary destination directory of executable file
+# ------------------------------------------------------------------------------
+
+sub load {
+  my $info = shift;
+
+  my $rc = 0;
+
+  # Verbose mode
+  my $verbose = &get_env ('FCM_VERBOSE');
+  $verbose    = 1 unless defined ($verbose);
+
+  # Create temporary object library
+  (my $name   = $info->{TARGET}) =~ s/\.\S+$//;
+  my $libname = '__fcm__' . $name;
+  my $lib     = 'lib' . $libname . '.a';
+  my $libfile = catfile (&get_env ('FCM_LIBDIR', 1), $lib);
+  $rc = &archive ({TARGET => $lib});
+
+  unless ($rc) {
+    my @command = ();
+
+    # Linker
+    push @command, &select_flags ($info, 'LD');
+
+    # Linker output target (typical -o option)
+    push @command, &get_env ('LD_OUTPUT', 1), $info->{TARGET};
+
+    # Name of main object file
+    my $mainobj = (basename ($info->{SRC}) eq $info->{SRC})
+                  ? catfile (&get_env ('FCM_OBJDIR'), $info->{SRC})
+                  : $info->{SRC};
+    push @command, $mainobj;
+
+    # Link with Fortran BLOCKDATA objects if necessary
+    if (@{ $info->{BLOCKDATA} }) {
+      my @blockdata = @{ $info->{BLOCKDATA} };
+      my @objpath   = split /:/, &get_env ('FCM_OBJPATH');
+
+      # Search each BLOCKDATA object file from the object search path
+      for my $file (@blockdata) {
+        for my $dir (@objpath) {
+          my $full = catfile ($dir, $file);
+
+          if (-r $full) {
+            $file = $full;
+            last;
+          }
+        }
+
+        push @command, $file;
+      }
+    }
+
+    # Library search path
+    my $libopt  = &get_env ('LD_LIBSEARCH', 1);
+    my @libpath = split /:/, &get_env ('FCM_LIBPATH');
+    push @command, (map {$libopt . $_} @libpath);
+
+    # Link with temporary object library if it exists
+    push @command, &get_env ('LD_LIBLINK', 1) . $libname if -f $libfile;
+
+    # Other linker flags
+    my $flags = &select_flags ($info, 'LDFLAGS');
+    push @command, $flags;
+
+    # Execute command
+    my $tmpdir = &get_env ('FCM_TMPDIR', 1);
+    my $bindir = &get_env ('FCM_BINDIR', 1);
+    chdir $tmpdir;
+
+    my $command = join ' ', @command;
+    if ($verbose > 1) {
+      print 'cd ', $tmpdir, "\n";
+      print &timestamp_command ($command, 'Start');
+
+    } elsif ($verbose) {
+      print $command, "\n";
+    }
+
+    $rc = system $command;
+
+    print &timestamp_command ($command, 'End  ') if $verbose > 1;
+
+    # Move temporary output to correct location on success
+    # Otherwise, remove temporary output
+    if ($rc) { # error
+      unlink $info->{TARGET};
+
+    } else {   # success
+      print 'mv ', $info->{TARGET}, ' ', $bindir, "\n" if $verbose > 1;
+      rename $info->{TARGET}, &catfile ($bindir, $info->{TARGET});
+    }
+  }
+
+  # Remove the temporary object library
+  unlink $libfile if -f $libfile;
+
+  return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rc = &archive (\%info);
+#
+# DESCRIPTION
+#   This method invokes the library archiver to create an object library. The
+#   argument $info is a hash reference set up in MAIN. The following
+#   environment variables are used:
+# 
+#   AR           - archiver command
+#   ARFLAGS      - AR options to update/create an object library
+#   FCM_VERBOSE  - verbose level
+#   FCM_LIBDIR   - destination directory of object libraries
+#   FCM_OBJPATH  - search path of object files
+#   FCM_OBJDIR   - destination directory of object files
+#   FCM_TMPDIR   - temporary destination directory of executable file
+# ------------------------------------------------------------------------------
+
+sub archive {
+  my $info = shift;
+
+  my $rc = 0;
+
+  # Verbose mode
+  my $verbose = &get_env ('FCM_VERBOSE');
+  $verbose    = 1 unless defined ($verbose);
+
+  # Set up the archive command
+  my $lib     = &basename ($info->{TARGET});
+  my $tmplib  = &catfile (&get_env ('FCM_TMPDIR', 1), $lib);
+  my @ar_cmd  = ();
+  push @ar_cmd, (&get_env ('AR', 1), &get_env ('ARFLAGS', 1));
+  push @ar_cmd, $tmplib;
+
+  # Get object directories and their files
+  my %objdir;
+  if (exists $info->{OBJECTS}) {
+    # List of objects set in the argument, sort into directory/file list
+    for my $name (@{ $info->{OBJECTS} }) {
+      my $dir = (&dirname ($name) eq '.')
+                ? &get_env ('FCM_OBJDIR', 1) : &dirname ($name);
+      $objdir{$dir}{&basename ($name)} = 1;
+    }
+
+  } else {
+    # Objects not listed in argument, search object path for all files
+    my @objpath  = split /:/, &get_env ('FCM_OBJPATH', 1);
+    my %objbase  = ();
+
+    # Get registered objects into a hash (keys = objects, values = 1)
+    my %objects = map {($_, 1)} split (/\s+/, &get_env ('OBJECTS'));
+
+    # Seach object path for all files
+    for my $dir (@objpath) {
+      next unless -d $dir;
+
+      chdir $dir;
+
+      # Use all files from each directory in the object search path
+      for ((glob ('*'))) {
+        next unless exists $objects{$_}; # consider registered objects only
+        $objdir{$dir}{$_} = 1 unless exists $objbase{$_};
+        $objbase{$_} = 1;
+      }
+    }
+  }
+
+  for my $dir (keys %objdir) {
+    next unless -d $dir;
+
+    # Go to each object directory and executes the library archive command 
+    chdir $dir;
+    my $command = join ' ', (@ar_cmd, sort keys %{ $objdir{$dir} });
+
+    if ($verbose > 1) {
+      print 'cd ', $dir, "\n";
+      print &timestamp_command ($command, 'Start');
+
+    } else {
+      print $command, "\n" if exists $info->{OBJECTS};
+    }
+
+    $rc = system $command;
+
+    print &timestamp_command ($command, 'End  ')
+      if $verbose > 1;
+    last if $rc;
+  }
+
+  # Move temporary output to correct location on success
+  # Otherwise, remove temporary output
+  if ($rc) { # error
+    unlink $tmplib;
+
+  } else {   # success
+    my $libdir = &get_env ('FCM_LIBDIR', 1);
+
+    print 'mv ', $tmplib, ' ', $libdir, "\n" if $verbose > 1;
+    rename $tmplib, &catfile ($libdir, $lib);
+  }
+
+  return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flags = &select_flags (\%info, $set);
+#
+# DESCRIPTION
+#   This function selects the correct compiler/linker flags for the current
+#   sub-package from the environment variable prefix $set. The argument $info
+#   is a hash reference set up in MAIN.
+# ------------------------------------------------------------------------------
+
+sub select_flags {
+  my ($info, $set) = @_;
+
+  (my $srcroot = &basename ($info->{SRC})) =~ s/\.\S+$//;
+  my @names    = ($set);
+  push @names, split (/__/, $info->{SRCPACKAGE} . '__' . $srcroot);
+
+  my $string   = '';
+  while (@names) {
+    my $name = join '__', @names;
+    my $var  = &get_env ($name);
+
+    if (defined $var) {
+      $string = $var;
+      last;
+
+    } else {
+      pop @names;
+    }
+  }
+
+  return $string;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $variable = &get_env ($name);
+#   $variable = &get_env ($name, $compulsory);
+#
+# DESCRIPTION
+#   This internal method gets a variable from $ENV{$name}. If $compulsory is
+#   set to true, it throws an error if the variable is a not set or is an empty
+#   string. Otherwise, it returns C<undef> if the variable is not set.
+# ------------------------------------------------------------------------------
+
+sub get_env {
+  (my $name, my $compulsory) = @_;
+  my $string;
+
+  if ($name =~ /^\w+$/) {
+    # $name contains only word characters, variable is exported normally
+    die 'The environment variable "', $name, '" must be set, abort'
+      if $compulsory and not exists $ENV{$name};
+
+    $string = exists $ENV{$name} ? $ENV{$name} : undef;
+
+  } else {
+    # $name contains unusual characters
+    die 'The environment variable "', $name, '" must be set, abort'
+      if $compulsory and not exists $unusual_tool_name{$name};
+
+    $string = exists $unusual_tool_name{$name}
+              ? $unusual_tool_name{$name} : undef;
+  }
+
+  return $string;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $path = &catfile (@paths);
+#
+# DESCRIPTION
+#   This is a local implementation of what is in the File::Spec module.
+# ------------------------------------------------------------------------------
+
+sub catfile {
+  my @names = split (m!/!, join ('/', @_));
+  my $path  = shift @names;
+
+  for my $name (@names) {
+    $path .= '/' . $name if $name;
+  }
+
+  return $path;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $basename = &basename ($path);
+#
+# DESCRIPTION
+#   This is a local implementation of what is in the File::Basename module.
+# ------------------------------------------------------------------------------
+
+sub basename {
+  my $name = $_[0];
+
+  $name =~ s{/*$}{}; # remove trailing slashes
+
+  if ($name =~ m#.*/([^/]+)$#) {
+    return $1;
+
+  } else {
+    return $name;
+  }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $dirname = &dirname ($path);
+#
+# DESCRIPTION
+#   This is a local implementation of what is in the File::Basename module.
+# ------------------------------------------------------------------------------
+
+sub dirname {
+  my $name = $_[0];
+
+  if ($name =~ m#^/+$#) {
+    return '/'; # dirname of root is root
+
+  } else {
+    $name =~ s{/*$}{}; # remove trailing slashes
+
+    if ($name =~ m#^(.*)/[^/]+$#) {
+      my $dir = $1;
+      $dir =~ s{/*$}{}; # remove trailing slashes
+      return $dir;
+
+    } else {
+      return '.';
+    }
+  }
+}
+
+# ------------------------------------------------------------------------------
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_setup_konqueror
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_setup_konqueror	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_setup_konqueror	(revision 7236)
@@ -0,0 +1,44 @@
+#!/usr/bin/ksh
+# ------------------------------------------------------------------------------
+# NAME
+#   fcm_setup_konqueror
+#
+# SYNOPSIS
+#   fcm_setup_konqueror
+#
+# DESCRIPTION
+#   Set up Konqueror to use "fcm gui".
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+# Check number of arguments
+script=$(basename $0)
+usage="$script: no argument required"
+if (( $# != 0 )); then
+  echo "$usage, abort..." >&2
+  exit 1
+fi
+
+filename=fcm_gui.desktop
+
+file=$(dirname $0)
+file=${file%/bin}/etc/$filename
+
+if [[ ! -f $file ]]; then
+  echo "$script: $file not found, abort..." >&2
+  exit 1
+fi
+
+dir=$HOME/.kde/share/applnk/.hidden
+mkdir -p $dir
+cd $dir
+rm -f $filename             # Always remove.
+ln -s $file .
+
+echo "$script: finished"
+
+#EOF
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_update_version_dir.pl
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_update_version_dir.pl	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/bin/fcm_update_version_dir.pl	(revision 7236)
@@ -0,0 +1,302 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   fcm_update_version_dir.pl
+#
+# SYNOPSIS
+#   fcm_update_version_dir.pl [OPTIONS] [CFGFILE]
+#
+# DESCRIPTION
+#   See $usage for detail.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+# Standard pragmas
+use strict;
+use warnings;
+
+# Standard modules
+use Getopt::Long;
+use Cwd;
+use File::Basename;
+use File::Path;
+use File::Spec;
+
+# FCM component modules:
+use lib File::Spec->catfile (dirname (dirname ($0)), 'lib');
+use Fcm::Config;
+use Fcm::Util;
+
+# Usage
+# ------------------------------------------------------------------------------
+my $this  = basename $0;
+my $usage = <<EOF;
+NAME
+  $this
+
+SYNOPSIS
+  $this [OPTIONS] [CFGFILE]
+
+DESCRIPTION
+  Update the version directories for a list of relative paths in the source
+  repository URL.
+
+OPTIONS
+  -d [--dest] arg: Specify a destination for the extraction. If not specified,
+                   the command extracts to the current working directory.
+  -h [--help]    : Print help and exit.
+  -f [--full]    : Specify the full mode. If not specified, the command runs
+                   in incremental mode.
+  -u [--url]  arg: Specify the source repository URL. No default.
+
+ARGUMENTS
+  A configuration file may be given to this command, or it will attempt to
+  read from the standard input. Each line in the configuration must contain
+  a relative path that resides under the given source repository URL. (Empty
+  lines and lines beginning with a "#" are ignored.) Optionally, each
+  relative path may be followed by a list of space separated "conditions".
+  Each condition is a conditional operator (>, >=, <, <=, == or !=) followed
+  by a revision number or the keyword HEAD. The command uses the revision
+  log to determine the revisions at which the relative path has been updated
+  in the source repository URL. If these revisions also satisfy the
+  "conditions" set by the user, they will be considered in the extraction.
+  In full mode, everything is re-extracted. In incremental mode, the version
+  directories are only updated if they do not already exist.
+
+COPYRIGHT
+  This program is part of the FCM system.
+  (C) Crown copyright Met Office. All rights reserved.
+  For further details please refer to the file COPYRIGHT.txt
+  which you should have received as part of this distribution.
+EOF
+
+# Options
+# ------------------------------------------------------------------------------
+my ($dest, $full, $help, $url);
+GetOptions (
+  'dest|d=s' => \$dest,
+  'full|f'   => \$full,
+  'help'     => \$help,
+  'url|u=s'  => \$url,
+);
+
+if ($help) {
+  print $usage;
+  exit;
+}
+
+$dest = cwd () unless $dest;
+
+die 'An URL must be specified with the --url option, abort' unless $url;
+
+# Arguments
+# ------------------------------------------------------------------------------
+if (@ARGV) {
+  die 'Cannot read: ', $ARGV[0], ', abort' unless -f $ARGV[0] and -r $ARGV[0];
+}
+
+# Get configuration settings
+# ------------------------------------------------------------------------------
+my $config = Fcm::Config->new ();
+$config->get_config ();
+
+# Expand URL keyword
+$url = &expand_url_keyword (URL => $url);
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cfg = &main::cfg ();
+#
+# DESCRIPTION
+#   Return the $config variable.
+# ------------------------------------------------------------------------------
+
+sub cfg {
+  return $config;
+}
+
+# ------------------------------------------------------------------------------
+
+MAIN: {
+  my $date = localtime;
+  print $this, ': started on ', $date, "\n";
+
+  my %dirs;
+
+  # Read input (file) for a list directories and update conditions
+  while (<>) {
+    chomp;
+
+    # Ignore empty and comment lines
+    next if /^\s*(?:#|$)/;
+
+    # Each line must contain a relative path, and optionally a list of
+    # space delimited conditions
+    my @words = split /\s+/;
+    my $dir   = shift @words;
+
+    # Check that the conditions are valid
+    my @conditions;
+    for my $word (@words) {
+      if ($word =~ /^([<>]=?|[!=]=)(.+)$/i) {
+        # Condition must be a conditional operator followed by a revision
+        my ($operator, $rev) = ($1, $2);
+        $rev = &expand_rev_keyword (REV => $rev, URL => $url, HEAD => 1);
+        push @conditions, $operator . $rev;
+
+      } else {
+        print STDERR 'Warning: ignore unknown syntax for update condition: ',
+                     $word, "\n";
+      }
+    }
+
+    # Add directory and its conditions to a hash
+    if ($dir =~ s#/\*$##) { # Directory finishes with wildcard
+
+      # Run "svn ls" in recursive mode
+      my $dirurl  = join ('/', ($url, $dir));
+      my @files   = &run_command ([qw/svn ls -R/, $dirurl], METHOD => 'qx');
+
+      # Find directories containing regular files
+      while (my $file = shift @files) {
+	# Skip directories
+	next if $file =~ m#/$#;
+
+	# Get "dirname" of regular file and add to hash
+	my $subdir = join ('/', ($dir, dirname ($file)));
+	$dirs{$subdir} = \@conditions;
+      }
+
+    } else {
+      $dirs{$dir} = \@conditions;
+    }
+
+  }
+
+  # Update each directory, if required
+  for my $dir (sort keys %dirs) {
+    # Use "svn log" to determine the revisions that need to be updated
+    my %allversions;
+    {
+      my $command = 'svn log -q ' . join ('/', ($url, $dir));
+      my @log     = &run_command (
+        [qw/svn log -q/, join ('/', ($url, $dir))], METHOD => 'qx',
+      );
+      @log        = grep /^r\d+/, @log;
+
+      # Assign a sequential "version" number to each sub-directory
+      my $version = scalar @log;
+      for (@log) {
+        m/^r(\d+)/;
+        $allversions{$1} = 'v' . $version--;
+      }
+    }
+    my %versions = %allversions;
+
+    # Extract only revisions matching the conditions
+    if (@{ $dirs{$dir} }) {
+      my @conditions = @{ $dirs{$dir} };
+
+      for my $condition (@conditions) {
+        for my $rev (keys %versions) {
+          delete $versions{$rev} unless eval ($rev . $condition);
+        }
+      }
+    }
+
+    # Destination directory
+    my $dirpath = File::Spec->catfile ($dest, $dir);
+
+    if (-d $dirpath) {
+      if ($full or not keys %versions) {
+        # Remove destination directory top, in full mode
+        # or if there are no matching revisions
+        &run_command ([qw/rm -rf/, $dirpath], PRINT => 1);
+
+      } else {
+        # Delete excluded revisions if they exist, in incremental mode
+        if (opendir DIR, $dirpath) {
+          while (my $rev = readdir 'DIR') {
+            next unless $rev =~ /^\d+$/;
+
+            if (not grep {$_ eq $rev} keys %versions) {
+              my @command = (qw/rm -rf/, File::Spec->catfile ($dirpath, $rev));
+              &run_command (\@command, PRINT => 1);
+
+              # Remove "version" symlink
+              my $verlink = File::Spec->catfile ($dirpath, $allversions{$rev});
+              unlink $verlink if -l $verlink;
+            }
+          }
+          closedir DIR;
+        }
+      }
+    }
+
+    # Create container directory of destination if it does not already exist
+    if (keys %versions and not -d $dirpath) {
+      print '-> mkdir -p ', $dirpath, "\n";
+      my $rc = mkpath $dirpath;
+      die 'mkdir -p ', $dirpath, ' failed' unless $rc;
+    }
+
+    # Update each version directory that needs updating
+    for my $rev (keys %versions) {
+      my $revpath = File::Spec->catfile ($dest, $dir, $rev);
+
+      # Create version directory if it does not exist
+      if (not -e $revpath) {
+        # Use "svn export" to create the version directory
+        my @command = (
+          qw/svn export -q -r/,
+          $rev,
+          join ('/', ($url, $dir)),
+          $revpath,
+        );
+
+        &run_command (\@command, PRINT => 1);
+
+        # Run GenScr_GenRule on any component directories
+        # This can be removed once old versions of the SCSUI are no longer used
+	if ($dir =~ m#(?:^|/)components/#) {
+          my @command = (
+            "GenScr_GenRule",
+            File::Spec->catfile ($revpath, join ('.', (basename ($dir), "rule")))
+          );
+
+          &run_command (\@command, PRINT => 1);
+	}
+      }
+
+      # Create "version" symlink if necessary
+      my $verlink = File::Spec->catfile ($dest, $dir, $versions{$rev});
+      symlink $rev, $verlink unless -l $verlink;
+    }
+
+    # Symbolic link to the "latest" version directory
+    my $headlink = File::Spec->catfile ($dest, $dir, 'latest');
+    my $headrev  = 0;
+    for my $rev (keys %versions) {
+      $headrev = $rev if $rev > $headrev;
+    }
+
+    if (-l $headlink) {
+      # Remove old symbolic link if there is no revision to update or if it
+      # does not point to the correct version directory
+      my $org = readlink $headlink;
+      unlink $headlink if (! $headrev or $org ne $headrev);
+    }
+
+    # (Re-)create the "latest" symbolic link, if necessary
+    symlink $headrev, $headlink if ($headrev and not -l $headlink);
+  }
+
+  $date = localtime;
+  print $this, ': finished normally on ', $date, "\n";
+}
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/etc/fcm.cfg.eg
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/etc/fcm.cfg.eg	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/etc/fcm.cfg.eg	(revision 7236)
@@ -0,0 +1,266 @@
+# ------------------------------------------------------------------------------
+# FCM central configuration file
+# ------------------------------------------------------------------------------
+
+# ------------------------------------------------------------------------------
+# Standard repository locations
+# ------------------------------------------------------------------------------
+
+# AMV repository
+set::url::amv                svn://fcm7/AMV_svn/AMV
+
+set::trac::amv               http://fcm7/projects/AMV/browser/AMV
+
+# ANCIL repository
+set::url::ancil              svn://fcm8/ANCIL_svn/ANCIL
+
+set::trac::ancil             http://fcm8/projects/ANCIL/browser/ANCIL
+
+# ATSR repository
+set::url::atsr               svn://fcm7/ATSR_svn/ATSR
+
+set::trac::atsr              http://fcm7/projects/ATSR/browser/ATSR
+
+# CICE repository
+set::url::cice               svn://fcm3/CICE_svn/CICE
+
+set::trac::cice              http://fcm3/projects/CICE/browser/CICE
+
+# CVC repository
+set::url::cvc_admin          svn://fcm6/CVC_svn/Admin
+set::url::bullseye           svn://fcm6/CVC_svn/Bullseye
+set::url::cat                svn://fcm6/CVC_svn/CAT
+set::url::deicing            svn://fcm6/CVC_svn/Deicing
+set::url::ea                 svn://fcm6/CVC_svn/EA  
+set::url::ensemble           svn://fcm6/CVC_svn/Ensemble
+set::url::gales              svn://fcm6/CVC_svn/Gales
+set::url::ifv                svn://fcm6/CVC_svn/IFV
+set::url::mogreps            svn://fcm6/CVC_svn/MOGREPS
+set::url::openroad           svn://fcm6/CVC_svn/OpenRoad
+set::url::powertable         svn://fcm6/CVC_svn/PowerTable
+set::url::qnh                svn://fcm6/CVC_svn/QNH
+
+set::trac::cvc_admin         http://fcm6/projects/CVC/browser/Admin
+set::trac::bullseye          http://fcm6/projects/CVC/browser/Bullseye
+set::trac::cat               http://fcm6/projects/CVC/browser/CAT
+set::trac::deicing           http://fcm6/projects/CVC/browser/Deicing
+set::trac::ea                http://fcm6/projects/CVC/browser/EA
+set::trac::ensemble          http://fcm6/projects/CVC/browser/Ensemble
+set::trac::gales             http://fcm6/projects/CVC/browser/Gales
+set::trac::ifv               http://fcm6/projects/CVC/browser/IFV
+set::trac::mogreps           http://fcm6/projects/CVC/browser/MOGREPS
+set::trac::openroad          http://fcm6/projects/CVC/browser/OpenRoad
+set::trac::powertable        http://fcm6/projects/CVC/browser/PowerTable
+set::trac::qnh               http://fcm6/projects/CVC/browser/QNH
+
+# DA repository
+set::url::da                 svn://fcm5/DA_svn/DA
+
+set::trac::da                http://fcm5/projects/DA/browser/DA
+
+# ENS repository
+set::url::ens                svn://fcm9/ENS_svn/ENS
+
+set::trac::ens               http://fcm9/projects/ENS/browser/ENS
+
+# FCM repository
+set::url::fcm                svn://fcm1/FCM_svn/FCM
+set::url::fcm_admin          svn://fcm1/FCM_svn/Admin
+
+set::trac::fcm               http://fcm1/projects/FCM/browser/FCM
+set::trac::fcm_admin         http://fcm1/projects/FCM/browser/Admin
+
+# FLUME repository
+set::url::flume_metadata     svn://fcm2/FLUME_svn/metadata
+
+set::trac::flume_metadata    http://fcm2/projects/FLUME/browser/metadata
+
+# GEN repository
+set::url::gen                svn://fcm1/GEN_svn/GEN
+
+set::trac::gen               http://fcm1/projects/GEN/browser/GEN
+
+# LEM repository
+set::url::lem                svn://fcm2/LEM_svn/LEM
+
+set::trac::lem               http://fcm2/projects/LEM/browser/LEM
+
+# LINK repository
+set::url::link               svn://fcm1/LINK_svn/LINK
+
+set::trac::link              http://fcm1/projects/LINK/browser/LINK
+
+# NEMO repository
+set::url::nemosys            svn://fcm3/NEMO_svn/NEMOSYS
+
+set::trac::nemosys           http://fcm3/projects/NEMO/browser/NEMOSYS
+
+# NWPWEB repository
+set::url::www_nwp            svn://fcm1/NWPWEB_svn/www_nwp
+
+set::trac::www_nwp           http://fcm1/projects/NWPWEB_svn/browser/www_nwp
+
+# obsmon repository
+set::url::obsmon_dc          svn://fcm4/obsmon_svn/DC
+set::url::obsmon_rtm         svn://fcm4/obsmon_svn/RTM
+
+set::trac::obsmon_dc         http://fcm4/projects/obsmon/browser/DC
+set::trac::obsmon_rtm        http://fcm4/projects/obsmon/browser/RTM
+
+# OCN repository
+set::url::polcoms            svn://fcm3/OCN_svn/POLCOMS
+
+set::trac::polcoms           http://fcm3/projects/OCN/browser/POLCOMS
+
+# OPFC repository
+set::url::opfc               svn://fcm9/OPFC_svn/OPFC
+
+set::trac::opfc              http://fcm9/projects/OPFC/browser/OPFC
+
+# OPS repository
+set::url::ops                svn://fcm4/OPS_svn/OPS
+set::url::ops_admin          svn://fcm4/OPS_svn/Admin
+set::url::ops_data           svn://fcm4/OPS_svn/Data
+
+set::trac::ops               http://fcm4/projects/OPS/browser/OPS
+set::trac::ops_admin         http://fcm4/projects/OPS/browser/Admin
+set::trac::ops_data          http://fcm4/projects/OPS/browser/Data
+
+# OSTIA repository
+set::url::ostia              svn://fcm3/OSTIA_svn/OSTIA
+
+set::trac::ostia             http://fcm3/projects/OSTIA/browser/OSTIA
+
+# PF repository
+set::url::pf                 svn://fcm5/PF_svn/PF
+
+set::trac::pf                http://fcm5/projects/PF/browser/PF
+
+# PostProc repository
+set::url::pp                 svn://fcm9/PostProc_svn/PostProc
+set::url::ppancil            svn://fcm9/PostProc_svn/PostProcAncil
+
+set::trac::pp                http://fcm9/projects/PostProc/browser/PostProc
+set::trac::ppancil           http://fcm9/projects/PostProc/browser/PostProcAncil
+
+# PRISM repository
+set::url::oasis4             svn://fcm2/PRISM_svn/oasis4
+
+set::trac::oasis4            http://fcm2/projects/PRISM/browser/oasis4
+
+# radarnet repository
+set::url::radarnet4          svn://fcm9/radarnet_svn/radarnet4
+
+set::trac::radarnet4         http://fcm7/projects/radarnet/browser/radarnet4
+
+# ROPP repository
+set::url::ropp_doc           svn://fcm7/ROPP_svn/ropp_doc
+set::url::ropp_src           svn://fcm7/ROPP_svn/ropp_src
+set::url::ropp_test          svn://fcm7/ROPP_svn/ropp_test
+set::url::ropp_web           svn://fcm7/ROPP_svn/ropp_web
+
+set::trac::ropp_doc          http://fcm7/projects/ROPP/browser/ropp_doc
+set::trac::ropp_src          http://fcm7/projects/ROPP/browser/ropp_src
+set::trac::ropp_test         http://fcm7/projects/ROPP/browser/ropp_test
+set::trac::ropp_web          http://fcm7/projects/ROPP/browser/ropp_web
+
+# RTTOV repository
+set::url::rttov8             svn://fcm7/RTTOV_svn/RTTOV8
+set::url::rttov9             svn://fcm7/RTTOV_svn/RTTOV9
+
+set::trac::rttov8            http://fcm7/projects/RTTOV/browser/RTTOV8
+set::trac::rttov9            http://fcm7/projects/RTTOV/browser/RTTOV9
+
+# SAUtils repository
+set::url::autoscat_global      svn://fcm7/SAUtils_svn/AUTOSCAT_Global
+set::url::autoscat_nae         svn://fcm7/SAUtils_svn/AUTOSCAT_NAE
+set::url::gpsiwv_mon           svn://fcm7/SAUtils_svn/GPSIWV_Mon
+set::url::gpsro_mon            svn://fcm7/SAUtils_svn/GPSRO_Mon
+set::url::iasi_mon             svn://fcm7/SAUtils_svn/IASI_Mon
+set::url::metstrike            svn://fcm7/SAUtils_svn/METSTRIKE
+set::url::scatwind_mon         svn://fcm7/SAUtils_svn/Scatwind_Mon
+
+set::trac::autoscat_global     http://fcm7/projects/SAUtils/browser/AUTOSCAT_Global
+set::trac::autoscat_nae        http://fcm7/projects/SAUtils/browser/AUTOSCAT_NAE
+set::trac::gpsiwv_mon          http://fcm7/projects/SAUtils/browser/GPSIWV_Mon
+set::trac::gpsro_mon           http://fcm7/projects/SAUtils/browser/GPSRO_Mon
+set::trac::iasi_mon            http://fcm7/projects/SAUtils/browser/IASI_Mon
+set::trac::metstrike           http://fcm7/projects/SAUtils/browser/METSTRIKE
+set::trac::scatwind_mon        http://fcm7/projects/SAUtils/browser/Scatwind_Mon
+
+# SBV repository
+set::url::sbv                svn://fcm6/SBV_svn/SBV
+set::url::sbv_admin          svn://fcm6/SBV_svn/Admin
+
+set::trac::sbv               http://fcm6/projects/SBV/browser/SBV
+set::trac::sbv_admin         http://fcm6/projects/SBV/browser/Admin
+
+# SCS repository
+set::url::scs                svn://fcm1/SCS_svn/SCS
+set::url::tik                svn://fcm1/SCS_svn/TIK
+set::url::tt                 svn://fcm1/SCS_svn/TT
+
+set::trac::scs               http://fcm1/projects/SCS/browser/SCS
+set::trac::tik               http://fcm1/projects/SCS/browser/TIK
+set::trac::tt                http://fcm1/projects/SCS/browser/TT
+
+# SPS repository
+set::url::sps                svn://fcm7/SPS_svn/SPS
+set::url::sps_archive        svn://fcm7/SPS_svn/Archive
+
+set::trac::sps               http://fcm7/projects/SPS/browser/SPS
+set::trac::sps_archive       http://fcm7/projects/SPS/browser/Archive
+
+# SURF repository
+set::url::surf               svn://fcm8/SURF_svn/SURF
+
+set::trac::surf              http://fcm8/projects/SURF/browser/SURF
+
+# test repository
+set::url::test               svn://fcm1/test_svn/OPS
+
+set::trac::test              http://fcm1/projects/test/browser/OPS
+
+# tutorial repository
+set::url::tutorial           svn://fcm1/tutorial_svn/tutorial
+
+set::trac::tutorial          http://fcm1/projects/tutorial/browser/tutorial
+
+# TRUI repository
+set::url::trui               svn://fcm1/TRUI_svn/TRUI
+
+set::trac::trui              http://fcm1/projects/TRUI/browser/TRUI
+
+# UM repository
+set::url::um                 svn://fcm2/UM_svn/UM
+set::url::um_admin           svn://fcm2/UM_svn/Admin
+set::url::gcom               svn://fcm2/UM_svn/GCOM
+
+set::trac::um                http://fcm2/projects/UM/browser/UM
+set::trac::um_admin          http://fcm2/projects/UM/browser/Admin
+set::trac::gcom              http://fcm2/projects/UM/browser/GCOM
+
+# UM tutorial repository
+set::url::um_tutorial        svn://fcm2/UM_TUTORIAL_svn/UM
+
+set::trac::um_tutorial       http://fcm2/projects/UM_TUTORIAL/browser/UM
+
+# VAR repository
+set::url::var                svn://fcm5/VAR_svn/VAR
+set::url::var_admin          svn://fcm5/VAR_svn/Admin
+set::url::var_data           svn://fcm5/VAR_svn/Data
+
+set::trac::var               http://fcm5/projects/VAR/browser/VAR
+set::trac::var_admin         http://fcm5/projects/VAR/browser/Admin
+set::trac::var_data          http://fcm5/projects/VAR/browser/Data
+
+# VER repository
+set::url::ver                svn://fcm6/VER_svn/VER
+set::url::ver_admin          svn://fcm6/VER_svn/Admin
+set::url::ver_archive        svn://fcm6/VER_svn/Archive
+
+set::trac::ver               http://fcm6/projects/VER/browser/VER
+set::trac::ver_admin         http://fcm6/projects/VER/browser/Admin
+set::trac::ver_archive       http://fcm6/projects/VER/browser/Archive
+
+# EOF
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/etc/fcm_gui.desktop
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/etc/fcm_gui.desktop	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/etc/fcm_gui.desktop	(revision 7236)
@@ -0,0 +1,13 @@
+[Desktop Entry]
+Comment=
+Exec=fcm gui %f
+Hidden=false
+Icon=wizard
+MimeType=inode/directory
+Name=FCM GUI
+Path=
+Terminal=0
+TerminalOptions=
+Type=Application
+X-KDE-SubstituteUID=false
+X-KDE-Username=
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Ecmwf/Fortran90_stuff.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Ecmwf/Fortran90_stuff.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Ecmwf/Fortran90_stuff.pm	(revision 7236)
@@ -0,0 +1,2736 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Ecmwf::Fortran90_stuff
+#
+# DESCRIPTION
+#   This is a module for analysing Fortran 9X code. It is used by the FCM
+#   system to generate interface blocks for Fortran 9X free source files.
+#
+# ABOUT THIS MODULE:
+#   The original version of this module was developed by the European Centre
+#   for Medium-Range Weather Forecasts (ECMWF). This version has been modified
+#   by UK Met Office to become part of the FCM system.
+# ------------------------------------------------------------------------------
+
+package Ecmwf::Fortran90_stuff;
+
+# Standard pragmas
+use strict;
+use warnings;
+
+# Standard modules
+require Exporter;
+
+our @ISA      = qw(Exporter);
+our @EXPORT   = qw(study setup_parse pre_tidy remove_macro expcont 
+                   process_include_files tidy tidy_decl getvars 
+		   find_unused_vars remove_unused_vars doctor_viol
+		   fix_doctor_viol various cont_lines f90_indent
+		   writefile readfile create_interface_block
+		   add_interface_blocks change_var_names insert_hook
+		   remake_arg_decl remove_some_comments parse_prog_unit
+		   get_calls_inc);
+
+# ------------------------------------------------------------------------------
+
+# Module variables
+
+my $fname = '';
+
+# ------------------------------------------------------------------------------
+# SYNPOSIS
+#   $file = &Ecmwf::Fortran90_stuff::fname ();
+#   &Ecmwf::Fortran90_stuff::fname ($file);
+#
+# DESCRIPTION
+#   This function returns the value in the module variable $fname, which is the
+#   name of the input Fortran source file from FCM. If an argument exists, the
+#   value of $fname is set to the value of the argument.
+#
+# ------------------------------------------------------------------------------
+
+sub fname {
+  $fname = $_[0] if @_;
+  return $fname;
+}
+
+#==========================================================================
+sub study{
+# Study statements and put attributes into array $statements
+# Attributes assigned:
+# $href->{content}       - What statement it is
+# $href->{decl}       - true if declaration,
+#                       5 means statement function
+#                       4 means USE statement,
+#                       2 means type decleration
+#                       3 means FORMAT statement
+#                       1 means the rest
+# $href->{in_contain} - true while in internal procedure(s)
+# $href->{exec}       - true if executable statement
+#                     - 2 means first executable statement in program unit
+#                     - 3 means last executable statement in program unit
+#                     - 23 means first and last executable statement in program unit
+# $href->{prog_unit}  - program unit number (numbered from 0)
+# $href->{number}     - statement number (numbered from 0)
+ 
+# Further attributes will be assigned later (action attributes)
+
+  my($statements,$prog_info) = @_;
+
+  our ($name,$nest_par);
+  my ($unit_name,@args,$prog_unit,$href,@punit,$current_punit);
+  my ($content,$decl,$exec);
+  my($type_def)=0;
+  my($unit_count)=-1;
+  @punit=();
+  $current_punit='';
+  my $number=-1;
+  my $in_contain=0;
+  my $in_interface=0;
+  my $contain_host='';
+  my $current_unit_name='';
+  our($study_called);
+#  if(! $study_called) {
+#    $$prog_info{has_interface_block}=0;
+#  }
+# Initial "parsing" loop
+
+  foreach $href (@$statements) {
+    $href->{in_contain}=$in_contain;
+    $href->{contain_host}=$contain_host if($in_contain);
+    $number++;
+    $_=$href->{statement};
+    $content='unknown';
+    my $content2='';
+    $decl=0;
+    $exec=0;
+
+    if($type_def) {
+ #     $href->{content}='typedef';
+    }
+    
+# Comment
+CRACK:    {
+      if(/^\s*(?:!|$)/) {
+	$content='comment';
+	last CRACK;
+      }
+
+      $_ = uc unless /^#/;
+      s/^\s*//;
+      s/\!.*\n/\n/g; # Remove trailing comments in all lines
+#      print "AA $_";
+ 
+# Program name statement 
+      if($content eq 'unknown' and ! $in_interface) {
+	$prog_unit=&parse_prog_unit(\$unit_name,\@args);
+	if($prog_unit) {
+          $current_unit_name=$unit_name;
+	  $content=uc($prog_unit);
+	  push(@punit,$prog_unit);
+	  $current_punit=$prog_unit;
+	  $unit_count++;
+	  if(! $study_called) {
+	    $$prog_info{'unit_name'}[$unit_count]=uc($unit_name);
+	    $$prog_info{'unit_name'}[$unit_count]=uc($unit_name);
+#	  $$prog_info{'tokens'}[$unit_count]=[];
+	    if($prog_unit eq 'module') {
+	      $$prog_info{'is_module'}=1;
+	      $$prog_info{'module_name'}=$unit_name;
+	    }
+	  }
+	  last CRACK;
+	}
+      }
+      if($content eq 'unknown') {
+	$decl=0;
+	$exec=1;
+# Executable constructs
+	&study_exec(\$content,$prog_info,\$study_called);
+	if($content eq 'IF') {
+	  s/^IF\s*$nest_par\s*//;
+	  &study_exec(\$content2,$prog_info,\$study_called);
+	}
+      }
+      
+
+      if($content eq 'unknown') {
+# Specification statemnts
+	$exec=0;
+	$decl=1;
+	if(/^USE\b/) {
+	  $content='USE';
+	  $decl=4;
+	}
+	elsif(/^INTEGER\b/) {
+	  $content='INTEGER';
+	  $decl=2;
+	}
+	elsif(/^REAL\b/) {
+	  $content='REAL';
+	  $decl=2;
+	}
+	elsif(/^LOGICAL\b/) {
+	  $content='LOGICAL';
+	  $decl=2;
+	}
+	elsif(/^CHARACTER\b/) {
+	  $content='CHARACTER';
+	  $decl=2;
+	}
+	elsif(/^DOUBLE\s*PRECISION\b/) {
+	  $content='DOUBLE PRECISION';
+	  $decl=2;
+	}
+	elsif(/^COMPLEX\b/) {
+	  $content='COMPLEX';
+	  $decl=2;
+	}
+	elsif(/^TYPE *\(/) {
+	  $content='type_decl';
+	  $decl=2;
+	}
+	elsif(/^ALLOCATABLE\b/) {
+	  $content='ALLOCATABLE';
+	}
+	elsif(/^COMMON\b/) {
+	  $content='COMMON';
+	}
+	elsif(/^DATA\b/) {
+	  $content='DATA';
+	}
+	elsif(/^DIMENSION\b/) {
+	  $content='DIMENSION';
+	}
+	elsif(/^EQUIVALENCE\b/) {
+	  $content='EQUIVALENCE';
+	}
+	elsif(/^EXTERNAL\b/) {
+	  $content='EXTERNAL';
+	}
+	elsif(/^\d+\s+FORMAT\b/) {
+	  $content='FORMAT';
+	  $decl=3;
+	}
+	elsif(/^IMPLICIT\b\s+NONE\b/) {
+	  $content='IMPLICIT NONE';
+	}
+	elsif(/^IMPLICIT\b/) {
+	  $content='IMPLICIT';
+	}
+	elsif(/^INTENT\b/) {
+	  $content='INTENT';
+	}
+	elsif(/^INTRINSIC\b/) {
+	  $content='INTRINSIC';
+	}
+	elsif(/^NAMELIST\b/) {
+	  $content='NAMELIST';
+	}
+	elsif(/^OPTIONAL\b/) {
+	  $content='OPTIONAL';
+	}
+	elsif(/^PARAMETER\b/) {
+	  $content='PARAMETER';
+          $decl = 2;
+	}
+	elsif(/^POINTER\b/) {
+	  $content='POINTER';
+	}
+	elsif(/^PUBLIC\b/) {
+	  $content='PUBLIC';
+	}
+	elsif(/^PRIVATE\b/) {
+	  $content='PRIVATE';
+	}
+	elsif(/^SAVE\b/) {
+	  $content='SAVE';
+	}
+	elsif(/^TARGET\b/) {
+	  $content='TARGET';
+	}
+	elsif(/^SEQUENCE\b/) {
+	  $content='SEQUENCE';
+	}
+	elsif(/^INTERFACE\b/) {
+	  $content='INTERFACE';
+	  if(! $study_called) {
+	    $$prog_info{has_interface_block}=1;
+	    $in_interface=1;
+	  }
+	}
+	elsif(/^END ?INTERFACE\b/) {
+	  $content='END INTERFACE';
+	    $in_interface=0;
+	}
+	elsif(/^TYPE *[^\( ]/i) {
+	  $content='type_def';
+	  $type_def=1;
+	}
+	elsif(/^END\s*TYPE\b/){
+	  $content='type_def';
+	  $type_def=0;
+	}
+        elsif( $in_interface ) {
+          if(/^MODULE PROCEDURE\b/) {
+            $content='MODULE PROCEDURE';
+          }
+        }
+      }
+# Other constructs
+      if($content eq 'unknown') {
+	$decl=0;
+	$exec=0;
+	
+	if(/^CONTAINS\b/) {
+	  $content='CONTAINS';
+	  $in_contain=1;
+          $contain_host=uc($current_unit_name);
+	  if(! $study_called) {
+	    $$prog_info{has_contain}=1;
+	    $$prog_info{containing}=1;
+	  }
+	}
+	elsif(/^(?:INCLUDE|#include)\b/) {
+	  $content='include';
+	  if(! $study_called) {
+	    $$prog_info{has_include}=1;
+	  }
+	}
+	elsif(/^\#/) {
+	  $content='cpp';
+	}
+	elsif(/^\@/) {
+	  $content='compiler_directive';
+	}
+	
+	else{
+	  if(/^END\b/ and ! $in_interface) {
+	    $prog_unit=pop(@punit);
+	    $content='END '.uc($prog_unit);
+	    if($in_contain) {
+	      unless(@punit) {
+		$unit_count=0;
+		$href->{in_contain}=0;
+		$in_contain=0;
+	      }
+	    }
+	  }
+	} 
+      }
+    }
+    
+    if($in_interface and $content ne 'INTERFACE') {
+      $content='in_interface';
+      $exec=0;
+      $decl=1;
+    }
+
+#    print "BB $unit_count $content $_";
+    if($content  eq 'unknown') {
+      print STDERR $fname, ': failed to crack statement starting at line ',
+                   $href->{first_line}, ', - syntax error?', "\n";
+      print STDERR ' ', $_, "\n";
+#      print STDERR "study_called $study_called in_interface $in_interface \n";
+#      print STDERR Dumper($statements);
+      #die "Failed in study";
+    }
+#    unless($content eq 'comment') {
+#      my @tmpvar=/\b$name\b/g;
+#      my $i=0;
+#      foreach my $tmp (@tmpvar){ 
+#	$href->{'tokens'}[$i]=$tmp;
+#	$i++;
+#	if(! $study_called and $unit_count > -1) {
+#	  $$prog_info{'token_hash'}[$unit_count]{$tmp}++;
+#	}
+#      }
+#    }
+               
+    $href->{content}=$content;
+    $href->{content2}=$content2 if($content2);
+    $href->{decl}=$decl;
+    $href->{exec}=$exec;
+#    $href->{type_decl}=$type_decl;
+    $href->{prog_unit}=$unit_count;
+    $href->{number}=$number;
+    unless($content eq 'comment') {
+      $href->{multi_line} = 1 if(tr/\n// > 1);
+    }
+  }
+
+
+# Find first executable statement in each program unit
+# Also repair statement functions wrongly assigned as executable
+  my $prev_unit_count=-2;
+  my $stat_func_suspicion=0;
+  my @lastexec=();
+
+  foreach $href (@$statements) {
+    $exec=$href->{exec};
+    $unit_count=$href->{prog_unit};
+    if($exec) {
+      if($unit_count > $prev_unit_count) {
+	$content=$href->{content};
+	if($content eq 'array_assign') {
+	  $stat_func_suspicion=1;
+	  $_=$href->{statement};
+	  if(/^\s*$name\s*\(\s*:/){
+	    $stat_func_suspicion=0;
+#	    print " A $_";
+	   } 
+	  elsif(/^\s*$name\s*\(\s*$name\s*:/){
+	    $stat_func_suspicion=0;
+#	    print " B $_";
+	  } 
+	  elsif(/^\s*$name\s*\(\s*\d+/){
+	    $stat_func_suspicion=0;
+#	    print " C $_";
+	  }
+	  else {
+	    $href->{exec}=0;
+	    $href->{decl}=5;
+	    $href->{content}='statmf';
+#	    print " D $_";
+	    next;
+	  }
+	}
+	$href->{exec}=2;
+	$prev_unit_count=$unit_count;
+	$content=$href->{content};
+      }
+      $lastexec[$unit_count]=$href->{number}  unless ($unit_count < 0);  
+# No prog_unit assigned, include file?
+    }
+  }
+
+# Assign last executable statement
+  if(@lastexec) {
+    foreach my $last (@lastexec) {
+      if(defined ($last)) {
+	if($$statements[$last]->{exec} == 1) {
+	  $$statements[$last]->{exec}=3;
+	}
+	else{
+	  $$statements[$last]->{exec}=23;
+	}      
+      }
+    }
+  }
+# Consistency checks
+  my $fail=0;
+  my $prev_exec=0;
+  $prev_unit_count=-1;
+  foreach $href (@$statements) {
+    $content=$href->{content};
+    next if($content eq 'comment');
+    $unit_count=$href->{prog_unit};
+    $exec=$href->{exec};
+    $decl=$href->{decl};
+    if($unit_count == $prev_unit_count) {
+      if($decl and $prev_exec) {
+	unless ($content eq 'FORMAT' | $content eq 'DATA' ) {
+          die $fname, ': declaration after executable statement', "\n",
+              $href->{first_line}, ' ', $href->{statement}, "\n";
+	}
+      }
+    }
+    $prev_unit_count=$unit_count;
+    $prev_exec=$exec;
+  }
+
+  $study_called=1;
+}
+
+#==========================================================================
+sub study_exec{
+  my($content,$prog_info,$study_called) = @_;
+  our ($name,$nest_par);
+  if(/^(\w+\s*:\s*)*IF\s*$nest_par\s*THEN/) {
+    $$content='IF_construct';
+  }
+  elsif(/^ELSE\s*IF\s*\(/) {
+    $$content='ELSEIF';
+  }
+  elsif(/^ELSE\b\s*($name)*/) {
+    $$content='ELSE';
+  }
+  elsif(/^END\s*IF\b\s*($name)*/) {
+    $$content='ENDIF';
+  }
+  elsif(/^(?:\d+\s+)?($name\s*:\s*)*DO(\s+WHILE)?\b/) {
+    $$content='DO';
+  }
+  elsif(/^(?:\d+\s+)?END\s*DO\b/) {
+    $$content='ENDDO';
+  }
+  elsif(/^(?:\d+\s+)?ALLOCATE\b/) {
+    $$content='ALLOCATE';
+  }
+  elsif(/^ASSIGN\b/) {
+    $$content='ASIGN';
+  }
+  elsif(/^(?:\d+\s+)?BACKSPACE\b/) {
+    $$content='BACKSPACE';
+  }
+  elsif(/^(?:\d+\s+)?CALL\b/) {
+    $$content='CALL';
+    if(!$$study_called) {
+      $$prog_info{no_calls}++;
+    }
+  }
+  elsif(/^(?:\d+\s+)?CLOSE\b/) {
+    $$content='CLOSE';
+  }
+  elsif(/^(?:\d+\s+)?CONTINUE\b/) {
+    $$content='CONTINUE';
+  }
+  elsif(/^(?:\d+\s+)?CYCLE\b/) {
+    $$content='CYCLE';
+  }
+  elsif(/^(?:\d+\s+)?DEALLOCATE\b/) {
+    $$content='DEALLOCATE';
+  }
+  elsif(/^ENDFILE\b/) {
+    $$content='ENDFILE';
+  }
+  elsif(/^(?:\d+\s+)?EXIT\b/) {
+    $$content='EXIT';
+  }
+  elsif(/^(?:\d+\s+)?GO\s*TO\b/) {
+    $$content='GOTO';
+  }
+  elsif(/^(?:\d+\s+)?IF\s*\(/) {
+    $$content='IF';
+  }
+  elsif(/^(?:\d+\s+)?INQUIRE\b/) {
+    $$content='INQUIRE';
+  }
+  elsif(/^(?:\d+\s+)?NULLIFY\b/) {
+    $$content='NULLIFY';
+  }
+  elsif(/^(?:\d+\s+)?OPEN\b/) {
+    $$content='OPEN';
+  }
+  elsif(/^(?:\d+\s+)?PAUSE\b/) {
+    $$content='PAUSE';
+  }
+  elsif(/^(?:\d+\s+)?PRINT\b/) {
+    $$content='PRINT';
+  }
+  elsif(/^(?:\d+\s+)?(?:READ|BUFFER\s*IN)\b/) {
+    $$content='READ';
+  }
+  elsif(/^(?:\d+\s+)?RETURN\b/) {
+    $$content='RETURN';
+  }
+  elsif(/^(?:\d+\s+)?REWIND\b/) {
+    $$content='REWIND';
+  }
+  elsif(/^(?:\d+\s+)?STOP\b/) {
+    $$content='STOP';
+  }
+  elsif(/^(?:\d+\s+)?(?:WRITE|BUFFER\s*OUT)\s*\(/) {
+    $$content='WRITE';
+  }
+  elsif(/^(?:\d+\s+)?($name\s*:\s*)*SELECT\s*CASE\b/) {
+    $$content='SELECT CASE';
+  }
+  elsif(/^(?:\d+\s+)?CASE\b/) {
+    $$content='CASE';
+  }
+  elsif(/^(?:\d+\s+)?END\s*SELECT\b/) {
+    $$content='END SELECT';
+  }
+  elsif(/^(?:\d+\s+)?WHERE\s*$nest_par\s*$name.*=/) {
+    $$content='WHERE';
+  }
+  elsif(/^(?:\d+\s+)?WHERE\s*\(/) {
+    $$content='WHERE_construct';
+  }
+  elsif(/^ELSE\s*WHERE\b/) {
+    $$content='ELSEWHERE';
+  }
+  elsif(/^END\s*WHERE\b/) {
+    $$content='ENDWHERE';
+  }
+  elsif(/^(?:\d+\s+)?FORALL\s*\(/) {
+    $$content='FORALL';
+  }
+  elsif(/^END\s*FORALL\b/) {
+    $$content='ENDFORALL';
+  }
+  elsif(/^(?:\d+\s+)?$name(?:\s*%\s*$name)*\s*=/o) {
+    $$content='scal_assign';
+  }
+  elsif(/^(?:\d+\s+)?$name(?:\s*$nest_par)*(?:\s*%\s*$name(?:\s*$nest_par)?)*\s*=/o) {
+    $$content='array_assign';
+  }
+}
+#===================================================================================
+sub pre_tidy {
+
+# Initial tidying to make the rest work
+
+  my($lines)=@_;
+  foreach (@$lines) {
+
+# Substitute tab with four blanks
+    s/\t/    /g;
+    s/^ *INTEGER /INTEGER_M /i;
+    s/^ *REAL /REAL_B /i;
+  }
+}
+#==========================================================================
+sub remove_macro {
+
+# Remove INTEGER_M, _ONE_ etc. macros and replace by expanded statement
+
+  my($lines)=@_;
+
+  my($im)=1; # Until I start checking include files
+  my($ia)=0;
+  my($ib)=0;
+  my($rb)=1; # Until I start checking include files
+  my($is)=0;
+  my($rh)=0;
+  my($rm)=0;
+  my(@pars,$string);
+  for (@$lines) {
+    next if(/^ *$/ | /^ *!/);
+# The following two substitutions should be restored at end of processing
+    s/(\'[^!]*)!+(.*\')/$1\£$2/;   # Protect against mischief 
+    s/(["][^!]*)!+(.*["])/$1\£$2/;      # Protect against mischief
+    $im=$im+/JPIM\b/i unless($im);
+    $rb=$rb+/JPRB\b/i unless($rb);
+    $rm=$rm+/JPRM\b/i unless($rm);
+    $im=$im+s/\bINTEGER_M\b/INTEGER(KIND=JPIM)/o;
+    $ia=$ia+s/\bINTEGER_A\b/INTEGER(KIND=JPIA)/o;
+    $ib=$ib+s/\bINTEGER_B\b/INTEGER(KIND=JPIB)/o;
+    $is=$is+s/\bINTEGER_S\b/INTEGER(KIND=JPIS)/o;
+    $rb=$rb+s/\bREAL_B\b/REAL(KIND=JPRB)/o;
+    $rh=$rh+s/\bREAL_H\b/REAL(KIND=JPRH)/o;
+    $rm=$rm+s/\bREAL_M\b/REAL(KIND=JPRM)/o;
+    $rb=$rb+s/\b_ZERO_\b/0.0_JPRB/og;
+    $rb=$rb+s/\b_ONE_\b/1.0_JPRB/og;
+    $rb=$rb+s/\b_TWO_\b/2.0_JPRB/og;
+    $rb=$rb+s/\b_HALF_\b/0.5_JPRB/og;
+  }
+  @pars=();
+  push(@pars,"JPIM") if $im;
+  push(@pars,"JPRB") if $rb;
+  push(@pars,"JPRM") if $rm;
+  push(@pars,"JPIA") if $ia;
+  push(@pars,"JPIB") if $ib;
+  push(@pars,"JPIS") if $is;
+  ($string=join('     ,',@pars))=~s/ *$//;
+  for (@$lines) {
+    next unless (/^\#/);
+    if(@pars) {
+      s/^#include +"tsmbkind.h"/USE PARKIND1  ,ONLY : $string/ ;
+    }
+    else {
+      s/^#include +"tsmbkind.h"//;
+    }
+#    if($rh) {
+      s/^#include +"hugekind.h"/USE PARKIND2  ,ONLY : JPRH/ ;
+#    }
+#    else {
+#      s/^#include +"hugekind.h"// ;
+#    }
+  }
+}
+
+#==========================================================================
+sub readfile  {
+# Read file 
+  my($fname)=@_;
+  my(@lines);
+  if(!open(INFIL,$fname)) {
+    print STDERR "Can't open $fname for reading\n";
+    die("Can't open $fname for reading\n");
+  }
+  @lines=<INFIL>;
+  close INFIL;
+  (@lines);
+}
+
+#==========================================================================
+sub writefile  {
+# Write file
+  my($fname,$lines)=@_;
+  if(!open(OUTFIL,">".$fname)) {
+    print STDERR "Can't open $fname for writing\n";
+    exit;
+  }
+  print OUTFIL @$lines;
+  close OUTFIL;
+}
+
+#==========================================================================
+sub expcont {
+#
+# Expand continuation lines into statements for free-format Fortran while
+# maintaining line-breaking and all comments
+# Put statements onto array of references to anonymous hashes as key 'statement'
+# Also put into the hash the linenumber of first line of statement as key 'first_line'
+  my ($lines, $statements) = @_;
+  my ($statm, $first_line);
+
+  my $prev        = 0;
+  my $line_number = 0;
+
+  for (@$lines) {
+    $line_number++;
+
+    s/^([^'"]*)(?:\s*!.*)$/$1/; # Remove trailing comments
+
+    s/^(\s*)&(.*)$/$1$2/s;
+
+    if (!/^\s*!.*$/ && /^.+?&(?:\s*!.*)*\s*$/) {
+      s/(.+?)&(.+)/$1\n/s;
+
+      $statm     .= $_;
+      $first_line = $line_number unless $prev;
+      $prev       = 1;
+      next;
+
+    } elsif ($prev && /^\s*(?:!|$)/) { # ignore blank/comment lines
+      next;
+
+    } else {
+      s/!.*?$//;
+
+      $statm     .= $_;
+      push @$statements, {
+        'statement'  => $statm,
+        'first_line' => $prev ? $first_line : $line_number,
+      };
+
+      $statm = "";
+      $prev  = 0;
+    }
+  }
+}
+#==========================================================================
+
+sub cont_lines {
+#
+# Put back continuation character in correct place and execute delayed actions
+#
+  my($statements,$lines,$line_hash) = @_;
+  my(@temp,$i,$iup,$href);
+
+
+# Put back continuation characters and split statements into lines as they were
+  @$lines=();
+  @$line_hash=();
+  foreach $href (@$statements) {
+    $_=$href->{statement};
+    if (/\n.*\n/){                      # This is a multi-line statement
+      @temp=split /\n/;                 # Split statement into lines (removes EOL)
+      $iup=scalar(@temp);               # Number of lines in statement
+      for ($i=0;$i < $iup;$i++) {       # Loop through lines
+	$_=$temp[$i];
+	if($i == 0 ){                   # First line
+	  if(/^([^!]+)(!.*)$/) {        # Line has trailing comment
+	    s/^([^!]+)(!.*)$/$1&$2\n/;  # Put back & at end of line before comment
+	  }
+	  else {                        # No trailing comment
+	    s/^([^!]+)$/$1&\n/;         # Put back & and EOL at end of line
+	  }	    
+	}
+	elsif ($i == ($iup-1)) {        # Last line
+	  s/^( *)(.*)$/$1& $2 \n/;      # Put back & at beginning of line
+	}
+	else {                          # Other lines
+	  if (/^ *!/) {                 # Line is comment line
+	    $_=$_."\n";                 # Restore EOL for comments
+	  }
+	  else {
+	    if(/^( *)([^!]*)(!.*)$/) {  # Line has trailing comment
+	      s/^( *)([^!]*)(!.*)*$/$1& $2&$3\n/;  # & at beginning and end of line
+	    }
+	    else {                      # No trailing comment
+	      s/^( *)([^!]*)$/$1& $2&\n/; # & at beggining and end of line
+	    }	 
+	  }  
+	}
+	if($i == 0        && exists $href->{pre_insert}) {
+	  my @templines=split('\n',$href->{pre_insert});
+	  foreach my $tline (@templines) {
+	    my $rec={};
+	    $rec->{'content'}='unknown';
+	    $rec->{'line'}=$tline."\n";
+	    push(@$lines,$rec->{'line'});
+	    push(@$line_hash,$rec);
+	  }
+	}
+	unless(exists $href->{remove}) {
+	  my $rec={};
+	  $rec->{'line'}=$_;
+	  if($i == 0) {
+	    $rec->{'content'}=$href->{content};
+	  }
+	  else {
+	    $rec->{'content'}='cont_line';
+	  }
+	  push(@$lines,$rec->{'line'});
+	  push(@$line_hash,$rec);
+	}
+	if($i == ($iup-1) && exists $href->{post_insert}) {
+	  my @templines=split('\n',$href->{post_insert});
+	  foreach my $tline (@templines) {
+	    my $rec={};
+	    $rec->{'content'}='unknown';
+	    $rec->{'line'}=$tline."\n";
+	    push(@$lines,$rec->{'line'});
+	    push(@$line_hash,$rec);
+	  }
+	}
+      }
+    }
+    else {  # Not multiline statement
+      if(exists $href->{pre_insert}) {
+	my @templines=split('\n',$href->{pre_insert});
+	foreach my $tline (@templines) {
+	  my $rec={};
+	  $rec->{'content'}='unknown';
+	  $rec->{'line'}=$tline."\n";
+	  push(@$lines,$rec->{'line'});
+	  push(@$line_hash,$rec);
+	}
+      }
+      unless(exists $href->{remove}) {
+	my $rec={};
+	$rec->{'line'}=$_;
+	$rec->{'content'}=$href->{content};
+	push(@$lines,$rec->{'line'});
+	push(@$line_hash,$rec);
+#	print $rec;
+      }
+      if(exists $href->{post_insert}) {
+	my @templines=split('\n',$href->{post_insert});
+	foreach my $tline (@templines) {
+	  my $rec={};
+	  $rec->{'content'}='unknown';
+	  $rec->{'line'}=$tline."\n";
+	  push(@$lines,$rec->{'line'});
+	  push(@$line_hash,$rec);
+	}
+      }
+    }
+  }
+}
+#==========================================================================
+sub getvars {
+# Return list of locally declared variables with type and scope information
+# 
+  my($statements,$prog_info,$vars,$use_vars) = @_;
+  my ($test,$type,@vars1,$func,$prog_unit,$dum,$tmp_name,@pu_args);
+  my ($preserve,$rank,$href);
+  our($nest_par,$name);
+
+  %$vars=();
+  $func="";
+  $prog_unit=0;
+  %$use_vars=();
+  foreach $href (@$statements) {
+    next if($href->{content} eq 'comment');           # Skip comments
+    next if($href->{exec});                        # Don't look in executable statements
+    next if($$prog_info{is_module} and ! $href->{in_contain}); # Unless inside CONTAIN skip module 
+    $prog_unit=$href->{prog_unit};
+    if($href->{content} eq 'FUNCTION') {
+      $_=$href->{statement};
+      my $dum=&parse_prog_unit(\$func,\@pu_args);          # Get name of FUNCTION
+#      print "GETVARS FUNCTION $func \n";
+      $func=uc($func);
+    }
+    if($href->{decl} == 2 or $href->{content} eq 'EXTERNAL'){  # Real parse starts
+      $_=$href->{statement};
+      $_=uc($_);                                   # Upcase to avoid /.../i
+      s/^ *//;                                     # remove leading blanks
+      if($href->{decl} == 2) {
+	$type=lc(substr($href->{content},0,1));
+      }
+      else {
+	$type='e';
+      }
+      s/\!.*\n/\n/g;                               # Remove trailing comments in all lines
+      $preserve=$_;
+      s/(.+)::(.+)/$2/s;                           #REAL(KIND=JPRB) :: zsig(:) -> zsig(:),
+      s/^EXTERNAL (.+)$/$1/;
+      s/\s+//g;                                    # Remove all white-space
+      if($href->{content} eq 'CHARACTER') {
+	s/($name)\*\d+/$1/g;
+	s/($name)\*$nest_par/$1/g;
+	s/($name)$nest_par\*\w+/$1/g;
+      }
+      s#=\(/.+/\)##;      # ZVAL(1:2)=(/1.0,2.0/) -> ZVAL(1:2)
+#?      s/=[^,\n]+//g;
+      s/$nest_par//g;     # ISEC3(SIZE(NSEC3)),ISEC4(SIZE(NSEC4)) -> ISEC3,ISEC4
+      s/=\w+//g;          # ZVAL=1.0 -> ZVAL
+      s@/.*/@@;           # What?
+      @vars1=split(',',$_);
+      for(@vars1) {
+	next unless /^$name$/;          # A bit of security
+	if($preserve =~ /\b$_\b *\(/ | $preserve =~ /DIMENSION/) {
+	  $rank=1;        # Variable is array
+	}
+	else {
+	  $rank=0;        # Variable is scalar
+	}
+	if($_ eq $func) {
+	  $$vars{$_}{type_spec}="f";
+	} 
+	else {
+	  if($href->{content} eq 'FUNCTION') {
+	    $$vars{$_}{type_spec}='f';
+	  }
+	  else {
+	    $$vars{$_}{type_spec}=$type;
+	  }
+	}
+	$$vars{$_}{scope}=$prog_unit;
+	$$vars{$_}{rank}=$rank;
+	$$vars{$_}{usage}='local';
+      }
+    }
+# Perhaps the variable is really a statement function?
+    if($href->{decl} == 5) {
+      $_=$href->{statement};
+      s/\s+//g;                                    # Remove all white-space
+      /^($name)\((.+)\)=/i;
+      my $tvar=uc($1);
+      my @stmf_args=split(',',$2);
+      if (exists($$vars{$tvar})) {
+	$$vars{$tvar}{type_spec}='s';
+#	print "STATMF OK $tvar \n ";
+      }
+      for (@stmf_args) {
+	if (exists($$vars{$_})) {
+	  $$vars{$_}{type_spec}='s';
+#	  print "STATMF ARG OK $_ \n ";
+	}
+      }
+    }
+  }
+# Perhaps instead the variable is a declaration of an external function?
+  my @extract=();                  # Extract part of statements for efficiency
+  foreach $href (@$statements) {
+    if($href->{exec}) {                 # Function call must be in executable stat.
+      next if($href->{content} eq 'CALL'); # A call can't contain an undeclared function
+      push(@extract,$href->{statement});
+    }
+  }
+  
+  foreach my $var (keys (%$vars)) {
+    next if($$vars{$var}{rank} > 0);   # Can't be a function if rank > 0
+    next if($$vars{$var}{type_spec} eq 's' | $$vars{$var}{type_spec} eq 'f');
+    my $dec_unit=$$vars{$var}{scope};
+    my $regex1=qr/\b$var\b\s*\(/i;      # As var's rank=0 this could be function call
+    for(@extract) {
+      if(/${regex1}/) {
+	s/\!.*\n/\n/g;                       # Remove trailing comments in all lines
+	s/\s+//g;                            # Remove all white-space
+	if(/${regex1}/) {
+	  if($$vars{$var}{type_spec} eq 'c') {   # Avoid CLVAR(1:3) etc.
+	    next if(/${regex1}\s*(\d+|$name)*\s*:\s*(\d+|$name)*\s*\)/);
+	  }
+#	  print "TYPE changed to function $var $_ \n";
+	  $$vars{$var}{type_spec}='f';
+	  last;
+	}
+      }
+    }
+  }
+# ---------------------------------------------------------------------
+# Assign  "usage" in Doctor sense to variable (default usage is 'local')
+# 
+  foreach $href (@$statements) {
+# Is the varaible a dummy argument
+    if($href->{content} eq 'FUNCTION' or $href->{content} eq 'SUBROUTINE') {
+      $_=$href->{statement};
+      @pu_args=();
+      my $dum=&parse_prog_unit(\$func,\@pu_args);   # Get arguments
+      for(@pu_args) {
+	if( exists $$vars{$_} ) {
+	  if($$vars{$_}{scope} == $href->{prog_unit}) {
+	    $$vars{$_}{usage}='arg';
+	  }
+
+	} else {
+          print STDERR "Argument $_ has not got a corresponding declaration " .
+                       "statement\n";
+          print STDERR "Bailing out at this point\n";
+          die "Bailing out";
+	}
+      }
+    }
+# Does the variable appear in a NAMELIST
+# We want to distinguish this for more lenient Doctor check
+    if($href->{content} eq 'NAMELIST') {
+      $_=$href->{statement};
+      s/\!.*\n/\n/g;     # Remove trailing comments in all lines
+      s/\s+//g;          # Remove all white-space
+      m:NAMELIST/\w+/(.+):;
+      my @namvars=split(',',uc($1));
+      for (@namvars) {
+	if( exists $$vars{$_} ) {
+	  if($$vars{$_}{scope} == $href->{prog_unit}) {
+	    $$vars{$_}{usage}='namvar';
+	  }
+	}
+      }
+    }
+    if(exists $href->{inc_statm}) { # We also have to look in include files
+      my $incs=$href->{inc_statm};
+      foreach my $hrefi (@$incs) {
+	if($hrefi->{content} eq 'NAMELIST') {
+	  $_=$hrefi->{statement};
+	  s/\!.*\n/\n/g;     # Remove trailing comments in all lines
+	  s/\s+//g;          # Remove all white-space
+	m:NAMELIST/\w+/(.+):;
+	  my @namvars=split(',',uc($1));
+	  for (@namvars) {
+	    if( exists $$vars{$_} ) {
+	      if($$vars{$_}{scope} == $href->{prog_unit}) {
+		$$vars{$_}{usage}='namvar';
+	      }
+	    }
+	  }
+	}
+      }
+    }
+  }
+# -----------------------------------------------------------------------------
+# Find use variables
+  my %use_count=();
+  foreach $href (@$statements) {
+    if($href->{content} eq 'USE') {
+      $prog_unit=$href->{prog_unit};
+      $_=$href->{statement};
+      s/\!.*\n/\n/g;                               # Remove trailing comments in all lines
+      s/\s+//g;                                    # Remove all white-space
+      $_=uc($_);                                   # Upcase to avoid /.../i
+      if(/^USE($name),ONLY:(.+)$/){
+	my $modname=$1;
+	if( exists $use_count{$modname}) {
+	  if($prog_unit == $use_count{$modname}) {
+	    print STDERR "-> $href->{statement}";
+            print STDERR "USE $modname appears more than once in program unit $prog_unit \n\n";
+
+	  }
+	}
+	$use_count{$modname} = $prog_unit;
+	my @usevars = split /,/ ,$2;
+	my %usevars=();
+	foreach my $usevar (@usevars) {
+	  $usevars{$usevar}++;
+	  $$use_vars{$usevar}{module}=$modname;
+	  $$use_vars{$usevar}{scope}=$prog_unit;
+	  $$use_vars{$usevar}{count}++;
+	}
+	foreach my $usevar (keys (%usevars)) {
+	  if($usevars{$usevar} >1) {
+	    print STDERR "DUPLICATE USE ONLY VARIABLE ",
+	    "$modname $usevar $prog_unit \n";
+	    $_=$href->{statement};
+	    s/\b$usevar\b//i;
+	    s/,\s*,/,/;
+	    s/,\s*\n$/\n/;
+	    s/\n *\n/\n/;
+	    s/^(.+:\s*),/$1/;
+	    $href->{statement}=$_;
+	  }
+	}
+      }
+      else {
+#	print "WARNING:USE without ONLY \n";
+      }
+    }
+  }
+}
+#==========================================================================
+sub find_unused_vars {
+# Find declared variables not used
+  my($statements,$vars,$unused_vars,$use_vars,$unused_use_vars) = @_;
+  my ($var,@tokens,$href);
+  @tokens=();
+# Find all tokens in file
+  foreach $href (@$statements) {
+    next if($href->{content} eq 'comment');
+    if(exists $href->{inc_statm}) {  # Look also in include files
+      my $incs=$href->{inc_statm};
+      foreach my $hrefi (@$incs) {
+	die "FUV $href->{content} $href->{statement}" unless exists $hrefi->{statement};
+	$_=$hrefi->{statement};
+	if(/\b[a-zA-Z]\w*\b/) {
+	  push(@tokens,/\b[a-zA-Z]\w*\b/g);
+	}
+      }
+    }
+    else {
+      $_=$href->{statement};
+      push(@tokens,/\b[a-zA-Z]\w*\b/g);
+    }
+  }
+  @tokens= map {uc} @tokens; # Upcase array of tokens, the variables are upper-case
+
+# Find out how many times the variable appears in array tokens
+  foreach $var (keys (%$vars)) {
+    $$vars{$var}{uses}=0;
+  }
+  foreach $var (keys (%$use_vars)) {
+    $$use_vars{$var}{uses}=0;
+  }
+  for (@tokens) {
+    if(exists($$vars{$_})){
+      $$vars{$_}{uses}++; 
+    }
+    if(exists($$use_vars{$_})){
+      $$use_vars{$_}{uses}++; 
+    }
+  }
+# If it appears only one time (which must be in a declaration) it is unused
+  @$unused_vars=();
+  foreach $var (keys (%$vars)) {
+    push(@$unused_vars,$var) if($$vars{$var}{uses} < 2);
+  }
+  @$unused_use_vars=();
+  foreach $var (keys (%$use_vars)) {
+    push(@$unused_use_vars,$var) if($$use_vars{$var}{uses} < 2);
+  }
+}
+#==========================================================================
+sub remove_unused_vars {
+# Does what it says on the tin
+  my($statements,$unused_vars,$unused_use_vars) = @_;
+  my ($var,$href);
+  our $nest_par;
+  for (@$unused_vars) {
+    $var=$_;
+    foreach $href (@$statements) {
+      $_=$href->{statement};
+      next unless(($href->{decl}) | ($href->{content} eq 'comment'));
+      if($href->{content} eq 'comment') {
+	next unless(/^ *!\$OMP/);
+      }
+      if(/\b$var\b/i) {
+#	print $_;
+	
+	if(/\b$var\b *\(/i) {
+#	  print "ZYZ $var $_";
+	  s/\b$var\b *$nest_par *(=\s*\(\/.*\/\))*//si;
+#	  print "ZZZ $var $_";
+	}
+	s/\b$var\b\s*=\s*\d+(\.\d*)*//i;
+	s/\b$var\b *(\* *\d+)*//i if($href->{content} eq 'CHARACTER') ;
+	s/\b$var\b//i; 
+#	print $_;
+        s/^.+:: *\n$//;
+        s/^.+:: *\!.*\n$//;
+#	print $_;
+        s/,\s*,/,/;
+#	print $_;
+	s/, *\n$/\n/;
+#	print $_;
+        s/(::\s*),(.+)$/$1$2/s;
+        s/\n *\n/\n/;
+        s/\n *!.*\n/\n/;
+	s/, *\n$/\n/;
+# Remove "empty" lines
+        s/^.+::\s*$//;
+        s/^.+::\s*=.*$//;
+        s/^.+::\s*!.*$//;
+#	print $_;
+        s/^CHARACTER *\*\d+ *\n$//i if($href->{content} eq 'CHARACTER') ;
+	$href->{statement}=$_;
+      }
+    }
+  }
+  for (@$unused_use_vars) {
+    $var=$_;
+    foreach $href (@$statements) {
+      next unless($href->{decl} == 4);
+      $_=$href->{statement};
+      next if(/PARKIND/); #I am sure this could be done betterh
+
+      if(/\b$var\b/i) {
+	s/\b$var\b//i;
+        s/,\s*,/,/;
+        s/,\s*\n$/\n/;
+        s/\n *\n/\n/;
+	s/^(.+:\s*),/$1/;
+	s/^.+:\s*$//;
+	$href->{statement}=$_;
+      }
+    }
+  }
+}
+#==========================================================================
+sub tidy_decl {
+# Tidy up declarions
+  my($statements) = @_;
+  my($href,$content);
+
+  foreach $href (@$statements) {
+    next unless($href->{decl} == 2);
+    $_=$href->{statement};
+    $content=$href->{content};
+    
+    if($content eq 'CHARACTER') {
+      s/CHARACTER *\* *(\w+)/CHARACTER \(LEN = $1\)/i; 
+      s/CHARACTER *\* *\(\*\)/CHARACTER \(LEN = \*\)/i;
+      s/CHARACTER *\* *\( *(\w+) *\)/CHARACTER \(LEN = $1)/i;
+    }
+    if($content eq 'INTEGER') {
+      if(/^ *INTEGER[^\(]/i) {
+	s/INTEGER\b/INTEGER(KIND=JPIM)/;
+      }
+    }
+    unless (/::/) {
+      s/^( *LOGICAL )/$1:: /i;
+      s/^( *INTEGER\(KIND=JPI\w\) )/$1:: /;
+      s/^( *REAL\(KIND=JPR\w\) )/$1:: /;
+      if(/^ *CHARACTER/i) {
+	if( s/^( *CHARACTER *\( *LEN *= *\w+ *\))/$1 :: /i) {
+	  $href->{statement}=$_;
+	  next;
+	}
+	if(s/^( *CHARACTER *\( *LEN *= *\* *\))/$1 :: /i) {
+	  $href->{statement}=$_;
+	  next;
+	}
+	s/^( *CHARACTER )/$1:: /i;
+      }
+    }
+    $href->{statement}=$_;
+  }
+}
+#==========================================================================
+
+sub doctor_viol {
+# Find Doctor violations
+
+  my($vars,$fix_doc) = @_;
+  my ($var,$type,$zz,$prog_unit,$usage);
+  %$fix_doc=();
+
+  foreach $var (keys (%$vars)) {
+    $type=$$vars{$var}{type_spec};
+    $prog_unit=$$vars{$var}{scope};
+    $usage=$$vars{$var}{usage};
+#    print "DOC $var $type $prog_unit $usage \n";
+    if($zz=&doc_char($type,$usage,$var)) {
+#      print "DOCTOR VIOL - ",$var," $type $zz $prog_unit\n";
+      $$fix_doc{$var}=$zz.'_'.$var.','.$prog_unit
+    }
+  }  
+}
+#==========================================================================
+
+sub fix_doctor_viol {
+# Fix Doctor violations
+  my($statements,$fix_doc) = @_;
+  my($doc_viol,$repl,$prog_unit,$cur_prog_unit,@allowed,$href,$content);
+  my($tmp_name,@pu_args);
+
+  @allowed=('NRGRI'); # Hack
+
+  VIOL:foreach $doc_viol (keys (%$fix_doc)) {
+    # Let's allow some violations
+    for (@allowed){ 
+      next VIOL if($doc_viol eq $_);
+    }
+
+    ($repl,$prog_unit)=split(',',$$fix_doc{$doc_viol});
+
+    print "FIX $repl $prog_unit \n";
+    foreach $href (@$statements) {
+      $content=$href->{content};
+      $_=$href->{statement};
+      if($href->{content} eq 'comment') {
+	next unless(/^ *!\$OMP/);
+      }
+      $cur_prog_unit=$href->{prog_unit};
+      if($prog_unit == $cur_prog_unit) {  # Could be fine in other program units
+	if(/\b$doc_viol\b/i) {
+	  s/%$doc_viol\b/_X_$doc_viol/ig; # Protect type-components
+	  s/\b$doc_viol\b/$repl/ig;
+	  s/_X_$doc_viol\b/%$doc_viol/ig; # Restore type-components
+	}
+      }
+      $href->{statement}=$_;
+    }
+  }
+  
+}
+#==========================================================================
+sub various{
+# 
+  my($statements,$prog_info,$vars) = @_;
+  my($punit,@args,$tmp_name,$cont,$statm);
+  my($href,$exec);
+  our $nest_par;
+#------------------------------------------------------------------
+# Remove unneccesary RETURN statement
+  foreach $href (@$statements) {
+    $cont=$href->{content};
+    if($cont eq 'RETURN') {
+      if($href->{exec} == 3) {   # $href->{exec} == 3 means last executable statement
+	$href->{remove} = 1;     # Post remove line for later
+      }
+    }
+  }
+
+
+# Make sure all CALL MPL_... has a CDSTRING argument
+  foreach $href (@$statements) {
+    $cont=$href->{content};
+    if($href->{content} eq 'CALL' ) {
+      $_=$href->{statement};
+      if(/^\s*CALL\s+MPL_/i) {
+	next if(/^\s*CALL\s+MPL_ABORT/i);
+	next if(/^\s*CALL\s+MPL_WRITE/i);
+	next if(/^\s*CALL\s+MPL_READ/i);
+	next if(/^\s*CALL\s+MPL_OPEN/i);
+	next if(/^\s*CALL\s+MPL_CLOSE/i);
+	next if(/^\s*CALL\s+MPL_INIT/i);
+	next if(/^\s*CALL\s+MPL_GROUPS_CREATE/i);
+	next if(/^\s*CALL\s+MPL_BUFFER_METHOD/i);
+	next if(/^\s*CALL\s+MPL_IOINIT/i);
+	next if(/^\s*CALL\s+MPL_CART_COORD/i);
+#	print "CDSTRING=$$prog_info{'unit_name'}[$href->{prog_unit}]: \n";
+	unless(/CDSTRING\s*=/i) {
+	  s/\)(\s)$/,CDSTRING=\'$$prog_info{'unit_name'}[$href->{prog_unit}]:\'\)$1/;
+	  $href->{statement}=$_;
+	}
+      }
+    }
+  }
+	
+
+
+#------------------------------------------------------------------
+# Add Standard Modification Line
+
+  my $start=0;
+  foreach $href (@$statements) {
+    $cont=$href->{content};
+    if($cont eq 'comment') {
+      $_=$href->{statement};
+      if($start) {                        # Found header - look for end of mod lines
+	if(/^ *$/ || /^! *------------------------/) {
+	  $href->{pre_insert} = "!        M.Hamrud      01-Oct-2003 CY28 Cleaning\n";
+	  last;
+	}
+	next;
+      }
+      $start=1 if(/^! +Modifications/i) ;  # This how the header should look
+      next;
+    }
+    last if($href->{exec});                # We have failed - bail out
+  }
+
+# Change subroutine and call multi-line statements so that the comma
+# beetwen variables comes at the end of the line
+  my @lines=();
+  foreach $href (@$statements) {
+    if(exists $href->{multi_line}) {
+      $cont=$href->{content};
+      if($cont eq 'SUBROUTINE' | $cont eq 'CALL' ) {
+	$statm=$href->{statement};
+	@lines=split "\n", $statm;
+	@lines = reverse @lines;
+	my $append_comma=0;
+	for (@lines) {
+#	  print "A $append_comma $_ \n";
+	  next if(/^ *!/);
+	  if($append_comma) {
+	    if(/\S *!.*$/) {
+	      s/(\S)( *!.*)$/$1,$2/;
+	    }
+	    else {
+	      s/(\S) *$/$1,/;
+	    }
+	  }
+	  $append_comma=s/^ *,//;
+#	  print "B $append_comma $_ \n";
+	}
+	@lines = reverse @lines;
+	$statm=join  "\n",@lines;
+	$statm=$statm."\n";
+	$href->{statement}=$statm;
+      }
+    }
+  }
+  our $name;
+  foreach $href (@$statements) {
+    if($href->{content} eq 'USE') {
+      $_=$href->{statement};
+      unless(/^\s*USE\s+$name\s*,\s*ONLY\s*:/i){
+	print $_;
+	print "WARNING:USE without ONLY \n";
+      }
+    }
+  }    
+}
+#==========================================================================
+sub insert_hook{
+# 
+  my($statements,$prog_info,$vars) = @_;
+  my($punit,@args,$tmp_name,$cont,$statm);
+  my($href,$exec);
+  our $nest_par;
+#------------------------------------------------------------------
+# Add HOOK function
+  my $unit_name='';
+  my $last_use=0;
+  my $hook_status=0;
+  my $in_contain=0;
+  my $prev_prog=0;
+  my ($decl,$remember);
+  foreach $href (@$statements) {
+    $cont=$href->{content};
+    next if($cont eq 'comment');
+
+    $decl=$href->{decl};
+    $exec=$href->{exec};
+    $in_contain=$href->{in_contain};
+    if(! $in_contain and $href->{prog_unit} > $prev_prog) {
+      $hook_status=0;
+      $prev_prog=$href->{prog_unit};
+      print "resetting hook status \n";
+    }
+
+    if($cont eq 'FUNCTION' or $cont eq 'SUBROUTINE' or 
+       $cont eq 'PROGRAM'){ # Need name of routine
+      $_=$href->{statement};
+      &parse_prog_unit(\$unit_name,\@args);
+      $unit_name=uc($unit_name);
+# If in module pre-pend module name
+      $unit_name=$$prog_info{module_name}.':'.$unit_name if($$prog_info{is_module}); 
+      $remember=0;
+    }
+
+    if($hook_status == 0) {   # $hook_status == 0 means we have not done anything yet
+      if($cont eq 'USE') {    # Add USE YOMHOOK as second use statement
+	$href->{post_insert}="USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK\n";
+	$hook_status=1;
+      }
+      elsif($cont eq 'IMPLICIT NONE') { # No previous USE, add USE YOMHOOK before IMPLICIT NONE
+	$href->{pre_insert} ="USE PARKIND1  ,ONLY : JPRB\n".
+	  "USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK\n";
+	$hook_status=1;
+      } 
+    }
+    $remember=$href->{number} if($decl == 2); 
+
+#   Use statement added ($hook_status == 1), now insert HOOK switch on statement
+#   before first executable statement in program unit ($exec == 2)
+    if($hook_status == 1 && $exec == 2) {
+      if($remember) {
+	$$statements[$remember]->{post_insert}="REAL(KIND=JPRB) :: ZHOOK_HANDLE\n";
+	$href->{pre_insert}="IF (LHOOK) CALL DR_HOOK(\'${unit_name}\',0,ZHOOK_HANDLE)\n";
+      }
+      else {
+	$href->{pre_insert}="REAL(KIND=JPRB) :: ZHOOK_HANDLE\n".
+	    "IF (LHOOK) CALL DR_HOOK(\'${unit_name}\',0,ZHOOK_HANDLE)\n";
+      }   
+      if($cont eq 'IF') {
+	if($href->{content2} eq 'RETURN') {
+	  $_=$href->{statement};
+	  s/(\s*IF\s*$nest_par).*\n/$1/i;
+	  s/\)$/ .AND. LHOOK\)/;
+	  $href->{pre_insert}=$href->{pre_insert}."$_ CALL DR_HOOK(\'${unit_name}\',1,ZHOOK_HANDLE)\n";
+	}
+      }
+      $hook_status=2;
+    }
+#   Hook switched on($hook_status == 2), switch off after last executable statement
+#   ($exec == 3)
+    elsif($hook_status == 2) {
+      if($exec == 3 or $exec == 23) {
+	$href->{post_insert}="IF (LHOOK) CALL DR_HOOK(\'${unit_name}\',1,ZHOOK_HANDLE)\n";
+	$hook_status=3;
+      }
+      elsif($cont eq 'RETURN') {
+	$href->{pre_insert}="IF (LHOOK) CALL DR_HOOK(\'${unit_name}\',1,ZHOOK_HANDLE)\n";
+      }
+      elsif($cont eq 'IF') {
+	if($href->{content2} eq 'RETURN') {
+	  $_=$href->{statement};
+	  s/(\s*IF\s*$nest_par).*\n/$1/i;
+	  s/\)$/ .AND. LHOOK\)/;
+	  $href->{pre_insert}="$_ CALL DR_HOOK(\'${unit_name}\',1,ZHOOK_HANDLE)\n";
+	}
+      }	
+    }
+    $hook_status=1 if($in_contain && $hook_status==3); # Reset hook status in CONTAIN region
+  }
+  die "Adding HOOK function failed " if($hook_status == 2);
+}
+#==========================================================================
+
+sub doc_char{
+# Returns suggested prefix in case of DOCTOR violation (otherwise null string)
+  my($type,$usage,$var) = @_;
+  my $prefix="";
+# INTEGER variables
+  if( $type eq "i") {
+    if($usage eq "arg") {
+      $prefix="K" unless($var=~/^K/i);
+    }
+    elsif($usage eq "local") {
+      $prefix="I" unless($var=~/^[IJ]/i);
+    }
+    elsif($usage eq "module") {
+      $prefix="N" unless($var=~/^[MN]/i);
+    }
+    elsif($usage eq "namvar") {
+      $prefix="I" unless($var=~/^[MNIJ]/i);
+    }
+    else { 
+      die "Unknown usage";
+    }
+  }
+# REAL variables
+  elsif( $type eq "r") {
+    if($usage eq "arg") {
+      $prefix="P" unless($var=~/^P/i);
+    }
+    elsif($usage eq "local") {
+      $prefix="Z" unless($var=~/^Z|^PP/i);
+    }
+    elsif($usage eq "module") {
+      $prefix="R" if ($var=~/^[ZPIJKLMNCY]/i);
+    }
+    elsif($usage eq "namvar") {
+      $prefix="Z" if ($var=~/^[PIJKLMNCY]/i);
+    }
+    else { 
+      die "Unknown usage";
+    }
+  }
+#LOGICAL variables
+  elsif( $type eq "l") {
+    if($usage eq "arg") {
+      $prefix="LD" unless($var=~/^LD/i);
+    }
+    elsif($usage eq "local") {
+      $prefix="LL" unless($var=~/^LL/i);
+    }
+    elsif($usage eq "module") {
+      $prefix="L" unless($var=~/^L[^LD]/i);
+    }
+    elsif($usage eq "namvar") {
+      $prefix="LL" unless($var=~/^L/i);
+    }
+    else { 
+      die "Unknown usage";
+    }
+  }
+#CHARACTER variables
+  elsif( $type eq "c") {
+    if($usage eq "arg") {
+      $prefix="CD" unless($var=~/^CD/i);
+    }
+    elsif($usage eq "local") {
+      $prefix="CL" unless($var=~/^CL/i);
+    }
+    elsif($usage eq "module") {
+      $prefix="C" unless($var=~/^C[^LD]/i);
+    }
+    elsif($usage eq "namvar") {
+      $prefix="CL" unless($var=~/^C/i);
+    }
+    else { 
+      die "Unknown usage";
+    }
+  }
+# USER DEFINED TYPES
+  elsif( $type eq 't') {
+    if($usage eq "arg") {
+      $prefix="YD" unless($var=~/^YD/i);
+    }
+    elsif($usage eq "local") {
+      $prefix="YL" unless($var=~/^YL/i);
+    }
+    elsif($usage eq "module") {
+      $prefix="Y" unless($var=~/^Y[^LD]/i);
+    }
+    elsif($usage eq "namvar") {
+      $prefix="YL" unless($var=~/^Y/i);
+    }
+    else { 
+      die "Unknown usage";
+    }
+  }
+# FUNCTION/EXTERNAL declarations
+  elsif( $type eq 'f' || $type eq 'e' || $type eq 's') {
+# Everything is OK
+  }
+  else {
+    die "Unknown type $type"
+  }
+  ($prefix);
+}
+#==========================================================================
+     
+sub parse_prog_unit {
+  # Find out type (return), name ($$unit_name) and arguments (@$args)
+  # from a program unit statement ($_)
+  my ($unit_name, $args) = @_;
+  $$unit_name = '';
+  @$args      = ();
+
+  my $type = '';
+
+  our ($name, $type_spec, $attribute);
+
+  if (/^\s*(MODULE|PROGRAM|BLOCK\s*DATA)\s+($name)\s*$/io) {
+    $type       = lc ($1);
+    $$unit_name = $2;
+
+    # Remove space from "block data"
+    $type       =~ s/\s*//;
+
+  } elsif (/^\s*(?:$attribute)?\s*(SUBROUTINE)\s+($name)\b/io or
+           /^\s*(?:$attribute)?\s*(?:$type_spec)?\s*(FUNCTION)\s+($name)\b/io) {
+    $type       = lc ($1);
+    $$unit_name = $2;
+
+    # Get arguments/keywords from SUBROUTINE/FUNCTION
+    if(/^[^\(]+\([^\)]+\)/) {
+      my $tstatm = $_;
+
+      # Remove trailing comment
+      $tstatm =~ s/\!.*\n/\n/g;
+
+      # Remove space characters
+      $tstatm =~ s/\s//g;
+
+      # Add the RESULT clause to the argument/keyword list
+      $tstatm =~ s/\)result\((\w+\))$/,$1/i if $type eq 'function';
+
+      # Remove the parenthesis around the argument list
+      $tstatm =~ s/.+\((.+)\)/$1/;
+
+      @$args = split (',', uc ($tstatm));
+
+      # For FUNCTION, add its name to the list if necessary
+      push @$args, uc ($$unit_name)
+        if $type eq 'function' and not grep {$_ eq uc ($$unit_name)} @$args;
+    }
+  }
+
+  return $type;
+}
+
+#==========================================================================
+
+sub setup_parse {
+  # Set up some "global" variables that helps with parsing statements
+
+  # Pattern for nested parenthesis
+  our $nest_par;
+  $nest_par = qr/\((?:(?>[^()]+)|(??{$nest_par}))*\)/; #Camel p214
+
+  # Patterns for variable name and natural digit
+  our $name='[a-zA-Z]\w*';
+  our $digit_string='\d+';
+  our $type_name=$name;
+
+  # Patterns for specification
+  our $specification_expr='(?:'.$name.'|'.$digit_string.')'; # Simplification
+  our $type_param_value='(?:\*|'.$specification_expr.')';
+
+  # Patterns for length/kind attributes
+  our $char_selector='LEN *= *'.$type_param_value; # Simplification
+  our $kind_selector='\( *KIND *= *'.$name.' *\)';    # Simplification
+
+  # Pattern for type specification
+  our $type_spec='INTEGER *(?:'.$kind_selector.')?|REAL *(?:'.$kind_selector.
+    ')?|DOUBLE PRECISION|COMPLEX *(?:'.$kind_selector.')?|CHARACTER *'.
+    $char_selector.'|LOGICAL *(?:'.$kind_selector.')?|TYPE\s*\(\s*'.$type_name.
+    '\s*\)';
+
+  # Pattern for function/subroutine attribute
+  our $attribute = 'ELEMENTAL|(?:RECURSIVE(?:\s+PURE)?|PURE(?:\s+RECURSIVE)?)';
+
+  return;
+}
+
+#==========================================================================
+
+sub f90_indent {
+# Indent free-format F90 program to our standards
+  my($line_hash,$lines)=@_;
+  my($delta)='  '; 
+  my($cur_indent)='';
+  @$lines=();
+  foreach my $href (@$line_hash) {
+    $_=$href->{line};
+    if($href->{content} eq 'comment') {
+      push(@$lines,$_);
+      next;
+    }
+    s/^ *//; # Remove current indentation
+    my($post_chg)=0;
+    my($pre_chg)=0;
+    my($cont_line)='';
+    exit if (! exists $href->{content});
+    if($href->{content} eq 'DO') {
+      $post_chg=1 unless /^DO\s+\d/;
+    }
+    elsif($href->{content} eq 'ENDDO') {
+      $pre_chg=1;
+    }
+    elsif($href->{content} eq 'IF_construct') {
+      $post_chg=1;
+    }
+    elsif($href->{content} eq 'ELSEIF') {
+      $post_chg=1;
+      $pre_chg=1;
+    }
+    elsif($href->{content} eq 'ELSE') {
+      $post_chg=1;
+      $pre_chg=1;
+    }
+    elsif($href->{content} eq 'ENDIF') {
+      $pre_chg=1;
+    }
+    elsif($href->{content} eq 'ENDIF') {
+      $pre_chg=1;
+    }
+    elsif($href->{content} eq 'WHERE_construct') {
+      $post_chg=1;
+    }
+    elsif($href->{content} eq 'ELSEWHERE') {
+      $post_chg=1;
+      $pre_chg=1;
+    }
+    elsif($href->{content} eq 'ENDWHERE') {
+      $pre_chg=1;
+    }
+    elsif($href->{content} eq 'ENDIF') {
+      $pre_chg=1;
+    }
+    elsif($href->{content} eq 'SELECT CASE') {
+      $post_chg=1;
+    }
+    elsif($href->{content} eq 'CASE') {
+      $post_chg=1;
+      $pre_chg=1;
+    }
+    elsif($href->{content} eq 'END SELECT') {
+      $pre_chg=1;
+    }
+    $cont_line=' ' if($href->{content} eq 'cont_line');
+    if( $pre_chg ) {
+      unless($cur_indent=~s/^$delta//o) {
+	print STDERR $_;
+	die  "f90_indent: something wrong, indent negative\n";;
+      }
+    }
+#    print "$cur_indent$cont_line$_";
+    
+    $_=$cur_indent.$cont_line.$_;
+    push(@$lines,$_);
+    $cur_indent.=$delta if( $post_chg );
+  }
+
+  if(! ($cur_indent eq '')) {
+    die "f90_indent: something wrong, indent=XX${cur_indent}XX\n";
+  }
+}
+
+#==========================================================================
+
+sub tidy {
+# Straigthforward tidiyng of statements
+  my($statements) = @_;
+  my($href,$content);
+  foreach $href (@$statements) {
+    $_=$href->{statement};
+    $content=$href->{content};
+# Substitute tab with four blanks
+    s/\t/    /g;
+    if($content eq 'comment') {
+# Substitute empty comment line with empty line
+      s/^[!] *\n$/\n/;
+      $href->{statement}=$_;
+      next;
+    }
+    if($href->{exec}) {
+      if($content eq 'ENDDO') {
+	s/\bEND DO\b/ENDDO/i;
+	$href->{statement}=$_;
+	next;
+      }
+      if($content eq 'ENDIF') {
+	s/\bEND IF\b/ENDIF/i;
+	$href->{statement}=$_;
+	next;
+      }
+      if($content eq 'ENDWHERE') {
+	s/\bEND WHERE\b/ENDWHERE/i;
+	$href->{statement}=$_;
+	next;
+      }
+
+      s/\bELSE IF\b/ELSEIF/i  if($content eq 'ELSEIF');
+
+      if(/\./) {
+	s/ *\.EQ\. */ == /gi;
+	s/ *\.NE\. */ \/= /gi;
+	s/ *\.LT\. */ < /gi;
+	s/ *\.LE\. */ <= /gi;
+	s/ *\.GT\. */ > /gi;
+	s/ *\.GE\. */ >= /gi;
+      }
+
+#
+      s/\bA?MAX[01]\b/MAX/gi;
+      s/\bA?MIN[01]\b/MIN/gi;
+      s/\bAMOD\b/MOD/gi;
+      s/\bALOG\b/LOG/gi;
+      s/\bALOG10\b/LOG10/gi;
+#      s/\bI(SIGN *\()/$1/gi; # Goes wrong in larcinad etc.
+      s/\bFLOAT\b/REAL/g;
+      s/\bfloat\b/real/g;
+    }
+    
+    $href->{statement}=$_;
+  }
+}
+
+#==========================================================================
+
+sub process_include_files {
+# Read include files and put reference to the anonomys array
+# holding the array of "statement" hashes in $href->{inc_statm}
+  my($statements,$prog_info,$inc_statements) = @_;
+  my ($content,$fname,$href);
+  return unless ($$prog_info{has_include});
+  my @lines=();
+  foreach $href (@$statements) {
+    $content=$href->{content};
+    if($content eq 'include'){
+      $_=$href->{statement};
+      /["](\S+)["]/;
+      $fname=$1;
+      &get_inc_lines($fname,\@lines);
+# Macro-removal
+      &remove_macro(\@lines);
+# Expand lines into statements and put refernce to this
+# array of hashes into $href->{inc_statm}
+      my @inc_statms=();
+      my $dum={};
+      &expcont(\@lines,\@inc_statms);
+      $href->{inc_statm}=[@inc_statms];
+      my $incs=$href->{inc_statm};
+# Study the read in file and add more attributes
+      &study($incs);
+#      print Dumper($incs,$dum);
+      
+    }
+  }
+}
+#==========================================================================
+sub get_inc_lines{
+# Recurcivly get lines from include files, flatten into array of lines
+  my ($fname,$lines) = @_;
+  my ($VPATH,@vpath,@tmp_lines);
+
+  $VPATH=$ENV{VPATH} or die "VPATH not defined ";
+# IFS VPATH /tmp/27/ifs/function:/tmp/27/ifs/common:/tmp/27/ifs/interface:/tmp/27/ifs/namelist:/tmp/27/ifsaux/include:/tmp/27/trans/interface:/tmp/27/obsort/interface:/tmp/27/ifs/ald_inc/function:/tmp/27/ifs/ald_inc/interface:/tmp/27/ifs/ald_inc/namelist
+  @vpath=split(":",$VPATH);
+# Look for include file in VPATH
+  foreach my $path (@vpath) {
+    my $ffname=$path.'/'.$fname;
+    if( -f $ffname) {
+# Read lines from include file
+      @tmp_lines = &readfile($ffname);
+#      print "$ffname \n";
+      for (@tmp_lines) {
+	if(/^\#include\b/){
+	  /["](\S+)["]/;
+	  my $fname2=$1;
+	  &get_inc_lines($fname2,$lines);
+	}
+	else {
+	  push(@$lines,$_);
+	}
+      }
+      last;
+    }
+  }
+  die "Include file $fname not found in VPATH=$VPATH " unless(@$lines);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &create_interface_block (\@statements, \@interface_block);
+#
+# DESCRIPTION
+#   This function analyses the Fortran statements in \@statements and returns
+#   an interface block in \@interface_block.
+# ------------------------------------------------------------------------------
+
+sub create_interface_block {
+  # Create a "minimal" interface block for subroutines
+  my  ($statements, $interface_block) = @_;
+  my  (%pu_args, %tokens);
+  our ($name, $nest_par);
+
+  @$interface_block = ();
+
+  my @tokens_in_lines = (); # List of tokens in each line
+
+  # Gather information needed to create interface block for routine
+  for my $href (@$statements) {
+    last if $href->{exec}; # exit loop at beginning of executable statements
+
+    # Get arguments of subroutine or function
+    if ($href->{content} eq 'SUBROUTINE' or $href->{content} eq 'FUNCTION') {
+      my $func;
+      my @pu_args;
+      $_ = $href->{statement};
+      &parse_prog_unit (\$func, \@pu_args);
+      $pu_args{uc ($_)} = 1 for @pu_args;
+      next;
+    }
+
+    # Get tokens from lines where arguments are present
+    # Inspect only type declaration statements
+    next unless $href->{decl} == 2;
+
+    my $statement = uc $href->{statement};
+    $statement =~ s/!.*$//; # Remove trailing comment
+
+    my @line_tokens = ();
+    if ($statement =~ s/^(.*?):://) {
+      # New style declaration statement contains "::"
+
+      # Tokens in specification part
+      my $spec = $1;
+      my @tokens = ($spec =~ /\b$name\b/g);
+      shift @tokens; # Remove leading token
+
+      for (@tokens) {
+        push @line_tokens, $_
+          unless /^(?:KIND|LEN|ALLOCATABLE|POINTER|TARGET|DIMENSION|OPTIONAL|
+                  SAVE|INTENT|IN|OUT|INOUT|PARAMETER)$/x;
+      }
+
+      # Tokens in declaration part
+      push @line_tokens, ($statement =~ /\b$name\b/g);
+
+    } else {
+      # Old style declaration statement does not contain "::"
+      @line_tokens = ($statement =~ /\b$name\b/g);
+      shift @line_tokens; # Remove leading token
+    }
+
+    push @tokens_in_lines, \@line_tokens;
+
+    # Check whether each token matches an argument
+    for my $token (@line_tokens) {
+      if (exists $pu_args{$token}) {
+        $tokens{$_} = 1 for @line_tokens;
+        last;
+      }
+    }
+  }
+
+  # Parse statements one more time to ensure all required tokens are included
+  for (@tokens_in_lines) {
+    my @line_tokens = @{ $_ };
+
+    # Check whether line contains an essential token
+    for my $token (@line_tokens) {
+      if (exists $tokens{$token}) {
+        $tokens{$_} = 1 for @line_tokens;
+        last;
+      }
+    }
+  }
+
+  # Create the interface block
+  for my $href (@$statements) {
+    my %myhref  = %$href;
+    my $content = $myhref{content};
+
+    # Ignore comment, executable statements and items in CONTAINS block
+    next if $content eq 'comment';
+    next if $myhref{exec};
+    next if $myhref{in_contain};
+
+    # Delete existing pre- and post -inserts
+    delete $myhref{pre_insert}  if exists $myhref{pre_insert};
+    delete $myhref{post_insert} if exists $myhref{post_insert};
+
+    # Put SUBROUTINE/FUNCTION statement into interface block
+    if ($content =~ /^(?:SUBROUTINE|FUNCTION)$/) {
+      $myhref{pre_insert} = 'INTERFACE' . "\n"; # Insert INTERFACE statement
+      push @$interface_block, \%myhref;
+    }
+
+    # Add USE statement in interface block, if necessary
+    if($myhref{decl} == 4) {
+      $_ = uc $myhref{statement};
+      tr/ \n//d;
+
+      if(/^USE$name,ONLY:(.+)$/) {
+        # USE statement with ONLY, check token to see if it is necessary
+	my @line_tokens = /\b$name\b/g;
+
+	for (@line_tokens) {
+	  if (exists $tokens{$_}) {
+	    push @$interface_block, \%myhref;
+	    last;
+	  }
+	}
+
+      } else {
+        # Always add USE statement without ONLY
+	push @$interface_block, \%myhref;
+      }  
+    }
+
+    if ($myhref{decl} == 1 or $myhref{decl} == 2) {
+      $_ = uc ($myhref{statement});
+      s/\s*!.*$//;
+
+      if ($content eq 'INTEGER' or $content eq 'PARAMETER') {
+        # INTEGER and PARAMETER may be used for dimensioning
+	my @line_tokens = /\b$name\b/g;
+
+	for (@line_tokens) {
+	  if (exists $tokens{$_}) {
+	    push @$interface_block, \%myhref;
+	    last;
+	  }
+	}
+      } else {
+        # Add line only if an argument is present
+	s/$nest_par//g;
+	my @line_tokens = /\b$name\b/g;
+
+	for (@line_tokens) {
+	  if (exists $pu_args{$_}) {
+	    push @$interface_block, \%myhref;
+	    last;
+	  }
+	}
+      }
+    }
+
+    # Add END statement to interface block
+    if ($content =~ /^END\s+(?:SUBROUTINE|FUNCTION)/) {
+      $myhref{post_insert} = 'END INTERFACE' . "\n";
+      push @$interface_block, \%myhref;
+    }
+  }
+
+  # Beautify the interface block
+  for my $href (@$interface_block) {
+    $_ = $href->{statement};
+
+    s/\!.*\n/\n/g; # Remove trailing comments
+    s/ +/ /g;      # Only one space
+    s/\n *\n/\n/g; # Remove empty lines
+    s/\n *\n/\n/g; # Remove empty lines again
+    s/ +\n/\n/g;   # No trailing spaces
+
+    $href->{statement} = $_;
+  }
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+
+sub change_var_names{
+  my($statements) = @_;
+  foreach my $href (@$statements) {
+    $_=$href->{statement};
+    s/\bVAZX\b/YVAZX/ig;
+    s/\bPVAZX\b/YDVAZX/ig;
+    s/\bVAZG\b/YVAZG/ig;
+    s/\bPVAZG\b/YDVAZG/ig;
+    s/\bSCALP_DV\b/YSCALP/ig;
+    s/\bRSCALP_DV\b/YRSCALP/ig;
+    s/\bSCALPSQRT_DV\b/YSCALPSQRT/ig;
+    s/\bRSCALPSQRT_DV\b/YRSCALPSQRT/ig;
+    s/\bPYBAR\b/YDYBAR/ig;
+    s/\bPSBAR\b/YDSBAR/ig;
+    s/\bVCGLPC\b/YVCGLPC/ig;
+    s/\bVCGLEV\b/YVCGLEV/ig;
+    s/\bSKFROT\b/YSKFROT/ig;
+    s/\bSKFMAT\b/YSKFMAT/ig;
+    s/\bSTATE_VECTOR_4D\b/YSTATE_VECTOR_4D/ig;
+    s/\bVAZX0\b/YVAZX0/ig;
+    s/\bVAZG0\b/YVAZG0/ig;
+    s/\bRSPFORCE\b/YSPFORCE/ig;
+    $href->{statement}=$_;
+  }
+}
+# =========================================================================
+sub remake_arg_decl{
+  my($statements,$prog_info) = @_;
+  my($href,$content,@pu_args,$func,%tokens);
+  my($left,$right,%arghash,$dim);
+  our($nest_par,$name);
+
+  my $dims='';
+# Crack existing dummy declarations, build hash arghash
+  foreach $href (@$statements) {
+    last if($href->{prog_unit} >0);
+    if($href->{content} eq 'SUBROUTINE') {   # Get arguments of subroutine
+      $_=$href->{statement};
+      my $dum=&parse_prog_unit(\$func,\@pu_args);
+#      print Dumper(\@pu_args);
+      for(@pu_args) {
+	$_=uc($_);
+	$arghash{$_}{other}='';
+	$arghash{$_}{dimuse}=0;
+	$arghash{$_}{intent}='';
+	$arghash{$_}{used}=0;
+	$arghash{$_}{set}=0;
+	$arghash{$_}{reallyset}=0;
+	$arghash{$_}{type}='';
+	$arghash{$_}{comment}='';
+	$arghash{$_}{inif}=0;
+      }
+      next;
+    }
+    if($href->{decl} == 2) {
+      $_=$href->{statement};
+      my $comment='';
+      $comment=$1 if(/.*(\!.*)$/);
+      s/\!.*\n/\n/g;                        # Remove trailing comments in all lines
+      $_=uc($_);
+      s/\s//g;
+      if(/^(.+)::(.+)$/){
+	$left=$1;
+	$right=$2;
+	$_=$right;
+	s/$nest_par//g;
+	s/($name)\*\w+/$1/g;
+#	print "XX  $_ \n";
+	foreach my $arg (@pu_args) {
+	  if(/\b$arg\b/) {
+#	    print "ARG $arg $left $_ \n";
+	    $arghash{$arg}{linedec}=$href->{number};
+	    $arghash{$arg}{comment}=$comment;
+	    my @locdec =split ',',$left;
+	    my $i=0;
+	    foreach my $locdec (@locdec) {
+	      if($i == 0) {
+		$arghash{$arg}{type}=$locdec;
+	      }
+	      elsif($locdec=~/\bINTENT/) {
+		$arghash{$arg}{intent}=','.$locdec;
+	      }
+	      else {
+		$arghash{$arg}{other}=$arghash{$arg}{other}.','.$locdec;
+	      }
+	      $i++;
+	    }
+	    if($right=~/\b$arg\b(\*\w+)/) {
+	      $dim=$1;
+	    }
+	    elsif($right=~/\b$arg\b($nest_par\*$nest_par)/) {
+	      $dim=$1;
+	    }
+	    elsif($right=~/\b$arg\b($nest_par\*\w+)/) {
+	      $dim=$1;
+	    }
+	    elsif($right=~/\b$arg\b(\*$nest_par)/) {
+	      $dim=$1;
+	    }
+	    elsif($right=~/\b$arg\b($nest_par)/) {
+	      $dim=$1;
+	    }
+	    else {
+	      $dim='';
+	    }
+	    $arghash{$arg}{dim}=$dim;
+	    $dims=$dims.$dim
+	      }
+	}
+	foreach my $arg (@pu_args) {  # Is arg. used for dimensioning other args?
+	  if($dims=~/\b$arg\b/i) {
+	    $arghash{$arg}{dimuse}=1;
+	  }
+	}  
+      }
+    }
+  }
+  my $insert_line=0;
+  foreach $href (@$statements) {
+    last if($href->{prog_unit} >0);
+    if($href->{decl} == 2 or $href->{content} eq 'PARAMETER') {                 
+      $_=uc($href->{statement});
+      next unless /\bPARAMETER\b/;
+      my @tmpvar=/\b$name\b/g;
+      foreach my $token (@tmpvar) {
+	if($dims=~/\b$token\b/) {
+	  $insert_line=$href->{number};
+	}
+      }
+    }
+  }
+      
+# Gather info to decide INTENT status
+  my $inif=0;
+  my @inif_stack=();
+  my $cur_inif=0;
+  foreach $href (@$statements) {
+    last if($href->{prog_unit} >0);
+    if($href->{exec}) {
+      if($href->{content} eq 'ENDIF') {
+	$inif--;
+	$cur_inif=pop @inif_stack;
+	next;
+      }
+      elsif($href->{content} eq 'ELSEIF' or $href->{content} eq 'ELSE') {
+	$cur_inif=pop @inif_stack;
+	$cur_inif=$href->{number};
+	push @inif_stack,$cur_inif;
+      }
+      my ($left,$right);
+      $_=$href->{statement};
+      s/\!.*\n/\n/g;                        # Remove trailing comments in all lines
+      my %setnow=();
+      foreach my $arg (@pu_args) {
+	$setnow{$arg}=0;
+	$setnow{$arg}=1 if($arghash{$arg}{reallyset});
+	unless ($setnow{$arg}) {
+	  foreach my $xx (@inif_stack) {
+	    $setnow{$arg}=1 if($xx == $arghash{$arg}{inif});
+	  }
+	}
+      }
+      
+      if($href->{content} eq 'scal_assign' or $href->{content} eq 'array_assign') {
+	s/\s//g;
+	($left,$right)=/^(.+)=(.+)$/;
+	$_=$right;
+	foreach my $arg (@pu_args) {
+	  if(/\b$arg\b/i) {
+	    $arghash{$arg}{used}=1 unless $setnow{$arg};
+	  }
+	}
+	$_=$left;
+	if(/($nest_par)/) {
+	  $_=$1;
+	  foreach my $arg (@pu_args) {
+	    if(/\b$arg\b/i) {
+	      $arghash{$arg}{used}=1 unless $setnow{$arg};
+	    }
+	  }
+	}
+	$_=$left;
+	foreach my $arg (@pu_args) {
+	  if(/^$arg\b/i) {
+	    $arghash{$arg}{set}=1;
+	    $arghash{$arg}{inif}=$cur_inif;
+	    $arghash{$arg}{reallyset}=1 unless($inif);
+	  }
+	}
+      }
+      elsif($href->{content} eq 'IF' ) {
+	if($href->{content2} eq 'scal_assign' or $href->{content2} eq 'array_assign' or 
+	   $href->{content2} eq 'CALL') {
+	  s/\n//g;
+	  ($left,$right)=/^\s*(IF\b\s*$nest_par)(.+)/i;
+	  $_=$left;
+	  foreach my $arg (@pu_args) {
+	    if(/\b$arg\b/i) {
+	      $arghash{$arg}{used}=1 unless $setnow{$arg};
+	    }
+	  }
+	  $_=$right;
+	  if($href->{content2} eq 'CALL') {
+	    my $statement=$right;
+	    my $inifx=1;
+	    &propag_arg(\$statement,\%arghash,\$inifx,\%setnow);
+	  }
+	  else {
+	    s/\s//g;
+	    ($left,$right)=/^(.+)=(.+)$/;
+	    $_=$right;
+	    foreach my $arg (@pu_args) {
+	      if(/\b$arg\b/i) {
+		$arghash{$arg}{used}=1 unless $setnow{$arg};
+	      }
+	    }
+	    $_=$left;
+	    if(/($nest_par)/) {
+	      $_=$1;
+	      foreach my $arg (@pu_args) {
+		if(/\b$arg\b/i) {
+		  $arghash{$arg}{used}=1 unless $setnow{$arg};
+		}
+	      }
+	    }
+	    $_=$left;
+	    foreach my $arg (@pu_args) {
+	      if(/^$arg\b/i) {
+		$arghash{$arg}{inif}=$cur_inif;
+		$arghash{$arg}{set}=1;
+	      }
+	    }
+	  }
+	}
+	else {
+	  foreach my $arg (@pu_args) {
+	    if(/\b$arg\b/i) {
+	      $arghash{$arg}{used}=1 unless $setnow{$arg};
+	    }
+	  }
+	}
+      }
+      elsif($href->{content} eq 'WHERE' ) {
+	s/\s//g;
+	($left,$right)=/^(WHERE$nest_par)(.+)/i;
+	$_=$left;
+	foreach my $arg (@pu_args) {
+	  if(/\b$arg\b/i) {
+	    $arghash{$arg}{used}=1 unless $setnow{$arg};
+	  }
+	}
+	$_=$right;
+	($left,$right)=/^(.+)=(.+)$/;
+	$_=$right;
+	foreach my $arg (@pu_args) {
+	  if(/\b$arg\b/i) {
+	    $arghash{$arg}{used}=1 unless $setnow{$arg};
+	  }
+	}
+	$_=$left;
+	foreach my $arg (@pu_args) {
+	  if(/^$arg\b/i) {
+	    $arghash{$arg}{inif}=$cur_inif;
+	    $arghash{$arg}{set}=1;
+	  }
+	}
+      }
+      elsif($href->{content} eq 'CALL') {
+	my $statement=$_;
+	&propag_arg(\$statement,\%arghash,\$inif);
+      }
+      else{
+	foreach my $arg (@pu_args) {
+	  if(/\b$arg\b/i) {
+	    $arghash{$arg}{used}=1 unless $setnow{$arg};
+	  }
+	}
+      }
+      if($href->{content} eq 'IF_construct') {
+	$inif++;
+	$cur_inif=$href->{number};
+	push @inif_stack,$cur_inif;
+      }
+    }	  
+  }
+
+# Create INTENT statemant based on gathered info
+  foreach my $arg (@pu_args) {
+    if($arghash{$arg}{linedec}) {
+      if($arghash{$arg}{nointent}) {
+	unless($arghash{$arg}{intent}) {
+	  $arghash{$arg}{intent}=' ';
+	  $arghash{$arg}{comment}='! UNDETERMINED INTENT';
+	}
+      }
+      else{
+	my $intent='';
+	$intent='IN' if($arghash{$arg}{used} or $arghash{$arg}{dimuse});
+	$intent=$intent.'OUT' if($arghash{$arg}{set});
+	if($intent) {
+	  if($arghash{$arg}{intent} and $intent eq 'OUT') {
+	    $intent='INOUT' if $arghash{$arg}{intent}=~/INOUT/i;
+	  }
+	  $arghash{$arg}{intent}=',INTENT('.$intent.')';
+	}
+	else {
+	  $arghash{$arg}{intent}=' ';
+	  $arghash{$arg}{comment}='! Argument NOT used';
+	}
+      }
+    }
+  }
+
+# Remove existing argument declarations
+  foreach my $arg (@pu_args) {
+    if($arghash{$arg}{linedec}) {
+      $_=$$statements[$arghash{$arg}{linedec}]->{statement};
+      #   print "BEFORE $arg $_";
+      if(/.*::\s*\b$arg\b\s*(\!.*\n)*$/i) {
+	$_='';
+      }
+      elsif(/.*::\s*\b$arg\b\s*$nest_par\s*(\!.*\n)*$/i) {
+	$_='';
+      }
+      elsif(/.*::\s*\b$arg\b\s*\*\s*\w+\s*(\!.*\n)*$/i) {
+	$_='';
+      }
+      elsif(/.*::\s*\b$arg\b\s*\*\s*$nest_par\s*(\!.*\n)*$/i) {
+	$_='';
+      }
+      elsif(/.*::\s*\b$arg\b\s*$nest_par\s*\*\s*\w+\s*(\!.*\n)*$/i) {
+	$_='';
+      }
+      elsif(/.*::\s*\b$arg\b\s*$nest_par\s*\*\s*$nest_par\s*(\!.*\n)*$/i) {
+	$_='';
+      }
+      else{
+	/^(.*::)(.*)$/s;
+	my $left=$1;
+	$_=$2;
+	s/\b$arg\b\s*$nest_par//i;
+	s/\b$arg\b\s*\*\s*\w+//i;
+	s/\b$arg\b\s*\*\s*$nest_par//i;
+	s/\b$arg\b//i;
+	s/,\s*,/,/;
+	s/,(\s*)$/$1/;
+	s/\n\s*\n/\n/g;
+	$_=$left.$_;
+	s/::\s*,/::/;
+      }
+ #   print "AFTER $arg $_\n";
+      $$statements[$arghash{$arg}{linedec}]->{statement}=$_; 
+    }
+  }
+
+ # Write out
+
+  my $newdecl='';
+  my $linedec;
+  foreach my $arg (@pu_args) {
+    if($arghash{$arg}{linedec}) {
+      if($arghash{$arg}{other} and ! $arghash{$arg}{dim}) {
+	$arghash{$arg}{other}=~s/\s//g;
+	if($arghash{$arg}{other}=~/^,DIMENSION($nest_par)$/i) {
+	  $arghash{$arg}{other}='';
+	  $arghash{$arg}{dim}=$1;
+	}
+      }
+      if($arghash{$arg}{dimuse}) { # Put declerations of args first
+	$linedec=sprintf "%-18s%s%-14s%s%s%s%s %s",
+	$arghash{$arg}{type},$arghash{$arg}{other},$arghash{$arg}{intent},
+	    ' :: ',$arg,$arghash{$arg}{dim},$arghash{$arg}{comment},"\n";
+	$newdecl=$newdecl.$linedec;
+      }
+    }
+  }
+  foreach my $arg (@pu_args) {
+    if($arghash{$arg}{linedec}) {
+      unless($arghash{$arg}{dimuse}) {
+	$linedec=sprintf "%-18s%s%-14s%s%s%s %s%s",
+	$arghash{$arg}{type},$arghash{$arg}{other},$arghash{$arg}{intent},
+	    ' :: ',$arg,$arghash{$arg}{dim},$arghash{$arg}{comment},"\n";
+	$newdecl=$newdecl.$linedec;
+      }
+    }
+  }
+#  print "INSERT_LINE $insert_line \n";
+  if($insert_line) {
+    $$statements[$insert_line]->{post_insert}=$newdecl;
+  }
+  else{
+    foreach $href (@$statements) {
+      if($href->{decl} == 2) {                 
+	$href->{pre_insert}=$newdecl;
+	last;
+      }
+    }
+  }
+
+#  print $newdecl;
+#  print Dumper(\%arghash);
+}
+
+sub propag_arg{
+  my ($statement,$arghash,$inif,$setnow) = @_;
+  our ($name,$nest_par);
+  my (%argpos);
+  $_=$$statement;
+  s/^\s*CALL\s+($name)//i;
+  my $called=lc($1);
+  s/\s//g;
+  s/^\((.*)\)$/$1/s;
+  my @inpars=/$nest_par/g;
+  s/$nest_par//g;
+  s/($name)%$name/$1/g;
+  $_=uc($_);
+#  print "PROPAG $called $_ ££ @inpars \n";
+  my @call_args=split ',' , $_;
+  my $i=0;
+  my $interesting=0;
+  %argpos=();
+  foreach my $call (@call_args) {
+    
+#    print "CALL $called $call \n" ;
+    if($call=~/(.+)=(.+)/) {
+      $call=$2; #This just by-passes the problem
+    }
+    if(exists $$arghash{$call}) {
+      if(exists $argpos{$call}) {
+	push @{$argpos{$call}},$i;
+      }
+      else {
+	my @i=($i);
+	$argpos{$call}=[@i];
+      }
+      $interesting=1;
+    }
+    $i++;
+  }
+  if($interesting) {
+    my $fname='/tmp/intblocks/'.$called.'.intfb.h';
+    if( -f $fname ) {
+      my @dumargs=();
+      my $unit_name;
+      print "FILE $fname FOUND \n";
+      my @lines = &readfile($fname);
+      my @loc_statements=(); 
+      &expcont(\@lines,\@loc_statements);
+      foreach my $href (@loc_statements) {
+	$_=$href->{statement};
+	if(/^\s*SUBROUTINE/i) {
+	  my $dum=&parse_prog_unit(\$unit_name,\@dumargs);
+	  next;
+	}
+	if(/::/) {
+	  s/\s//g;
+	  foreach my $arg (keys (%argpos)) {
+	    my $set_before=$$setnow{$arg};
+	    foreach my $i (@{$argpos{$arg}}){
+	      if(/::$dumargs[$i]/) {
+		if(/INTENT\(IN\)/i) {
+		  $$arghash{$arg}{used}=1 unless $set_before;
+		}
+		elsif(/INTENT\(OUT\)/i) {
+		  $$arghash{$arg}{set}=1;
+		  $$setnow{$arg}=1 unless($$inif);
+		}
+		elsif(/INTENT\(INOUT\)/i) {
+		  $$arghash{$arg}{set}=1;
+		  $$arghash{$arg}{used}=1 unless $set_before;;
+		  $$arghash{$arg}{reallyset}=1 unless($$inif);
+		}
+		elsif(/\! UNDETERMINED INTENT/) {
+		  $$arghash{$arg}{nointent}=1;
+		}
+	      }
+	    }
+	  }
+	}
+      }
+    }
+    else {
+      foreach my $arg (keys (%argpos)) {
+	$$arghash{$arg}{nointent}=1;
+      }
+    }
+  }
+  for (@inpars) {
+    foreach my $arg (keys (%$arghash)) {
+      if(exists $$arghash{$arg}) {
+	if(/\b$arg\b/i) {
+	  $$arghash{$arg}{used}=1 unless $$setnow{$arg};
+	}
+      }
+    }
+  }
+}
+  
+sub add_interface_blocks {
+# Add interface block for called routines
+  use File::Find;
+  my($statements,$prog_info) = @_;
+  my($href,$call);
+  our($name,$nest_par);
+  our(@call_names,@call_names_found,%call_names);
+
+  return unless ($$prog_info{no_calls}); # Skip if there are no calls
+  @call_names=();
+  %call_names=();
+
+  my $last_decl=0;
+  my $in_intfblk=0;
+  my %already_in=();
+  ST:foreach $href (@$statements) {
+    last if($href->{prog_unit} > 0);  # Only consider first program unit (no contains)
+    if($href->{content} eq 'INTERFACE') {
+      $in_intfblk=1;
+      next;
+    }
+    if($href->{content} eq 'END INTERFACE') {
+      $in_intfblk=0;
+      next;
+    }
+    if($in_intfblk) {
+      $_=$href->{statement};
+      s/\#include\s*\"(\w+)\.h\"\s*$/$1/;
+      $_=lc($_);
+      $already_in{$_}++;
+      next;
+    }
+    
+# Find last declaration
+    if($href->{decl}) {
+      next if($href->{content} eq 'FORMAT');
+      next if($href->{content} eq 'DATA');
+      $last_decl = $href->{number} ;
+    }
+# Find calls
+    next unless($href->{exec});
+    if($href->{content} eq 'CALL' or 
+       (exists  $href->{content2} and$ href->{content2} eq 'CALL') ) {
+      $_=$href->{statement};
+      /\s*\bCALL\b\s*($name)/i;
+      my $call=lc($1);
+      next if($already_in{$call}); # Exclude already existing interface block
+      next if($call eq 'packmsg'); # A couple of special exceptions
+      next if($call eq 'unpkmsg');
+      $call_names{$call}++;
+    }
+  }
+  
+
+# Check that routine exists in IFS
+  @call_names_found=();
+  find(\&calls_wanted,'/tmp/27/ifs/');
+#  find(\&calls_wanted,'/home/mats/work/cy28/ifs/');
+#  find(\&calls_wanted,'/tmp/27/trans/');
+  @call_names_found=sort(@call_names_found);
+#  print "P2 @call_names_found \n";
+  @call_names=@call_names_found;
+
+# Contruct include block
+  my $block='';
+  for (@call_names) {
+    $block=$block.'#include "'.$_.'.intfb.h"'."\n";
+  }
+#  print $block;
+
+  my $clean=0;
+  if(@call_names) {
+    if($$prog_info{has_interface_block}) {
+      foreach $href (@$statements) {
+# Add interface block to routine that already has INTERFACE statement
+	if($href->{content} eq 'END INTERFACE'){
+	  if($href->{post_insert}) {
+	    $href->{post_insert}=$href->{post_insert}."\n".$block;
+	  }
+	  else {
+	    $href->{post_insert}="\n".$block;
+	  }	    
+	  last;
+	}
+      }
+    }
+# Add interface block to routine that does not have previous INTERFACE statement
+    else {
+      $href=@$statements[$last_decl];
+      if($href->{post_insert}) {
+	$href->{post_insert}=$href->{post_insert}."\n".$block;
+      }
+      else {
+	$href->{post_insert}="\n".$block;
+      }	    
+    }
+# Remove from EXTERNAL statement where interface block has been added
+    foreach $href (@$statements) {
+      if($href->{content} eq 'EXTERNAL') {
+	$_=$href->{statement};
+	foreach my $ext (@call_names) {
+	  s/\b$ext\b//i;
+	}
+	s/,\s*,/,/g;
+	s/^(\s*EXTERNAL\s*),/$1/i;
+	s/^(\s*EXTERNAL.*),\s*$/$1/i;
+	s/^\s*EXTERNAL\s*,*\s*$//i;
+	$href->{statement}=$_;	
+      }
+    }
+  }
+}
+#======================================================================================
+sub calls_wanted {
+  # Used by Find as called from add_interface_blocks
+  our(%call_names,@call_names_found);
+  return unless (/^(\w+)\.F90$/);
+  my $call=$1;
+  if($call_names{$call}) {
+    push(@call_names_found,$call);
+  }    
+}
+sub remove_some_comments{
+  my($statements) = @_;
+  my $prev_empty=0;
+  foreach my $href (@$statements) {
+    if($href->{content} eq 'comment'){
+      $_=$href->{statement};
+      if(/^\s*$/) {
+	if($prev_empty) {
+	  s/\s*//;
+	  $href->{statement}=$_;
+	}
+	else {
+	  $prev_empty=1;
+	} 
+	next;
+      }
+      $prev_empty=0;
+      s/^\s*![\s\*]*\bLOCAL\s+(INTEGER|REAL|LOGICAL|CHARACTER)\s+(SCALARS|ARRAYS).*\n$//i;
+      s/^\s*![\s\*]*\bDUMMY\s+(INTEGER|REAL|LOGICAL|CHARACTER)\s+(SCALARS|ARRAYS).*\n$//i;
+      s/^\s*![\s\*]*\bLOCAL\s+(INTEGER|REAL|LOGICAL|CHARACTER).*\n$//i;
+      s/^\s*![\s\*]*\bDUMMY\b\s*$//i;
+      s/^\s*![\s\*]*\bLOCAL\b\s*$//i;
+      s/^\s*![\s\*]*\bLOCAL\b:\s*$//i;
+      s/^\s*![\s\*]*\bLOCAL ARRAYS\b[\s\*]*$//i;
+      s/^\s*![\s\*]*\bLOCAL SCALARS\b\s*$//i;
+      s/^\s*![\s\*]*\s*\d\.\d+\s*\bLOCAL ARRAYS\b\s*$//i;
+      s/^\s*![\s\*]*\s*=== LOCAL ARRAYS ===\s*$//i;
+      $href->{statement}=$_;
+    }
+    else {
+      $prev_empty=0;
+    }
+  }
+}      
+sub get_calls_inc {
+  my($statements,$calls,$intfb) = @_;
+  foreach my $href (@$statements) {
+    if($href->{content} eq 'CALL') {
+      $_=$href->{statement};
+      /^\s*CALL\s+([A-Z]\w*)/i;
+      $$calls{lc($1)}++;
+    }
+    elsif($href->{content} eq 'IF') {
+      if($href->{content2} eq 'CALL') {
+	$_=$href->{statement};
+	/\bCALL\s+([A-Z]\w*)/i;
+	$$calls{lc($1)}++;
+      }
+    }
+    elsif($href->{content} eq 'include') {
+      $_=$href->{statement};
+      $$intfb{$1}=1 if(/["](\S+)\.intfb\.h["]/);
+      $$intfb{$1}=2 if(/["](\S+)\.h["]/); # For old-style interface blocks
+    }
+  }
+}
+
+1;
+      
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Build.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Build.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Build.pm	(revision 7236)
@@ -0,0 +1,2428 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Fcm::Build
+#
+# DESCRIPTION
+#   The main purpose of this class is to process the build configuration,
+#   generate the required files for the build and invoke make to create the
+#   build.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::Build;
+
+# Standard pragma
+use strict;
+use warnings;
+
+# Standard modules
+use Carp;
+use Cwd;
+use File::Basename;
+use File::Path;
+use File::Spec::Functions;
+
+# FCM component modules
+use Fcm::CfgFile;
+use Fcm::SrcPackage;
+use Fcm::BuildTask;
+use Fcm::Util;
+use Fcm::Timer;
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $bld = Fcm::Build->new (
+#     CONFIG  => $config,
+#     CFG_SRC => $cfg_src,
+#   );
+#
+# DESCRIPTION
+#   This method constructs a new instance of the Fcm::Build class.
+#
+# ARGUMENTS
+#   CONFIG     - reference to a Fcm::Config instance
+#   CFG_SRC    - source path to the build configuration file
+# ------------------------------------------------------------------------------
+
+sub new {
+  my $this  = shift;
+  my %args  = @_;
+  my $class = ref $this || $this;
+
+  my $cfg    = exists $args{CFG_SRC} ? $args{CFG_SRC} : undef;
+  my $config = exists $args{CONFIG}  ? $args{CONFIG}  : &main::cfg;
+
+  my $self  = {
+    CONFIG   => $config,            # configuration settings
+    CFG      => Fcm::CfgFile->new ( # bld cfg
+      TYPE   => 'bld',              # config file type
+      SRC    => $cfg,               # source path of the bld cfg
+      CONFIG => $config,            # configuration settings
+    ),
+    NAME     => '',                 # name of this build
+    DIR      => {                   # directory tree of this build
+      ROOT    => '',                # root directory of this build
+    },
+    PATH     => {},                 # search paths of this build
+    SEARCH   => 1,                  # search for source directories in src/?
+    SRCDIR   => {},                 # source directories of this build
+    PP       => {},                 # pre-process flags
+    PACKAGE  => {},                 # source directory packages of this build
+    TARGET   => [],                 # targets of this build
+    USE      => [],                 # list of inherited builds
+    INHERIT  => {                   # inheritance flags
+      SRCDIR => 1,                  # inherit source directories?
+      PP     => 1,                  # inherit pre-process flags?
+      TARGET => 0,                  # inherit targets?
+    },
+    LIB      => {'' => ''},         # name of libraries
+    LOCK     => undef,              # lock file
+  };
+  bless $self, $class;
+  return $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->DESTROY;
+#
+# DESCRIPTION
+#   This method is called automatically when a Fcm::Build object is
+#   destroyed.
+# ------------------------------------------------------------------------------
+
+sub DESTROY {
+  my $self = shift;
+
+  # Remove the lock if it is set
+  unlink $self->{LOCK} if $self->{LOCK} and -e $self->{LOCK};
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $config = $bld->config;
+#
+# DESCRIPTION
+#   This method returns a reference to the Fcm::Config instance.
+# ------------------------------------------------------------------------------
+
+sub config {
+  my $self = shift;
+
+  return $self->{CONFIG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cfgfile = $bld->cfg;
+#
+# DESCRIPTION
+#   This method returns a reference to a Fcm::CfgFile instance for the build
+#   configuration file.
+# ------------------------------------------------------------------------------
+
+sub cfg {
+  my $self = shift;
+
+  return $self->{CFG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   %allpcks = $bld->allpcks ();
+#
+# DESCRIPTION
+#   This method returns a hash table with keys representing all the packages
+#   declared in the current build. The value of each element in the hash is a
+#   reference to a list of children of the current package.
+# ------------------------------------------------------------------------------
+
+sub allpcks {
+  my $self        = shift;
+  my %allpcks = ();
+
+  for my $pckname (keys %{ $self->{PACKAGE} }) {
+    $allpcks{$pckname} = [];
+  }
+
+  for my $pckname (keys %{ $self->{PACKAGE} }) {
+    my @names = split /__/, $pckname;
+
+    my $cur = $pckname;
+    while ($cur) {
+      pop @names;
+      my $depend = @names ? join '__', @names : '';
+      $allpcks{$depend} = [] unless exists $allpcks{$depend};
+
+      push @{ $allpcks{$depend} }, $cur
+        unless grep {$_ eq $cur} @{ $allpcks{$depend} };
+
+      $cur = $depend;
+    }
+  }
+
+  return %allpcks;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rc = $bld->build (
+#     [ARCHIVE     => $archive,]
+#     [FULL        => $full,]
+#     [IGNORE_LOCK => $ignore_lock,]
+#     [JOBS        => $jobs,]
+#     [STAGE       => $stage,]
+#     [TARGETS     => \@targets,]
+#   );
+#
+# DESCRIPTION
+#   This method performs a build based on the current configuration. The
+#   method returns 1 on success.
+#
+# ARGUMENTS
+#   ARCHIVE      - If set to "true", invoke the "archive" mode. Most build files
+#                  and directories created by this build will be archived using
+#                  the "tar" command. If not set, the default is not to invoke
+#                  the "archive" mode.
+#   FULL         - If set to "true", invoke the build in "full" mode. Build files
+#                  and directories created by previous builds in the same
+#                  location will be removed before the current build is
+#                  performed. If not set, the default is to perform the build
+#                  in "incremental" mode.
+#   IGNORE_LOCK  - If set to "true", it ignores any lock files that may exist in
+#                  the build root directory. 
+#   JOBS         - Specify number of jobs that can be handled by "make". If set,
+#                  the value must be a natural integer. If not set, the default
+#                  value is 1 (i.e. run "make" in serial mode).
+#   STAGE        - If set, it should be an integer number or a recognised
+#                  keyword or abbreviation. If set, the build is performed up
+#                  to the named stage. If not set, the default is to perform
+#                  all stages of the build. Allowed values are:
+#                  1, setup or s
+#                  2, pre_process or pp
+#                  3, generate_dependency or gd
+#                  4, generate_interface or gi
+#                  5, all, a, make or m
+#   TARGETS      - Specify targets to be built. If set, these targets will be
+#                  built instead of the ones specified in the build
+#                  configuration file.
+# ------------------------------------------------------------------------------
+
+sub build {
+  my $self = shift;
+  my %args = @_;
+
+  # Process arguments
+  my $archive     = exists $args{ARCHIVE}     ? $args{ARCHIVE}     : 0;
+  my $full        = exists $args{FULL}        ? $args{FULL}        : 0;
+  my $ignore_lock = exists $args{IGNORE_LOCK} ? $args{IGNORE_LOCK} : 0;
+  my $jobs        = exists $args{JOBS}        ? $args{JOBS}        : 1;
+  my $stage       = exists $args{STAGE}       ? $args{STAGE}       : 5;
+  my $targets     = exists $args{TARGETS}     ? $args{TARGETS}     : [qw/all/];
+
+  # Resolve named stages
+  $stage = 5 unless $stage;
+  if ($stage !~ /^\d$/) {
+    my %stagenames = (
+      'S(?:ETUP)?'                      => 1,
+      'P(?:RE)?_?P(?:ROCESS)?'          => 2,
+      'G(?:ENERATE)?_?D(?:ENPENDENCY)?' => 3,
+      'G(?:ENERATE)?_?I(?:NTERFACE)?'   => 4,
+      '(?:A(?:LL)|M(?:AKE)?)'           => 5,
+    );
+
+    for my $name (keys %stagenames) {
+      if ($stage =~ /$name/i) {
+        $stage = $stagenames{$name};
+        last;
+      }
+    }
+
+    if ($stage !~ /^\d$/) {
+      w_report 'Warning: invalid build stage: ', $stage, ', default to "5"';
+      $stage = 5;
+    }
+  }
+
+  # Get verbose mode
+  my $verbose = $self->config->verbose;
+
+  # Stage 1: setup
+  my $date = localtime;
+  print 'Build command started on ', $date, '.', "\n" if $verbose;
+  my $otime = time;
+
+  print '->Setup              : start', "\n" if $verbose;
+  my $stime = time;
+
+  # Read configurations
+  my $rc = $self->decipher_cfg;
+
+  # Check directories are set
+  $rc = $self->check_dir if $rc;
+
+  # Check for lock files
+  $rc = $self->check_lock if $rc and not $ignore_lock;
+
+  # Set a lock file
+  $rc = $self->_set_lock if $rc;
+
+  # Create build root directory if necessary
+  $rc = $self->_create_build_dir if $rc;
+
+  # Set up directory inheritance
+  $rc = $self->_setup_dir (FULL => $full) if $rc;
+
+  # Set up source directories, targets, etc
+  $rc = $self->_update_bld_info if $rc;
+
+  # Set up PP flag cache
+  $rc = $self->_update_pp_info if $rc;
+
+  # Set up build tools cache
+  $rc = $self->_update_tool_info if $rc;
+
+  # Set up regenerate make rule cache
+  $rc = $self->_update_regen_rule_info if $rc;
+
+  my $ftime = time;
+  my $s_str = $ftime - $stime > 1 ? 'seconds' : 'second';
+  print '->Setup              : ', $ftime - $stime, ' ', $s_str, "\n";
+
+  # Stage 2: Pre-process
+  if ($rc and $stage >= 2) {
+    print '->Pre-process        : start', "\n" if $verbose;
+    my $stime = time;
+
+    $rc = $self->_pre_process;
+
+    $ftime = time;
+    $s_str = $ftime - $stime > 1 ? 'seconds' : 'second';
+    print '->Pre-process        : ', $ftime - $stime, ' ', $s_str, "\n";
+  }
+
+  # Stage 3: Scan dependency and write make rules
+  if ($rc and $stage >= 3) {
+    print '->Scan dependency    : start', "\n" if $verbose;
+    my $stime = time;
+
+    $rc = $self->_scan_dependency;
+    $rc = $self->_write_make_rules if $rc;
+    $rc = $self->_write_makefile if $rc;
+
+    $ftime = time;
+    $s_str = $ftime - $stime > 1 ? 'seconds' : 'second';
+    print '->Scan dependency    : ', $ftime - $stime, ' ', $s_str, "\n";
+  }
+
+  # Stage 4: Generate Fortran 9x interface block
+  if ($rc and $stage >= 4) {
+    print '->Generate interface : start', "\n" if $verbose;
+    my $stime = time;
+
+    $rc = $self->_generate_f9x_interface;
+
+    $ftime = time;
+    $s_str = $ftime - $stime > 1 ? 'seconds' : 'second';
+    print '->Generate interface : ', $ftime - $stime, ' ', $s_str, "\n";
+  }
+
+  # Stage 5: Make the build
+  if ($rc and $stage >= 5) {
+    print '->Make               : start', "\n" if $verbose;
+    my $stime = time;
+
+    $rc = $self->_invoke_make (
+      TARGETS => $targets,
+      JOBS    => $jobs,
+      ARCHIVE => $archive,
+    );
+
+    # Remove empty build directories
+    $rc = $self->_remove_empty_dirs () if $rc;
+
+    # Create TAR archives if necessary
+    $rc = $self->_tar_build_dirs () if $rc and $archive;
+
+    # Create run time environment script if necessary
+    $rc = $self->_create_runenv_script () if $rc;
+
+    # Create exclude dependency configurations for libraries
+    $rc = $self->_create_lib_excl_dep () if $rc;
+
+    $ftime = time;
+    $s_str = $ftime - $stime > 1 ? 'seconds' : 'second';
+    print '->Make               : ', $ftime - $stime, ' ', $s_str, "\n";
+  }
+
+  if ($verbose) {
+    $s_str = $ftime - $otime > 1 ? 'seconds' : 'second';
+    print '->TOTAL              : ', $ftime - $otime, ' ', $s_str, "\n";
+  }
+
+  $date = localtime;
+  if ($rc) {
+    print 'Build command finished on ', $date, '.', "\n" if $verbose;
+
+  } else {
+    e_report 'Build command failed on ', $date, '.';
+  }
+
+  return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $bld->decipher_cfg ();
+#
+# DESCRIPTION
+#   This method deciphers the build configuration file and assigns the
+#   configurations to the variables of the current build.
+# ------------------------------------------------------------------------------
+
+sub decipher_cfg {
+  my $self = shift;
+
+  my $read = $self->cfg->read_cfg;
+
+  # Check config file type
+  if ($read) {
+    if ($self->cfg->type ne 'bld') {
+      w_report 'Error: ', $self->cfg->src, ': not a build config file.';
+      return;
+    }
+
+  } else {
+    return;
+  }
+
+  my %cfg_label = %{ $self->config->setting ('CFG_LABEL') };
+  my %tools     = %{ $self->config->setting ('TOOL') };
+
+  # Get lines from cfg file
+  my @cfg_lines  = $self->cfg->lines;
+
+  LINE: for my $line (@cfg_lines) {
+    # Label and value of each line
+    my $label = $line->{LABEL};
+    my $value = $line->{VALUE};
+
+    next LINE unless $label; # ignore blank or comment line
+
+    # Strip out BLD prefix from all labels
+    my $prefix = $cfg_label{BDECLARE} . '::';
+    $label = substr ($label, length ($prefix))
+      if index (uc ($label), $prefix) == 0;
+
+    next LINE unless $label; # ignore blank or comment line
+
+    # Configuration file type/version, ignore
+    next LINE if uc $label eq $cfg_label{CFGFILE}{TYPE};
+    next LINE if uc $label eq $cfg_label{CFGFILE}{VERSION};
+
+    # User variable, ignore
+    next LINE if index (uc ($label), '%') == 0;
+
+    # Build name
+    if (uc $label eq $cfg_label{NAME}) {
+      $self->{NAME} = $value;
+      next LINE;
+    }
+
+    # Build directory tree
+    $prefix = $cfg_label{DIR} . '::';
+    if (index (uc ($label), $prefix) == 0) {
+      my $name = substr uc ($label), length ($prefix);
+      $self->{DIR}{$name} = expand_tilde $value;
+      next LINE;
+    }
+
+    # Source directory
+    $prefix = $cfg_label{SRCDIR} . '::';
+    if (index (uc ($label), $prefix) == 0) {
+      my $name = substr $label, length ($prefix);
+      $name    =~ s/::/__/g;
+      $self->{SRCDIR}{$name} = expand_tilde $value;
+      next LINE;
+    }
+
+    # Automatic source directory search?
+    if (uc $label eq $cfg_label{SEARCH_SRC}) {
+      $self->{SEARCH} = $value;
+      next LINE;
+    }
+
+    # Pre-process flag, directory/file requires pre-processing before all tasks
+    $prefix = $cfg_label{PP};
+    if (index (uc ($label), $prefix) == 0) {
+      my @flds = split /::/, $label;
+      my $name = uc shift @flds;
+      $name    = join '__', ($name, @flds) if @flds;
+      $self->{PP}{$name} = $value;
+      next LINE;
+    }
+
+    # Specify name of top level or package library
+    $prefix = $cfg_label{LIB};
+    if (index (uc ($label), $prefix) == 0) {
+      my @flds = split /::/, $label;
+      shift @flds;
+      my $name = @flds ? join ('__', @flds) : '';
+      $self->{LIB}{$name} = $value;
+
+      next LINE;
+    }
+
+    # Specify extra executable dependencies and BLOCKDATA dependency
+    for my $name (qw/EXE_DEP BLOCKDATA/) {
+      $prefix = $cfg_label{$name};
+
+      if (index (uc ($label), $prefix) == 0) {
+        my @flds = split /::/, $label;
+        shift @flds;
+        my $target = @flds ? $flds[0] : '';
+        my @deps   = split /\s+/, $value;
+
+        # If $value is a null string, set executable to depend on all objects
+        if (not @deps) {
+          if ($name eq 'BLOCKDATA') {
+
+            # Label not recognised
+            w_report 'Warning: ', $line->{SRC}, ': LINE ', $line->{NUMBER},
+                     ': "', $label, '" declaration must have a value';
+            next LINE;
+
+          } else {
+            push @deps, '';
+          }
+        }
+
+        for my $dep (@deps) {
+          $dep =~ s/::/__/g;
+
+          $self->config->assign_setting (
+            LABELS => [$name, $target, $dep],
+            VALUE  => 1,
+          );
+        }
+
+        next LINE;
+      }
+    }
+
+    # Build target
+    if (uc $label eq $cfg_label{TARGET}) {
+      push @{ $self->{TARGET} }, split (/\s+/, $value);
+      next LINE;
+    }
+
+    # Rename a main program target
+    $prefix = $cfg_label{EXE_NAME};
+    if (index (uc ($label), $prefix) == 0) {
+      my @flds = split /::/, $label;
+      shift @flds;
+      my $name = shift @flds;
+
+      if ($name and $value) {
+        $self->config->assign_setting (
+          LABELS => ['EXE_NAME', $name],
+          VALUE  => $value,
+        );
+
+        next LINE;
+      }
+    }
+
+    # Build tool
+    $prefix = $cfg_label{TOOL} . '::';
+    if (index (uc ($label), $prefix) == 0) {
+      my $name = substr $label, length ($prefix);
+      my @flds = split /::/, $name;
+
+      $name = uc (shift @flds);
+
+      if (exists $tools{$name}) {
+        $name = join '__', ($name, @flds) if @flds;
+
+        $self->config->assign_setting (
+          LABELS => ['TOOL', $name],
+          VALUE  => $value,
+        );
+        next LINE;
+      }
+    }
+
+    # File name extension and type
+    for my $name (qw/INFILE_EXT OUTFILE_EXT/) {
+      $prefix = $cfg_label{$name};
+      if (index (uc ($label), $prefix) == 0) {
+        my $key = (split /::/, $label)[1];
+        $key    = uc $key if $name eq 'OUTFILE_EXT';
+
+        my $val = ($name eq 'INFILE_EXT') ? uc $value : $value;
+
+        $self->config->assign_setting (
+          LABELS => [$name, $key],
+          VALUE  => $val,
+        );
+        next LINE;
+      }
+    }
+
+    # Dependency scan exclusion
+    $prefix = $cfg_label{EXCL_DEP};
+    if (index (uc ($label), $prefix) == 0) {
+      my @flds = split /::/, $label;
+      shift @flds;
+
+      my $pk = @flds ? join ('__', @flds) : '';
+      $self->config->assign_setting (
+        LABELS => ['EXCL_DEP', uc ($value), $pk],
+        VALUE  => 1,
+      );
+      next LINE;
+    }
+
+    # Use (inherit from) another build
+    if (uc $label eq $cfg_label{USE}) {
+      my $use = Fcm::Build->new (
+        CONFIG  => $self->config,
+        CFG_SRC => expand_tilde ($value),
+      );
+      $use->decipher_cfg;
+      $use->check_dir;
+      push @{ $self->{USE} }, $use;
+      next LINE;
+    }
+
+    # Inheritance flag
+    $prefix = $cfg_label{INHERIT} . '::';
+    if (index (uc ($label), $prefix) == 0) {
+      my $name = substr $label, length ($prefix);
+      my @flds = split /::/, $name;
+
+      $name = uc (shift @flds);
+
+      for my $flag (qw/SRCDIR PP LIB TARGET/) {
+        if ($name eq $cfg_label{$flag}) {
+          $name = @flds ? join ('__', ($flag, @flds)) : $flag;
+          $self->{INHERIT}{$name} = $value;
+          next LINE;
+        }
+      }
+    }
+
+    # Label not recognised
+    w_report 'ERROR: ', $line->{SRC}, ': LINE ', $line->{NUMBER}, ': label "',
+             $label, '" not recognised';
+    return;
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $bld->check_dir ();
+#
+# DESCRIPTION
+#   This method checks whether the build directories are set correctly.
+# ------------------------------------------------------------------------------
+
+sub check_dir {
+  my $self = shift;
+
+  # Make sure build root directory is set
+  if (not $self->{DIR}{ROOT}) {
+    w_report 'Error: build root directory not set.';
+    return;
+  }
+
+  # Set value of build sub-directories if necessary
+  for my $name (keys %{ $self->config->setting ('DIR') }) {
+    next if $self->{DIR}{$name};
+
+    $self->{DIR}{$name} = catfile (
+      $self->{DIR}{ROOT},
+      $self->config->setting ('DIR', $name),
+    );
+  }
+
+  # Search src/ sub-directory if necessary
+  if ($self->{SEARCH} and -d $self->{DIR}{SRC}) {
+    my %dir = find_srcdir ($self->{DIR}{SRC});
+    for my $name (keys %dir) {
+      $self->{SRCDIR}{$name} = $dir{$name} unless $self->{SRCDIR}{$name};
+    }
+  }
+
+  # Expand source directory paths if necessary
+  for my $name (keys %{ $self->{SRCDIR} }) {
+    if ($self->{SRCDIR}{$name} =~ /^\w/) {
+      my $src_search  = catfile $self->{DIR}{SRC} , $self->{SRCDIR}{$name};
+      my $root_search = catfile $self->{DIR}{ROOT}, $self->{SRCDIR}{$name};
+
+      if ($self->{DIR}{SRC} and -d $src_search) {
+        $self->{SRCDIR}{$name} = $src_search;
+
+      } elsif (-d $root_search) {
+        $self->{SRCDIR}{$name} = $root_search;
+
+      } else {
+        w_report 'Warning: cannot locate declared source directory: ',
+                 $self->{SRCDIR}{$name};
+        next;
+      }
+    }
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $bld->check_lock ();
+#
+# DESCRIPTION
+#   This method checks whether a lock is set in the current build.
+# ------------------------------------------------------------------------------
+
+sub check_lock {
+  my $self = shift;
+
+  my $rootdir  = $self->{DIR}{ROOT};
+  my $lock_ext = catfile ($rootdir, $self->config->setting (qw/MISC LOCK_EXT/));
+  my $lock_bld = catfile ($rootdir, $self->config->setting (qw/MISC LOCK_BLD/));
+
+  # Always throw error if extract lock exists
+  if (-e $lock_ext) {
+    w_report 'ERROR: extract lock file exists: ', $lock_ext, ',';
+    w_report '       an extract may be running at ', $rootdir, ', abort.';
+    return;
+  }
+
+  # Always throw error if build lock exists
+  if (-e $lock_bld) {
+    w_report 'ERROR: build lock file exists: ', $lock_bld, ',';
+    w_report '       a build may be running at ', $rootdir, ', abort.';
+    return;
+  }
+
+  # Check locks in inherited build
+  for my $use (@{ $self->{USE} }) {
+    return unless $use->check_lock;
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_set_lock ();
+#
+# DESCRIPTION
+#   This method sets a lock is set in the current build.
+# ------------------------------------------------------------------------------
+
+sub _set_lock {
+  my $self = shift;
+
+  $self->{LOCK} = catfile (
+    $self->{DIR}{ROOT}, $self->config->setting (qw/MISC LOCK_BLD/),
+  );
+
+  &touch_file ($self->{LOCK});
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_setup_dir (FULL => $full);
+#
+# DESCRIPTION
+#   This internal method sets up the build directories.
+# ------------------------------------------------------------------------------
+
+sub _setup_dir {
+  my $self = shift;
+  my %args = @_;
+
+  my $full = exists $args{FULL} ? $args{FULL} : 0;
+
+  my $tar      = $self->config->setting (qw/OUTFILE_EXT TAR/);
+  my @tar_dirs = split /,/, $self->config->setting (qw/TAR_DIRS/);
+  my $verbose  = $self->config->verbose;
+
+  if ($full) {
+    # Remove sub-directories/archives created from previous builds
+    for my $name (qw/BIN BLD DONE ETC FLAGS INC LIB PPSRC OBJ TMP/) {
+      &run_command ([qw/rm -rf/, $self->{DIR}{$name}], PRINT => $verbose)
+        if -d $self->{DIR}{$name};
+
+      &run_command ([qw/rm -f/, $self->{DIR}{$name} . $tar], PRINT => $verbose)
+        if -f $self->{DIR}{$name} . $tar;
+    }
+
+    # Remove cache
+    my @files;
+    if (-d $self->{DIR}{CACHE} and opendir DIR, $self->{DIR}{CACHE}) {
+      @files = grep {$_ ne '.' and $_ ne '..'} readdir 'DIR';
+      closedir DIR;
+    }
+
+    my $extension = '\\' . $self->config->setting (qw/CACHE PCKFILE/) . '|' .
+                    '\\' . $self->config->setting (qw/CACHE PCKPPDEPEND/) . '|' .
+                    '\\' . $self->config->setting (qw/CACHE PCKDEPEND/);
+
+
+    for my $file (@files) {
+      next unless $file eq $self->config->setting (qw/CACHE BLDTOOL/) or
+                  $file eq $self->config->setting (qw/CACHE PPOPTION/) or
+                  $file eq $self->config->setting (qw/CACHE EXE_DEP/) or
+                  $file =~ /$extension$/;
+
+      my $path = File::Spec->catfile ($self->{DIR}{CACHE}, $file);
+      &run_command ([qw/rm -f/, $path], PRINT => $verbose);
+    }
+
+  } else {
+    # Extract archives if necessary
+    for my $name (@tar_dirs) {
+      my $tar_file = $self->{DIR}{$name} . $tar;
+
+      if (-f $tar_file) {
+        &run_command ([qw/tar -x -f/, $tar_file], PRINT => $verbose > 1);
+        &run_command ([qw/rm -f/, $tar_file], PRINT => $verbose > 1);
+      }
+    }
+  }
+
+  # Set up search paths
+  for my $name (keys %{ $self->{DIR} }) {
+    $self->{PATH}{$name} = [$self->_get_inherited_paths ($name)];
+
+    $self->config->assign_setting (
+      LABELS => ['PATH', $name],
+      VALUE  => $self->{PATH}{$name},
+    )
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_update_bld_info ();
+#
+# DESCRIPTION
+#   This internal method sets up the inheritance relationship for source
+#   directories and targets, and other configurations required by the build.
+# ------------------------------------------------------------------------------
+
+sub _update_bld_info {
+  my $self = shift;
+
+  # Set up build targets
+  $self->{TARGET} = [$self->_get_inherited_items ('TARGET')];
+
+  # Set up PP switches
+  $self->{PP} = {$self->_get_inherited_items ('PP')};
+
+  # Set up source directory packages for this build
+  my %srcdir = $self->_get_inherited_items ('SRCDIR');
+  for my $name (keys %srcdir) {
+    my $package = Fcm::SrcPackage->new (
+      CONFIG     => $self->config,
+      NAME       => $name,
+      CURRENT    => exists $self->{SRCDIR}{$name},
+      REQUIREPP  => $self->_require_pp ($name),
+      SEARCHPATH => [$self->_get_inherited_srcdirs ($name)],
+    );
+
+    $package->update_file_info ();
+
+    $self->{PACKAGE}{$name} = $package;
+  }
+
+  # Set up runtime dependency scan patterns
+  my %dep_pattern = %{ $self->config->setting ('DEP_PATTERN') };
+  for my $key (keys %dep_pattern) {
+    my $pattern = $dep_pattern{$key};
+
+    while ($pattern =~ /##([\w:]+)##/g) {
+      my $match = $1;
+      my $val   = $self->config->setting (split (/::/, $match));
+
+      last unless defined $val;
+      $val =~ s/\./\\./;
+
+      $pattern =~ s/##$match##/$val/;
+    }
+
+    $self->config->assign_setting (
+      LABELS => ['DEP_PATTERN', $key],
+      VALUE  => $pattern,
+    ) unless $pattern eq $dep_pattern{$key};
+  }
+
+  # Set up top level library name
+  {
+    $self->{LIB} = {$self->_get_inherited_items ('LIB')};
+
+    my $lib = $self->{LIB}{''};
+    $lib    = ($self->{NAME} ? $self->{NAME} : 'fcm_default') unless $lib;
+    $self->{LIB}{''} = $lib;
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_update_regen_rule_info ();
+#
+# DESCRIPTION
+#   This internal method compares the current EXE_DEP, BLOCKDATA and EXE_NAME
+#   declarations and the previous. If changed, the REGEN_MAKERULE flag will be
+#   set to true and the cache will be updated.
+# ------------------------------------------------------------------------------
+
+sub _update_regen_rule_info {
+  my $self = shift;
+
+  # Look for an extra executable dependency cache file
+  my $cachebase = $self->config->setting (qw/CACHE EXE_DEP/);
+  my $incache   = find_file_in_path $cachebase, $self->{PATH}{CACHE};
+
+  my $uptodate = 0;
+  my @inlines  = ();
+
+  # Read cache if it exists
+  if ($incache and -r $incache) {
+    my $incfg = Fcm::CfgFile->new (CONFIG => $self->config, SRC => $incache);
+    $incfg->read_cfg;
+
+    @inlines  = $incfg->lines;
+    $uptodate = 1;
+  }
+
+  # Prepare output lines
+  my $outcfg = Fcm::CfgFile->new (CONFIG => $self->config);
+  $outcfg->add_line (COMMENT => 'EXE_DEP cache');
+
+  # List of extra executable dependencies
+  my %exe_dep   = %{ $self->config->setting ('EXE_DEP') };
+  for my $target (sort keys %exe_dep) {
+    $outcfg->add_line (
+      LABEL => ($target ? 'OBJECTS__' . $target : 'OBJECTS'),
+      VALUE => join (' ', sort keys %{ $exe_dep{$target} }),
+    );
+  }
+
+  # List of BLOCKDATA dependencies
+  my %blockdata = %{ $self->config->setting ('BLOCKDATA') };
+  for my $target (sort keys %blockdata) {
+    $outcfg->add_line (
+      LABEL => ($target ? 'BLOCKDATA__' . $target : 'BLOCKDATA'),
+      VALUE => join (' ', sort keys %{ $blockdata{$target} }),
+    );
+  }
+
+  # List of EXE_NAME
+  my %exe_name = %{ $self->config->setting ('EXE_NAME') };
+  for my $target (sort keys %exe_name) {
+    $outcfg->add_line (
+      LABEL => 'EXE_NAME__' . $target,
+      VALUE => $exe_name{$target},
+    );
+  }
+
+  # Compare cache with current output
+  my @outlines = $outcfg->lines ();
+
+  $uptodate = 0 if @inlines != @outlines;
+
+  if ($uptodate) {
+    for my $i (0 .. $#outlines) {
+      next unless $inlines[$i]->{LABEL} and $outlines[$i]->{LABEL};
+
+      if ($inlines[$i]->{LABEL} ne $outlines[$i]->{LABEL} or
+          $inlines[$i]->{VALUE} ne $outlines[$i]->{VALUE}) {
+        $uptodate = 0;
+        last;
+      }
+    }
+  }
+
+  # Update cache if it is out of date
+  $outcfg->print_cfg (catfile ($self->{DIR}{CACHE}, $cachebase))
+    unless $uptodate;
+
+  # If out to date, set regenerate make rule flag to true
+  $self->config->assign_setting (
+    LABELS => [qw/REGEN_MAKERULE/],
+    VALUE  => ! $uptodate,
+  );
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_update_pp_info ();
+#
+# DESCRIPTION
+#   This internal method compares the current set of pre-processor options
+#   with that of the previous build using a "cache" file. If some
+#   pre-processor options have changed, the method updates the cache file and
+#   remove the "make" rules for the appropriate source packages.
+# ------------------------------------------------------------------------------
+
+sub _update_pp_info {
+  my $self = shift;
+
+  # Look for a PP option cache file
+  my $cachebase = $self->config->setting (qw/CACHE PPOPTION/);
+  my $incache   = find_file_in_path $cachebase, $self->{PATH}{CACHE};
+
+  my @chgpp = ();
+  my %newpp = %{ $self->{PP} };
+
+  # Read config if exists, otherwise marked all current PP flags as "changed"
+  if ($incache and -r $incache) {
+    my $cfg = Fcm::CfgFile->new (CONFIG => $self->config, SRC => $incache);
+    $cfg->read_cfg;
+
+    my @lines   = $cfg->lines;
+    my %oldpp = ();
+
+    for my $line (@lines) {
+      next unless $line->{LABEL};
+
+      $oldpp{$line->{LABEL}} = $line->{VALUE};
+    }
+
+    # Compare new and old, mark as "changed" if changed or does not exist in old
+    @chgpp = (grep {
+      exists $oldpp{$_} ? $oldpp{$_} ne $newpp{$_} : 1;
+    } keys %newpp);
+
+    # Compare old and new, mark as "changed" if not exist in new
+    push @chgpp, (grep {not exists $newpp{$_}} keys %oldpp);
+
+  } else {
+    @chgpp = keys %newpp;
+  }
+
+  if (@chgpp) {
+    for my $name (@chgpp) {
+      for my $package (values %{ $self->{PACKAGE} }) {
+        next if $package->newpp;
+
+        if (('PP__' . $package->name) =~ /^$name(?:__|$)/) {
+          $package->current (1);
+          $package->newpp   (1);
+        }
+      }
+    }
+
+    # Update the PP cache file if necessary
+    my $cfg = Fcm::CfgFile->new (CONFIG => $self->config);
+
+    for my $name (keys %newpp) {
+      $cfg->add_line (LABEL => $name, VALUE => $newpp{$name});
+    }
+    $cfg->add_line unless $cfg->lines;
+
+    $cfg->print_cfg (catfile ($self->{DIR}{CACHE}, $cachebase));
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_update_tool_info ();
+#
+# DESCRIPTION
+#   This internal method compares the current set of build tools with that of
+#   the previous build using a "cache" file. If some build tools have changed,
+#   the method updates the cache file and (the time stamps of) dummy "flags"
+#   files to denote changes in build tools from the previous build.
+# ------------------------------------------------------------------------------
+
+sub _update_tool_info {
+  my $self = shift;
+
+  # Look for a build tool cache file
+  my $cachebase = $self->config->setting (qw/CACHE BLDTOOL/);
+  my $incache   = find_file_in_path $cachebase, $self->{PATH}{CACHE};
+
+  my @chgtool = ();
+  my %newtool = %{ $self->config->setting ('TOOL') };
+
+  # Read config if exists, otherwise marked all current tools as "changed"
+  if ($incache and -r $incache) {
+    my $cfg = Fcm::CfgFile->new (CONFIG => $self->config, SRC => $incache);
+    $cfg->read_cfg;
+
+    my @lines   = $cfg->lines;
+    my %oldtool = ();
+
+    for my $line (@lines) {
+      next unless $line->{LABEL};
+
+      $oldtool{$line->{LABEL}} = $line->{VALUE};
+    }
+
+    # Compare new and old, mark as "changed" if changed or does not exist in old
+    @chgtool = (grep {
+      exists $oldtool{$_} ? $oldtool{$_} ne $newtool{$_} : 1;
+    } keys %newtool);
+
+    # Compare old and new, mark as "changed" if not exist in new
+    push @chgtool, (grep {not exists $newtool{$_}} keys %oldtool);
+
+  } else {
+    @chgtool = keys %newtool;
+  }
+
+  if (@chgtool) {
+    # Update the time stamps of dummy files for changed tools
+    $self->_create_build_dir ('FLAGS');
+
+    my $ext = $self->config->setting (qw/OUTFILE_EXT FLAGS/);
+    for my $name (@chgtool) {
+      my $file = catfile $self->{DIR}{FLAGS}, $name . $ext;
+
+      # Create/touch the file
+      touch_file $file or croak 'Unable to update: ', $file, ', abort';
+
+      print 'Updated: ', $file, "\n" if $self->config->verbose > 2;
+    }
+
+    # Update the build tool cache file if necessary
+    my $cfg = Fcm::CfgFile->new (CONFIG => $self->config);
+
+    for my $name (keys %newtool) {
+      $cfg->add_line (LABEL => $name, VALUE => $newtool{$name});
+    }
+
+    $cfg->print_cfg (catfile ($self->{PATH}{CACHE}->[0], $cachebase));
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_pre_process ();
+#
+# DESCRIPTION
+#   This internal method obtains a list of source files that require
+#   pre-processing in the source packages of this build, and attempts to
+#   pre-process them. The method returns 1 on success.
+# ------------------------------------------------------------------------------
+
+sub _pre_process {
+  my $self = shift;
+
+  # Go through source packages/files to see if PP is required
+  my @srcfiles = ();
+  for my $package (values %{ $self->{PACKAGE} }) {
+    next unless $package->requirepp;
+
+    $package->scan_dependency (HEADER_ONLY => 1);
+
+    push @srcfiles, grep ({$_->is_type_or (qw/FPP C/)} $package->srcfile);
+  }
+
+  return 1 unless @srcfiles;
+
+  my %task     = ();
+  my $flagsext = $self->config->setting (qw/OUTFILE_EXT FLAGS/);
+  my $pdoneext = $self->config->setting (qw/OUTFILE_EXT PDONE/);
+
+  # Set up tasks for each source file
+  for my $srcfile (@srcfiles) {
+    my $command  = $srcfile->is_type ('FPP') ? 'FPP' : 'CPP';
+    my @pck_list = $srcfile->get_package_list;
+    my @pknames  = split '__', pop (@pck_list);
+
+    # Set up a PP build task for each source file
+    my $target    = $srcfile->base . $pdoneext;
+    my $ppkeyname = join ('__', ($command . 'KEYS' , @pknames)) . $flagsext;
+    my $flagsname = join ('__', ($command . 'FLAGS', @pknames)) . $flagsext;
+
+    # Issue warning for duplicated tasks
+    if (exists $task{$target}) {
+      w_report 'Warning: ', $target, ': unable to create task for: ',
+               $srcfile->src, ': task already exists for: ',
+               $task{$target}->srcfile->src;
+      next;
+    }
+
+    $task{$target} = Fcm::BuildTask->new (
+      CONFIG     => $self->config,
+      TARGET     => $target,
+      TARGETPATH => $self->{PATH}{DONE},
+      SRCFILE    => $srcfile,
+      DEPENDENCY => [$ppkeyname, $flagsname, ($srcfile->dep ('H'))],
+      ACTIONTYPE => 'PP',
+    );
+
+    # Set up update ppkeys/flags build tasks for each source file/package
+    for my $i (0 .. $#pknames) {
+      my $name  = join '__', @pknames [0 .. $i];     # package name
+      my $dname = join '__', @pknames [0 .. $i - 1]; # dependent package name
+
+      for my $flag (qw/KEYS FLAGS/) {
+        my $fullflag = $command . $flag;
+        my $target   = join '__', ($fullflag, $name);
+        my $depend   = $dname ? join '__', ($fullflag, $dname) : $fullflag;
+
+        $target .= $flagsext;
+        $depend .= $flagsext;
+
+        next if exists $task{$target};
+
+        $task{$target} = Fcm::BuildTask->new (
+          CONFIG     => $self->config,
+          TARGET     => $target,
+          TARGETPATH => $self->{PATH}{FLAGS},
+          DEPENDENCY => [$depend],
+          ACTIONTYPE => 'UPDATE',
+        );
+      }
+    }
+  }
+
+  # Set up update global ppkeys/flags build tasks
+  for my $command (qw/CPP FPP/) {
+    for my $flag ('', qw/KEYS FLAGS/) {
+      my $target = $command . $flag . $flagsext;
+
+      $task{$target} = Fcm::BuildTask->new (
+        CONFIG     => $self->config,
+        TARGET     => $target,
+        TARGETPATH => $self->{PATH}{FLAGS},
+        ACTIONTYPE => 'UPDATE',
+      );
+    }
+  }
+
+  # Set up build tasks to copy all header files
+  for my $package (values %{ $self->{PACKAGE} }) {
+    my @files = grep {$_->is_type (qw/CPP INCLUDE/)} $package->srcfile;
+
+    # Author's note: may also want to issue warning for duplicated tasks
+
+    for my $file (@files) {
+      $task{$file->base} = Fcm::BuildTask->new (
+        CONFIG     => $self->config,
+        TARGET     => $file->base,
+        TARGETPATH => $self->{PATH}{INC},
+        SRCFILE    => $file,
+        DEPENDENCY => [$file->dep ('H')],
+        ACTIONTYPE => 'COPY',
+      );
+    }
+  }
+
+  # Build all PP tasks
+  my $count = 0;
+
+  for my $task (values %task) {
+    next unless $task->actiontype eq 'PP';
+
+    my $rc = $task->action (TASKLIST => \%task);
+    $count++ if $rc;
+  }
+
+  print 'Number of pre-processed files: ', $count, "\n"
+    if $self->config->verbose and $count;
+
+  # Change path and file type of pre-processed source files
+  for my $task (values %task) {
+    next unless $task->actiontype eq 'PP';
+
+    # Remove header dependencies from source file
+    my %dep = $task->srcfile->dep ();
+    for my $key (keys %dep) {
+      delete $dep{$key} if $dep{$key} eq 'H';
+    }
+    $task->srcfile->dep (\%dep);
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_generate_f9x_interface ();
+#
+# DESCRIPTION
+#   This internal method obtains a list of Fortran 9X source files in the
+#   source packages of this build, and attempts to generate an interface block
+#   file for each of the Fortran 9X source files. The method returns 1 on
+#   success.
+# ------------------------------------------------------------------------------
+
+sub _generate_f9x_interface {
+  my $self = shift;
+
+  # Go through source packages/files for Fortran 9x source files with
+  # standalone subroutines or functions
+  my @srcfiles = ();
+  for my $package (values %{ $self->{PACKAGE} }) {
+    next unless $package->current;
+
+    push @srcfiles, grep {
+      $_->is_type_or (qw/FORTRAN9X FPP9X/) and
+      uc ($_->select_tool ('GENINTERFACE')) ne 'NONE' and
+      not $_->is_type_or (qw/PROGRAM MODULE INCLUDE/)
+    } $package->srcfile;
+  }
+
+  my $flagsext = $self->config->setting (qw/OUTFILE_EXT FLAGS/);
+  my $pdoneext = $self->config->setting (qw/OUTFILE_EXT PDONE/);
+
+  # Set up build task to generate interface files for all selected Fortran 9x
+  # sources
+  my %task         = ();
+  for my $srcfile (@srcfiles) {
+    my $target  = $srcfile->interfacebase . $pdoneext;
+    my @pknames = split '__', ($srcfile->get_package_list)[-1];
+    my $flag    = join ('__', ('GENINTERFACE', @pknames)) . $flagsext;
+
+    $task{$target} = Fcm::BuildTask->new (
+      CONFIG     => $self->config,
+      TARGET     => $target,
+      TARGETPATH => $self->{PATH}{DONE},
+      SRCFILE    => $srcfile,
+      DEPENDENCY => [$flag],
+      ACTIONTYPE => 'GENINTERFACE',
+    );
+
+    # Set up build tasks for each source file/package flags file for interface
+    # generator tool
+    for my $i (0 .. $#pknames) {
+      my $name   = join '__', @pknames [0 .. $i];     # package name
+      my $dname  = join '__', @pknames [0 .. $i - 1]; # dependent package name
+
+      my $target = join '__', ('GENINTERFACE', $name);
+      my $depend = $dname ? join '__', ('GENINTERFACE', $dname) : 'GENINTERFACE';
+
+      $target .= $flagsext;
+      $depend .= $flagsext;
+
+      next if exists $task{$target};
+
+      $task{$target} = Fcm::BuildTask->new (
+        CONFIG     => $self->config,
+        TARGET     => $target,
+        TARGETPATH => $self->{PATH}{FLAGS},
+        DEPENDENCY => [$depend],
+        ACTIONTYPE => 'UPDATE',
+      );
+    }
+  }
+
+  # Set up build task to update the flags file for interface generator tool
+  {
+    my $target     = 'GENINTERFACE' . $flagsext;
+    $task{$target} = Fcm::BuildTask->new (
+      CONFIG     => $self->config,
+      TARGET     => $target,
+      TARGETPATH => $self->{PATH}{FLAGS},
+      ACTIONTYPE => 'UPDATE',
+    );
+  }
+
+  my $count = 0;
+
+  # Performs task
+  for my $task (values %task) {
+    next unless $task->actiontype eq 'GENINTERFACE';
+
+    my $rc = $task->action (TASKLIST => \%task);
+    $count++ if $rc;
+  }
+
+  print 'Number of generated interfaces: ', $count, "\n"
+    if $self->config->verbose and $count;
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_scan_dependency ();
+#
+# DESCRIPTION
+#   This internal method goes through each source package to obtain dependency
+#   information from their source files. It returns 1 on success.
+# ------------------------------------------------------------------------------
+
+sub _scan_dependency {
+  my $self = shift;
+
+  # Go through source packages/files
+  my $count = 0;
+
+  for my $package (values %{ $self->{PACKAGE} }) {
+    my $rc = $package->scan_dependency;
+    $count++ if $rc;
+  }
+
+  print 'Scanned files in ', $count, ' package(s) for dependency', "\n"
+    if $self->config->verbose and $count;
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_set_targets ();
+#
+# DESCRIPTION
+#   This internal method determines the default targets to be built.
+# ------------------------------------------------------------------------------
+
+sub _set_targets {
+  my $self = shift;
+
+  # Targets of the build
+  if (not @{ $self->{TARGET} }) {
+    # Build targets not specified by user, default to building all main programs
+    my @programs = ();
+
+    # Get all main programs from all packages
+    for my $package (values %{ $self->{PACKAGE} }) {
+      my @srcfiles = grep {$_->exebase} $package->srcfile;
+
+      for (@srcfiles) {
+        push @programs, $_->exebase;
+      }
+    }
+
+    @programs = sort (@programs);
+
+    if (@programs) {
+      # Build main programs, if there are any
+      @{ $self->{TARGET} } = @programs;
+
+    } else {
+      # No main program in source tree, build the default library
+      @{ $self->{TARGET} } = (
+        'lib' . $self->{LIB}{''} . $self->config->setting (qw/OUTFILE_EXT LIB/),
+      );
+    }
+  }
+
+  return @{ $self->{TARGET} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_write_make_rules ();
+#
+# DESCRIPTION
+#   This internal method writes the included make rules if necessary.
+# ------------------------------------------------------------------------------
+
+sub _write_make_rules {
+  my $self   = shift;
+  my $return = 1;
+
+  # Get list of all packages
+  my %allpcks = $self->allpcks;
+
+  # Get list of types that cannot have duplicated targets
+  my @no_duplicated_target_types = split (
+    /,/, $self->config->setting ('NO_DUPLICATED_TARGET_TYPE'),
+  );
+
+  my $unusual = 0;
+  my $count   = 0;
+  my %targets;
+  for my $name (sort keys %allpcks) {
+    # Check whether package is an actual package of the build
+    my $package  = exists $self->{PACKAGE}{$name} ? $self->{PACKAGE}{$name} : '';
+
+    # Regenerate make rules if this flag is set to true
+    my $regen_mk;
+
+    # Register non-word package name
+    if (not $name =~ /^\w*$/) {
+      $self->config->assign_setting (
+        LABELS => ['FCM_PCK_OBJECTS', $name],
+        VALUE  => 'FCM_PCK_OBJECTS' . $unusual++,
+      );
+
+      # Set regenerate make rule flag to true
+      $regen_mk = 1;
+    }
+
+    # Cycle loop if not an actual package of the build
+    next unless $package;
+
+    # Check whether make rule for each source package needs updating. Yes if:
+    # 1. package name contains non-word characters
+    # 2. the config setting REGEN_MAKERULE is set to true
+    # 3. package is current and the make rule for the package is out of date
+    $regen_mk = (
+      $regen_mk or
+      $self->config->setting ('REGEN_MAKERULE') or
+      ($package->current and not $package->makerule_uptodate)
+    );
+
+    # Update make rule for source package, if necessary
+    $count += $package->write_makerule () if $regen_mk;
+
+    # Check for duplicated rules
+    for my $srcfile (sort $package->srcfile) {
+      next unless $srcfile->type;
+
+      my %rules = $srcfile->required_rules;
+
+      for my $key (sort keys %rules) {
+        if (exists $targets{$key}) {
+          # Duplicated target: warning for most file types
+          my $status = 'WARNING';
+
+          # Duplicated target: error for the following file types
+          if (@no_duplicated_target_types and
+              $srcfile->is_type_or (@no_duplicated_target_types) and
+              $targets{$key}->is_type_or (@no_duplicated_target_types)) {
+            $status = 'ERROR';
+            $return = 0;
+          }
+
+          # Report the warning/error
+          w_report $status, ': ', $key, ': duplicated targets for building:';
+          w_report '       ', $targets{$key}->src;
+          w_report '       ', $srcfile->src;
+
+        } else {
+          $targets{$key} = $srcfile;
+        }
+      }
+    }
+  }
+
+  # Diagnostic
+  print 'Updated make rules for ', $count, ' package(s).', "\n"
+    if $count and $self->config->verbose;
+
+  return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_write_makefile ();
+#
+# DESCRIPTION
+#   This internal method writes the "Makefile" for this build.
+# ------------------------------------------------------------------------------
+
+sub _write_makefile {
+  my $self = shift;
+
+  # Makefile header
+  # ----------------------------------------------------------------------------
+  my $makefile = '# Automatic Makefile' . "\n\n";
+
+  # Name of the build
+  $makefile .= 'FCM_BUILD_NAME = ' . $self->{NAME} . "\n" if $self->{NAME};
+  
+  # Location of FCM config file
+  $makefile .= 'FCM_BLD_CFG = ' . $self->cfg->src . "\n";
+
+  # Targets of the build
+  $makefile .= 'FCM_BLD_TARGETS = ' . join (' ', ($self->_set_targets)) . "\n\n";
+
+  # Perl library
+  # ----------------------------------------------------------------------------
+  {
+    my $libdir  = dirname (dirname ($INC{'Fcm/Build.pm'}));
+    my @libpath = split /:/, ($ENV{PERL5LIB} ? $ENV{PERL5LIB} : '');
+
+    if (not grep (m/$libdir/, @libpath)) {
+      $makefile .= 'export PERL5LIB := ' . $libdir;
+      $makefile .= ':$(PERL5LIB)' if exists $ENV{PERL5LIB};
+      $makefile .= "\n\n";
+    }
+  }
+
+  # Build directories
+  # ----------------------------------------------------------------------------
+  my @keys    = ('ROOT', sort grep {$_ ne 'ROOT'} keys (%{ $self->{DIR} }));
+  my $rootdir = $self->{DIR}{ROOT};
+
+  # Build sub-directories
+  for my $name (@keys) {
+    my $dir = $self->{DIR}{$name};
+    $dir    =~ s/^$rootdir/\$(FCM_ROOTDIR)/ unless $name eq 'ROOT';
+
+    $makefile .= 'export FCM_' . $name . 'DIR = ' . $dir . "\n";
+  }
+
+  $makefile .= "\n";
+
+  # Build sub-directory paths
+  for my $name (@keys) {
+    my @path = @{ $self->{PATH}{$name} };
+    shift @path;
+
+    $makefile .= 'export FCM_' . $name . 'PATH = ' .
+                 join (':', ('$(FCM_' . $name . 'DIR)', @path)) . "\n";
+  }
+
+  $makefile .= "\n";
+
+  # Build tools
+  # ----------------------------------------------------------------------------
+  # List of build tools
+  my $tool          = $self->config->setting ('TOOL');
+
+  # List of tools local to FCM, (will not be exported)
+  my %localtool     = map {($_, 1)} split (    # map into a hash table
+    /,/, $self->config->setting ('LOCALTOOL'), # split comma separated list
+  );
+
+  # Export required tools
+  my $unusual_count = 0;
+  for my $name (sort keys %$tool) {
+    # Ignore local tools
+    my $topname = (split (/__/, $name))[0];
+    next if exists $localtool{$topname};
+
+    if ($name =~ /^\w+$/) {
+      # Tools with normal name, just export it as an environment variable
+      $makefile .= 'export ' . $name . ' = ' . $tool->{$name} . "\n";
+
+    } else {
+      # Tools with unusual characters, export using a label/value pair
+      $makefile .= 'export FCM_UNUSUAL_TOOL_LABEL' . $unusual_count . ' = ' .
+                   $name . "\n";
+      $makefile .= 'export FCM_UNUSUAL_TOOL_VALUE' . $unusual_count . ' = ' .
+                   $tool->{$name} . "\n";
+      $unusual_count++;
+    }
+  }
+
+  $makefile .= "\n";
+
+  # Verbose mode
+  # ----------------------------------------------------------------------------
+  $makefile .= 'export FCM_VERBOSE ?= ' . $self->config->verbose . "\n\n";
+
+  # VPATH
+  # ----------------------------------------------------------------------------
+  # $name is internal name of build sub-directories
+  # $type is the type of files
+  for my $name (sort keys %{ $self->config->setting ('VPATH') }) {
+    my @types = split /,/, $self->config->setting ('VPATH', $name);
+
+    for my $type (sort @types) {
+      # If $type is EMPTY, it is a file with no file name extension
+      if (uc ($type) eq 'EMPTY') {
+        $makefile .= 'vpath % $(FCM_' . $name . 'PATH)' . "\n";
+
+      } elsif ($type =~ s/^(in|out)://i) {
+        if (uc ($1) eq 'IN') {
+          # If $type begins with IN:<type>, it is a list of file extensions that
+          # can be found under the INFILE_EXT hash in the configuration setting,
+          # with <type> matching a keyword in the values of the hash.
+          my %infile_ext = %{ $self->config->setting ('INFILE_EXT') };
+
+          for my $ext (sort keys %infile_ext) {
+            $makefile .= 'vpath %.' . $ext . ' $(FCM_' . $name . 'PATH)' . "\n"
+              if grep {$_ eq $type} split /::/, $infile_ext{$ext};
+          }
+
+        } else {
+          # If $type begins with OUT:<type>, it is the value of a hash element
+          # in the OUTFILE_EXT hash in the configuration setting, with <type>
+          # matching the key.
+          my $ext    = $self->config->setting ('OUTFILE_EXT', $type);
+          $makefile .= 'vpath %' . $ext . ' $(FCM_' . $name . 'PATH)' . "\n";
+        }
+
+      } else {
+        # Otherwise, $type is a VPATH pattern recognised by "make".
+        $makefile .= 'vpath ' . $type . ' $(FCM_' . $name . 'PATH)' . "\n";
+      }
+    }
+  }
+
+  # VPATH for dummy files
+  $makefile .= 'vpath %.dummy $(FCM_DONEDIR)' . "\n";
+  $makefile .= "\n";
+
+  # Default targets
+  # ----------------------------------------------------------------------------
+  $makefile .= '.PHONY : all clean' . "\n\n";
+  $makefile .= 'all : $(FCM_BLD_TARGETS)' . "\n\n";
+  $makefile .= 'clean : ' . "\n";
+  $makefile .= "\t" . 'rm -rf';
+  for my $dir (qw/BIN LIB OBJ DONE/) {
+    $makefile .= ' $(FCM_' . $dir . 'DIR)' if exists $self->{DIR}{$dir};
+  }
+  $makefile .= "\n";
+  $makefile .= "\t" . 'rm -f lib__*' .
+               $self->config->setting (qw/OUTFILE_EXT LIB/) .
+               ' *' . $self->config->setting (qw/OUTFILE_EXT OBJ/) . "\n";
+  $makefile .= "\n";
+
+  # Targets for copy dummy
+  $makefile .= $self->config->setting (qw/MISC CPDUMMY/) . ' :' . "\n";
+  $makefile .= "\t" . 'touch $@' . "\n\n";
+
+  # Targets for all (non-main-program) objects and libraries
+  # ----------------------------------------------------------------------------
+  my %allpcks = $self->allpcks;
+  for my $key (reverse sort keys %allpcks) {
+    # Objects variable
+    my $var;
+    if ($self->config->setting ('FCM_PCK_OBJECTS', $key)) {
+      # Package name contains unusual characters, use predefined variable
+      $var = $self->config->setting ('FCM_PCK_OBJECTS', $key);
+
+    } else {
+      # Normal package name, prefix the package name with "OBJECTS__"
+      # Top level package, simply set to "OBJECTS"
+      $var = $key ? join ('__', ('OBJECTS', $key)) : 'OBJECTS';
+    }
+
+    # Export top level OBJECTS variable
+    # but keep sub-package OBJECTS variables local to the Makefile
+    $makefile .= ($var eq 'OBJECTS' ? 'export ' : '') . $var . ' =';
+
+    # Add objects from children
+    if (@{ $allpcks{$key} }) {
+      # List of sub-packages of current package
+      my @deps   = map {
+        if ($self->config->setting ('FCM_PCK_OBJECTS', $_)) {
+          # Package name contains unusual characters, use predefined variable
+          '$(' . $self->config->setting ('FCM_PCK_OBJECTS', $_) . ')';
+
+        } else {
+          # Normal package name, prefix the package name with "OBJECTS__"
+          '$(OBJECTS__' . $_ . ')';
+        }
+      } @{ $allpcks{$key} };
+
+      $makefile .= ' ' . join (' ', sort @deps);
+    }
+
+    # Add its own objects
+    if (exists $self->{PACKAGE}{$key}) {
+      # List of source files in the current package
+      my @files = sort {$a->base cmp $b->base} $self->{PACKAGE}{$key}->srcfile;
+
+      for my $file (@files) {
+        # Consider compilable source files only
+        next unless $file->objbase;
+
+        # Ignore main programs and Fortran BLOCKDATA program units
+        next if $file->is_type_or (qw/PROGRAM BLOCKDATA/);
+
+        # Add to object list
+        $makefile .= ' ' . $file->objbase;
+      }
+    }
+
+    $makefile .= "\n\n";
+
+    # Library target
+    my $lib = exists ($self->{LIB}{$key}) ? $self->{LIB}{$key} : $key;
+    $lib    = 'lib' . $lib . $self->config->setting (qw/OUTFILE_EXT LIB/);
+
+    $makefile .= $lib . ' : $(' . $var . ')' . "\n";
+    $makefile .= "\t" . 'fcm_internal archive $@ $(^F)' . "\n\n";
+  }
+
+  # Targets for top level and package flags files and dummy dependencies
+  my %src_tool   = %{ $self->config->setting ('SRC_TOOL') };
+  my %flags_tool = (LD => '', LDFLAGS => '');
+
+  for my $key (keys %src_tool) {
+    $flags_tool{$src_tool{$key}{FLAGS}} = $src_tool{$key}{COMPILER}
+      if exists $src_tool{$key}{FLAGS};
+
+    $flags_tool{$src_tool{$key}{PPKEYS}} = ''
+      if exists $src_tool{$key}{PPKEYS};
+  }
+
+  my $ext = $self->config->setting (qw/OUTFILE_EXT FLAGS/);
+  for my $name (sort keys %flags_tool) {
+    # Flags files for tool command
+    if ($flags_tool{$name}) {
+      $makefile .= $flags_tool{$name} . $ext . ' :' . "\n";
+      $makefile .= "\t" . 'touch ' . catfile ('$(FCM_FLAGSDIR)', '$@') . "\n\n";
+    }
+
+    # Top level flags files
+    $makefile .= $name . $ext . ' :';
+    $makefile .= ' ' . $flags_tool{$name} . $ext if $flags_tool{$name};
+    $makefile .= "\n\t" . 'touch ' . catfile ('$(FCM_FLAGSDIR)', '$@') . "\n\n";
+
+    # Package level flags files
+    for my $key (sort keys %allpcks) {
+      next unless @{ $allpcks{$key} }; # ignore packages without children
+
+      my $depend  = $key ? join '__', ($name, $key) : $name;
+      my @targets = sort map {$name . '__' . $_ . $ext} @{ $allpcks{$key} };
+
+      $makefile .= join (' ', @targets) . ' : ' . $depend . $ext . "\n";
+      $makefile .= "\t" . 'touch ' . catfile ('$(FCM_FLAGSDIR)', '$@') .
+                   "\n\n";
+    }
+  }
+
+  # Include source package make rules
+  # ----------------------------------------------------------------------------
+  for my $package (sort {$a->name cmp $b->name} values %{ $self->{PACKAGE} }) {
+    my $mkbase = $package->name . $self->config->setting (qw/OUTFILE_EXT MK/);
+    my $mkfile = find_file_in_path ($mkbase, $self->{PATH}{BLD});
+
+    if ($mkfile) {
+      if (index ($mkfile, $self->{DIR}{BLD}) == 0) {
+        $mkfile = catfile '$(FCM_BLDDIR)',
+                  substr ($mkfile, length ($self->{DIR}{BLD}) + 1);
+
+      } elsif (index ($mkfile, $self->{DIR}{ROOT}) == 0) {
+        $mkfile = catfile '$(FCM_ROOTDIR)',
+                  substr ($mkfile, length ($self->{DIR}{ROOT}) + 1);
+      }
+
+      $makefile .= 'include ' . $mkfile . "\n";
+
+    } else {
+      my $pck = join ('::', split (/__/, $package->name));
+      w_report 'Warning: no make rule file for source package: ', $pck;
+    }
+  }
+
+  $makefile .= "\n" . '# EOF' . "\n";
+
+  # Print Makefile
+  # ----------------------------------------------------------------------------
+  $self->_create_build_dir ('BLD');
+  my $out = catfile (
+    $self->{DIR}{BLD}, $self->config->setting (qw/MISC MAKEFILE/),
+  );
+
+  # Check whether an old file exists, if so compare current contents with it
+  my $old = '';
+
+  if (-r $out) {
+    open OLD, '<', $out or croak 'Cannot open "', $out, '" (', $!, '), abort';
+    my @lines = readline 'OLD';
+    close OLD;
+
+    $old = join ('', @lines);
+  }
+
+  # Update Makefile if changed
+  if ($old ne $makefile) {
+    open OUT, '>', $out or croak 'Cannot open "', $out, '" (', $!, '), abort';
+    print OUT $makefile;
+    close OUT or croak 'Cannot close "', $out, '" (', $!, '), abort';
+
+    print 'Updated Makefile: ', $out, "\n" if $self->config->verbose;
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_invoke_make (
+#     TARGETS => \@targets,
+#     JOBS    => $jobs,
+#     ARCHIVE => $archive,
+#   );
+#
+# DESCRIPTION
+#   This internal method invokes the "make" command to make the build.
+#
+# ARGUMENTS
+#   TARGETS - Specify targets to be built. If set, these targets will be built
+#             instead of the ones specified in the build configuration file.
+#   JOBS    - Specify number of jobs that can be handled by "make". If set,
+#             the value must be a natural integer. If not set, the default
+#             value is 1 (i.e. run "make" in serial mode).
+#   ARCHIVE - If set to "true", invoke the "archive" mode. Most build files and
+#             directories created by this build will be archived using the
+#             "tar" command. If not set, the default is not to invoke the
+#             "archive" mode.
+# ------------------------------------------------------------------------------
+
+sub _invoke_make {
+  my $self = shift;
+  my %args = @_;
+
+  # Build the make command from the specified targets
+  my @targets  = exists $args{TARGETS} ? @{ $args{TARGETS} } : qw/all/;
+  my $jobs     = exists $args{JOBS}    ? $args{JOBS}         : 1;
+  my $archive  = exists $args{ARCHIVE} ? $args{ARCHIVE}      : 0;
+  my $verbose  = $self->config->verbose;
+
+  # Create the required build directories
+  for my $dir (qw/BIN DONE ETC INC FLAGS LIB OBJ TMP/) {
+    $self->_create_build_dir ($dir);
+  }  
+
+  my @commands = ();
+  my @make_cmd = ($self->config->setting (qw/TOOL MAKE/));
+  push @make_cmd, split (/\s+/, $self->config->setting (qw/TOOL MAKEFLAGS/));
+  push @make_cmd, $self->config->setting (qw/TOOL MAKE_SILENT/)
+    unless $verbose > 2;
+
+  if ($jobs > 1) { # multi-process "make"
+    my $make_job = $self->config->setting (qw/TOOL MAKE_JOB/);
+
+    # Setup the "make" commands for each target
+    while (my $target = shift @targets) {
+      if ($target eq 'clean') { # Do not run "clean" in parallel
+        push @commands, [@make_cmd, $target];
+
+      } else {
+        push @commands, [@make_cmd, $make_job, $jobs, $target];
+      }
+    }
+
+  } else { # single process "make"
+
+    # Setup the "make" command
+    push @commands, [@make_cmd, @targets];
+
+  }
+  
+  # Run the make command
+  my $rc  = 0;
+  my $cwd = cwd;
+  print 'cd ', $self->{DIR}{BLD}, "\n" if $verbose > 2;
+  chdir $self->{DIR}{BLD};
+  while (my $cmd = shift @commands) {
+    $| = 1; # flush STDOUT before running "make"
+    print timestamp_command (&get_command_string ($cmd)) if $verbose > 2;
+    $| = 0;
+    &run_command ($cmd, ERROR => 'warn', RC => \$rc);
+    print timestamp_command (&get_command_string ($cmd), 'End') if $verbose > 2;
+    last if $rc;
+  }
+  print 'cd ', $cwd, "\n" if $verbose > 2;
+  chdir $cwd;
+
+  return $rc ? undef : 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rc = $self->_remove_empty_dirs ();
+#
+# DESCRIPTION
+#   This internal method removes empty build directories.
+# ------------------------------------------------------------------------------
+
+sub _remove_empty_dirs {
+  my $self = shift;
+
+  for my $name (qw/BIN CACHE DONE ETC FLAGS INC LIB PPSRC OBJ TMP/) {
+    opendir DIR, $self->{DIR}{$name};
+    my @files = readdir DIR;
+    @files    = grep !/^\.\.?$/, @files;
+    closedir DIR;
+
+    if (not @files) {
+      print 'Remove directory: ', $self->{DIR}{$name}, "\n"
+        if $self->config->verbose > 1;
+      rmdir $self->{DIR}{$name};
+    }
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rc = $self->_tar_build_dirs ();
+#
+# DESCRIPTION
+#   This internal method creates TAR archives for selected build directories.
+# ------------------------------------------------------------------------------
+
+sub _tar_build_dirs {
+  my $self = shift;
+
+  # Create TAR archives if necessary
+  my $cwd = cwd;
+
+  my $tar      = $self->config->setting (qw/OUTFILE_EXT TAR/);
+  my @tar_dirs = split /,/, $self->config->setting (qw/TAR_DIRS/);
+  my $verbose  = $self->config->verbose;
+
+  for my $name (@tar_dirs) {
+    my $dir = $self->{DIR}{$name};
+
+    if (-d $dir) {
+      my $base = basename ($dir);
+      print 'cd ', dirname ($dir), "\n" if $verbose > 2;
+      chdir dirname ($dir);
+
+      my $rc = &run_command (
+        [qw/tar -c -f/, $base . $tar, $base],
+        PRINT => $verbose > 1, ERROR => 'warn',
+      );
+
+      &run_command ([qw/rm -rf/, $base], PRINT => $verbose > 1) if not $rc;
+    }
+  }
+
+  print 'cd ', $cwd, "\n" if $verbose > 2;
+  chdir $cwd;
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rc = $self->_create_runenv_script ();
+#
+# DESCRIPTION
+#   This internal method creates the runtime environment script if necessary.
+# ------------------------------------------------------------------------------
+
+sub _create_runenv_script {
+  my $self = shift;
+
+  # More diagnostic on how to use the build
+  my @bin_dirs = grep {-d} @{ $self->{PATH}{BIN} };
+  my $etc_dir  = -d $self->{DIR}{ETC} ? $self->{DIR}{ETC} : undef;
+
+  if (@bin_dirs or $etc_dir) {
+    # Create a runtime environment script if necessary
+    my $run_env_sh_base = $self->config->setting (qw/MISC RUN_ENV_SH/);
+    my $run_env_sh      = catfile $self->{DIR}{ROOT}, $run_env_sh_base;
+
+    open FILE, '>', $run_env_sh
+      or croak $run_env_sh, ': cannot open (', $!, '), abort';
+    print FILE '#!/usr/bin/ksh', "\n";
+    print FILE 'export PATH=', join (':', @bin_dirs), ':$PATH', "\n"
+      if @bin_dirs;
+    print FILE 'export FCM_ETCDIR=', $self->{DIR}{ETC}, "\n" if $etc_dir;
+    close FILE or croak $run_env_sh, ': cannot close (', $!, '), abort';
+
+    # Create symbolic link in bin/ sub-directory for backward compatibility
+    if (-d $self->{DIR}{BIN}) {
+      my $file = catfile ($self->{DIR}{BIN}, $run_env_sh_base);
+      
+      # Remove old link if necessary
+      unlink $file if -l $file and readlink ($file) ne $run_env_sh;
+
+      # Create the new link
+      symlink $run_env_sh, $file if not -l $file;
+    }
+
+    # Information on the location/usage of the runtime environment script
+    if ($self->config->verbose > 1 and $run_env_sh) {
+      print '# ', '-' x 78, "\n";
+      print '# To use this build, source the following shell script:', "\n";
+      print '. ', $run_env_sh, "\n";
+      print '# ', '-' x 78, "\n";
+    }
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_create_lib_excl_dep ();
+#
+# DESCRIPTION
+#   This internal method creates a set of exclude dependency configurations for
+#   libraries of this build.
+# ------------------------------------------------------------------------------
+
+sub _create_lib_excl_dep {
+  my $self = shift;
+
+  if (-d $self->{DIR}{LIB}) {
+    $self->_create_build_dir ('ETC');
+    
+    my %allpcks  = $self->allpcks;
+    my $cfgext   = $self->config->setting (qw/OUTFILE_EXT CFG/);
+    my %cfglabel = %{ $self->config->setting ('CFG_LABEL') };
+
+    for my $key (reverse sort keys %allpcks) {
+      my $outcfg = Fcm::CfgFile->new (CONFIG => $self->config);
+
+      # Include configurations from sub-packages
+      for my $subpck (@{ $allpcks{$key} }) {
+        my $base = 'lib' . $subpck . $cfgext;
+        ($base = $self->{LIB}{$subpck}) =~ s/\.\w+$/$cfgext/
+          if exists ($self->{LIB}{$subpck});
+        my $file = catfile ('$HERE', $base);
+
+        $outcfg->add_line (LABEL => $cfglabel{INC}, VALUE => $file)
+          if -r catfile ($self->{DIR}{ETC}, $base);;
+      }
+
+      # Exclude dependency for source files in current package
+      if (exists $self->{PACKAGE}{$key}) {
+        my @srcfiles = $self->{PACKAGE}{$key}->srcfile;
+
+        for my $srcfile (@srcfiles) {
+          if ($srcfile->is_type ('INCLUDE')) {
+            if ($srcfile->is_type ('CPP')) {
+              $outcfg->add_line (
+                LABEL => $cfglabel{EXCL_DEP},
+                VALUE => 'H::' . $srcfile->base,
+              );
+
+            } elsif ($srcfile->is_type ('INTERFACE')) {
+              $outcfg->add_line (
+                LABEL => $cfglabel{EXCL_DEP},
+                VALUE => 'INTERFACE::' . $srcfile->base,
+              );
+
+            } else {
+              $outcfg->add_line (
+                LABEL => $cfglabel{EXCL_DEP},
+                VALUE => 'INC::' . $srcfile->base,
+              );
+            }
+
+          } elsif ($srcfile->is_type ('SOURCE')) {
+            next if $srcfile->is_type_or (qw/PROGRAM BLOCKDATA/);
+
+            if ($srcfile->is_type ('FORTRAN')) {
+              if ($srcfile->is_type (qw/FORTRAN MODULE/)) {
+                $outcfg->add_line (
+                  LABEL => $cfglabel{EXCL_DEP},
+                  VALUE => 'USE::' . $srcfile->root,
+                );
+
+              } else {
+                $outcfg->add_line (
+                  LABEL => $cfglabel{EXCL_DEP},
+                  VALUE => 'INTERFACE::' . $srcfile->interfacebase,
+                ) if $srcfile->interfacebase;
+
+                $outcfg->add_line (
+                  LABEL => $cfglabel{EXCL_DEP},
+                  VALUE => 'OBJ::' . $srcfile->root,
+                );
+              }
+
+            } else {
+              $outcfg->add_line (
+                LABEL => $cfglabel{EXCL_DEP},
+                VALUE => 'OBJ::' . $srcfile->root,
+              );
+            }
+          }
+        }
+      }
+
+      # Name of configuration file, follows the name of library
+      my $outbase ='lib' . $key . $cfgext;
+      ($outbase = $self->{LIB}{$key}) =~ s/\.\w+$/$cfgext/
+        if exists ($self->{LIB}{$key});
+      my $outfile = catfile ($self->{DIR}{ETC}, $outbase);
+
+      # Write to configuration file
+      $outcfg->print_cfg ($outfile);
+    }
+
+    # Information on the location/usage of the exclude dependency configurations
+    if ($self->config->verbose > 1) {
+      my $etcdir = $self->{DIR}{ETC};
+      print '# ', '-' x 78, "\n";
+      print <<EOF;
+# To use a library archive of this build in another FCM build, you need to
+# include in the new build configuration the corresponding configuration file
+# that has the relevant exclude dependency information. These configurations
+# files can be found in $etcdir.
+EOF
+      print '# ', '-' x 78, "\n";
+    }
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_create_build_dir ();
+#   $self->_create_build_dir ($label);
+#
+# DESCRIPTION
+#   This internal method creates a build directory. If $label is specified,
+#   the method will attempt to create a named sub-directory according to
+#   $label. Otherwise, the method attempts to create the build root
+#   directory. Returns the name of the directory if it is created successfully
+#   or if it already exists.
+# ------------------------------------------------------------------------------
+
+sub _create_build_dir {
+  my $self  = shift;
+  my $label = $_[0] ? uc $_[0] : 'ROOT';
+
+  my $dir = undef;
+
+  # Make sure the variable is set
+  if ($self->{DIR}{$label}) {
+    $dir = $self->{DIR}{$label};
+
+    # Expand relative path if necessary
+    $dir = catfile $self->{DIR}{ROOT}, $dir if $dir =~ /^\w/;
+
+  } else {
+    if ($label eq 'ROOT') {
+      w_report 'Error: build root directory not set.';
+      return;
+
+    } elsif ($self->config->setting ('DIR', $label)) {
+      $dir = catfile $self->{DIR}{ROOT}, $self->config->setting ('DIR', $label);
+
+    } else {
+      carp 'Directory label "', $label, '" not recognised';
+      return undef;
+    }
+  }
+
+  # Set up the bld directory, if required
+  if (not -d $dir) {
+    print 'Make directory: ', $dir, "\n" if $self->config->verbose > 1;
+    mkpath $dir or croak 'Cannot create directory "', $dir, '"';
+  }
+
+  $self->{DIR}{$label} = $dir unless $self->{DIR}{$label};
+
+  return $dir;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_get_inherited_paths ($name);
+#
+# DESCRIPTION
+#   This recursive internal method returns a list containing the search path
+#   for a build directory named by the internal label $name. (Please note that
+#   a build directory will only be placed into the search path if the
+#   directory exists.)
+# ------------------------------------------------------------------------------
+
+sub _get_inherited_paths {
+  my $self = shift;
+  my $name = shift;
+
+  return () unless $name and exists $self->{DIR}{$name};
+
+  my @path = ();
+
+  # Recursively inherit the search path for a this type of build directory
+  for my $use (@{ $self->{USE} }) {
+    my @cur_path = $use->_get_inherited_paths ($name);
+    unshift @path, @cur_path;
+  }
+
+  # Place the path of the current build in the front
+  unshift @path, $self->{DIR}{$name};
+
+  return @path;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_get_inherited_srcdirs ($name);
+#
+# DESCRIPTION
+#   This recursive internal method returns a list containing the search path
+#   for a source directory named by the internal package label $name. (Please
+#   note that a source directory will only be placed into the search path if
+#   the directory exists.)
+# ------------------------------------------------------------------------------
+
+sub _get_inherited_srcdirs {
+  my $self = shift;
+  my $name = shift;
+
+  return () unless $name;
+
+  my @path = ();
+
+  # Recursively inherit the search path for this source directory
+  my $key = 'SRCDIR__' . $name;
+  if ($self->_inherit_ok ($key)) {
+    for my $use (@{ $self->{USE} }) {
+      my @cur_path = $use->_get_inherited_srcdirs ($name);
+      unshift @path, @cur_path;
+    }
+  }
+
+  # Place the path of the current source in the front
+  unshift @path, $self->{SRCDIR}{$name}
+    if exists $self->{SRCDIR}{$name} and -d $self->{SRCDIR}{$name};
+
+  return @path;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_get_inherited_items ($type);
+#
+# DESCRIPTION
+#   This recursive internal method returns a list containing an inherited
+#   build item of the type $type. (Depending of $type, the returned list can
+#   be an array or a hash.)
+# ------------------------------------------------------------------------------
+
+sub _get_inherited_items {
+  my $self = shift;
+  my $type = shift;
+
+  return () if not exists $self->{$type};
+
+  if (ref $self->{$type} eq 'ARRAY') {
+
+    my @items = ();
+
+    # Recursively inherit from used builds
+    if ($self->{INHERIT}{$type}) {
+      for my $use (@{ $self->{USE} }) {
+        my @cur_items = $use->_get_inherited_items ($type);
+
+        for my $item (@cur_items) {
+          my $type_item = $type . '__' . $item;
+
+          # Check inheritance option of current item
+          next unless $self->_inherit_ok ($type_item);
+
+          # The statement ensures that there is no duplication
+          push @items, $item unless grep {$_ eq $item} @items;
+        }
+      }
+    }
+
+    # Items in current build
+    if (@{ $self->{$type} }) {
+      for my $item (@{ $self->{$type} }) {
+        # The statement ensures that there is no duplication
+        push @items, $item unless grep {$_ eq $item} @items;
+      }
+    }
+
+    return @items;
+
+  } elsif (ref $self->{$type} eq 'HASH') {
+
+    my %items = ();
+
+    # Recursively inherit from used builds
+    if ($self->{INHERIT}{$type}) {
+      for my $use (@{ $self->{USE} }) {
+        my %cur_items = $use->_get_inherited_items ($type);
+
+        for my $name (keys %cur_items) {
+          my $type_name = $type . '__' . $name;
+
+          # Check inheritance option of current item
+          next unless $self->_inherit_ok ($type_name);
+
+          # "Closer" ancestors overrides more "distant" ones
+          $items{$name} = $cur_items{$name};
+        }
+      }
+    }
+
+    # Items in current build
+    if (%{ $self->{$type} }) {
+      for my $name (keys %{ $self->{$type} }) {
+        # Settings in current build override inherited settings
+        $items{$name} = $self->{$type}{$name};
+      }
+    }
+
+    return %items;
+
+  }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_require_pp ($name);
+#
+# DESCRIPTION
+#   This internal method returns true if source package $name requires
+#   pre-processing.
+# ------------------------------------------------------------------------------
+
+sub _require_pp {
+  my $self = shift;
+  my $name = $_[0];
+
+  my $rc    = 0;
+  my @names = 'PP';
+  push @names, (split /__/, $name);
+
+  # Check whether pre-process flag exists, going up the source package hierarchy
+  do {
+    my $cur_name = join '__', @names;
+    if (exists $self->{PP}{$cur_name}) {
+      $rc = $self->{PP}{$cur_name};
+      return $rc;
+    }
+  } while pop @names;
+
+  return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_inherit_ok ($name);
+#
+# DESCRIPTION
+#   This internal method returns true if it is OK to inherit an item specified
+#   by $name, (where $name is a double underscore "__" delimited positional
+#   list of source package names).
+# ------------------------------------------------------------------------------
+
+sub _inherit_ok {
+  my $self  = shift;
+  my $name  = $_[0];
+
+  my $rc    = 1;
+  my @names = split /__/, $name;
+
+  # Check whether INHERIT flag exists, going up the source package hierarchy
+  do {
+    my $cur_name = join '__', @names;
+    if (exists $self->{INHERIT}{$cur_name}) {
+      $rc = $self->{INHERIT}{$cur_name};
+      return $rc;
+    }
+  } while pop @names;
+
+  return $rc;
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/BuildTask.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/BuildTask.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/BuildTask.pm	(revision 7236)
@@ -0,0 +1,406 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Fcm::BuildTask
+#
+# DESCRIPTION
+#   This class hosts information of a build task in the FCM build system.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::BuildTask;
+
+# Standard pragma
+use strict;
+use warnings;
+
+# Standard modules
+use Carp;
+use File::Compare;
+use File::Basename;
+use File::Path;
+use File::Spec::Functions;
+
+# FCM component modules
+use Fcm::Util;
+use Fcm::Timer;
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $task = Fcm::BuildTask->new (
+#     CONFIG     => $config,
+#     TARGET     => $target,
+#     TARGETPATH => \@targetpath,
+#     SRCFILE    => $srcfile,
+#     DEPENDENCY => \@dependency,
+#     TASKTYPE   => $tasktype,
+#   );
+#
+# DESCRIPTION
+#   This method constructs a new instance of the Fcm::BuildTask class.
+#
+# ARGUMENTS
+#   CONFIG     - reference to a Fcm::Config instance
+#   TARGET     - target name for this task
+#   TARGETPATH - search path for the target
+#   SRCFILE    - reference to input Fcm::SrcFile instance
+#   DEPENDENCY - list of dependencies for this target
+#   TASKTYPE   - type of task to build the target
+# ------------------------------------------------------------------------------
+
+sub new {
+  my $this  = shift;
+  my %args  = @_;
+  my $class = ref $this || $this;
+
+  my $self  = {
+    CONFIG      => exists $args{CONFIG}     ? $args{CONFIG}     : &main::cfg,
+    TARGET      => exists $args{TARGET}     ? $args{TARGET}     : undef,
+    TARGETPATH  => exists $args{TARGETPATH} ? $args{TARGETPATH} : [],
+    SRCFILE     => exists $args{SRCFILE}    ? $args{SRCFILE}    : undef,
+    DEPENDENCY  => exists $args{DEPENDENCY} ? $args{DEPENDENCY} : [],
+    ACTIONTYPE  => exists $args{ACTIONTYPE} ? $args{ACTIONTYPE} : undef,
+
+    OUTPUT      => undef,
+    OUTPUTMTIME => undef,
+  };
+
+  bless $self, $class;
+  return $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $config = $task->config;
+#
+# DESCRIPTION
+#   This method returns a reference to the Fcm::Config instance.
+# ------------------------------------------------------------------------------
+
+sub config {
+  my $self = shift;
+
+  return $self->{CONFIG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $srcfile = $task->srcfile;
+#   $task->srcfile ($srcfile);
+#
+# DESCRIPTION
+#   This method returns the reference to the input Fcm::SrcFile instance
+#   associated with this task. If an argument is specified, the reference is
+#   modified to the value given by the argument.
+# ------------------------------------------------------------------------------
+
+sub srcfile {
+  my $self = shift;
+
+  if (@_) {
+    $self->{SRCFILE} = $_[0];
+  }
+
+  return $self->{SRCFILE};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $actiontype = $task->actiontype;
+#   $task->actiontype ($actiontype);
+#
+# DESCRIPTION
+#   This method returns the action type of this task. If an argument is
+#   specified, the action type of this task is set to the value of the
+#   argument.
+# ------------------------------------------------------------------------------
+
+sub actiontype {
+  my $self = shift;
+
+  if (@_) {
+    $self->{ACTIONTYPE} = $_[0];
+  }
+
+  return $self->{ACTIONTYPE};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $output = $task->output;
+#   $task->output ($output);
+#
+# DESCRIPTION
+#   This method returns the name of the output file after the task has been
+#   performed successfully. If an argument is specified, it sets the output
+#   file (and its last modified time) to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub output {
+  my $self = shift;
+
+  if (@_) {
+    $self->{OUTPUT}      = $_[0];
+    $self->{OUTPUTMTIME} = (stat $self->{OUTPUT}) [9];
+  }
+
+  return $self->{OUTPUT};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $time = $task->outputmtime;
+#
+# DESCRIPTION
+#   This method returns the modified time of the output file.
+# ------------------------------------------------------------------------------
+
+sub outputmtime {
+  my $self = shift;
+
+  return $self->{OUTPUTMTIME};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rc = $task->action (TASKLIST => \%tasklist);
+#
+# DESCRIPTION
+#   This method performs the task action and sets the output accordingly. The
+#   argument TASKLIST must be a reference to a hash containing the other tasks
+#   of the build, which this task may depend on. The keys of the hash must the
+#   name of the target names of the tasks, and the values of the hash must be
+#   the references to the corresponding Fcm::BuildTask instances. The method
+#   returns true if the task has been performed to create a new version of the
+#   target.
+# ------------------------------------------------------------------------------
+
+sub action {
+  my $self     = shift;
+  my %args     = @_;
+  my $tasklist = exists $args{TASKLIST} ? $args{TASKLIST} : {};
+
+  return unless $self->actiontype;
+
+  my $uptodate     = 1;
+  my $dep_uptodate = 1;
+
+  # Check if dependencies are up to date
+  # ----------------------------------------------------------------------------
+  for my $depend (@{ $self->{DEPENDENCY} }) {
+    if (exists $tasklist->{$depend}) {
+      if (not $tasklist->{$depend}->output) {
+        # Dependency task output is not set, performs its task action
+        if ($tasklist->{$depend}->action (TASKLIST => $tasklist)) {
+          $uptodate     = 0;
+          $dep_uptodate = 0;
+        }
+      }
+
+    } elsif ($self->config->verbose > 1) {
+      w_report 'Warning: Task for "', $depend,
+               '" does not exist, may be required by ', $self->{TARGET};
+    }
+  }
+
+  # Check if the target exists in the search path
+  # ----------------------------------------------------------------------------
+  if (@{ $self->{TARGETPATH} }) {
+    my $output = find_file_in_path ($self->{TARGET}, $self->{TARGETPATH});
+    $self->output ($output) if $output;
+  }
+
+  # Target is out of date if it does not exist
+  if ($uptodate) {
+    $uptodate = 0 if not $self->output;
+  }
+
+  # Check if current target is older than its dependencies
+  # ----------------------------------------------------------------------------
+  if ($uptodate) {
+    for my $depend (@{ $self->{DEPENDENCY} }) {
+      next unless exists $tasklist->{$depend};
+
+      if ($tasklist->{$depend}->outputmtime > $self->outputmtime) {
+        $uptodate     = 0;
+        $dep_uptodate = 0;
+      }
+    }
+
+    if ($uptodate and ref $self->srcfile) {
+      $uptodate = 0 if $self->srcfile->mtime > $self->outputmtime;
+    }
+  }
+
+  if ($uptodate) {
+    # Current target and its dependencies are up to date
+    # --------------------------------------------------------------------------
+    if ($self->actiontype eq 'PP') {
+      # "done" file up to date, set name of pre-processed source file
+      # ------------------------------------------------------------------------
+      my $base     = $self->srcfile->root . lc ($self->srcfile->ext);
+      my @pck_list = $self->srcfile->get_package_list;
+      pop @pck_list;
+      my @pknames  = split '__', pop (@pck_list);
+      my @path     = map {
+        catfile ($_, @pknames);
+      } @{ $self->config->setting (qw/PATH PPSRC/) };
+      my $oldfile = find_file_in_path ($base, \@path);
+      $self->srcfile->ppsrc ($oldfile);
+    }
+
+  } else {
+    # Perform action is not up to date
+    # --------------------------------------------------------------------------
+    # (For GENINTERFACE and PP, perform action if "done" file not up to date)
+    my $new_output = @{ $self->{TARGETPATH} }
+                     ? catfile ($self->{TARGETPATH}[0], $self->{TARGET})
+                     : $self->{TARGET};
+
+    # Create destination container directory if necessary
+    my $destdir = dirname $new_output;
+
+    if (not -d $destdir) {
+      print 'Make directory: ', $destdir, "\n" if $self->config->verbose > 2;
+      mkpath $destdir;
+    }
+
+    # List of actions
+    if ($self->actiontype eq 'UPDATE') {
+      # Action is UPDATE: Update file
+      # ------------------------------------------------------------------------
+      print 'Update: ', $new_output, "\n" if $self->config->verbose > 2;
+      touch_file $new_output
+        or croak 'Unable to update "', $new_output, '", abort';
+      $self->output ($new_output);
+
+    } elsif ($self->actiontype eq 'COPY') {
+      # Action is COPY: copy file to destination if necessary
+      # ------------------------------------------------------------------------
+      my $copy_required = ($dep_uptodate and $self->output and -r $self->output)
+                          ? compare ($self->output, $self->srcfile->src)
+                          : 1;
+
+      if ($copy_required) {
+        # Set up copy command
+        &run_command (
+          ['cp', $self->srcfile->src, $destdir],
+          TIME => $self->config->verbose > 2,
+        );
+
+        $self->output ($new_output);
+
+      } else {
+        $uptodate = 1;
+      }
+
+    } elsif ($self->actiontype eq 'PP' or $self->actiontype eq 'GENINTERFACE') {
+      # Action is PP or GENINTERFACE: process file
+      # ------------------------------------------------------------------------
+      my ($newlines, $base, @path);
+
+      if ($self->actiontype eq 'PP') {
+        # Invoke the pre-processor on the source file
+        # ----------------------------------------------------------------------
+        # Get lines in the pre-processed source
+        $newlines = $self->srcfile->pre_process;
+        $base     = $self->srcfile->root . lc ($self->srcfile->ext);
+
+        # Get search path for the existing pre-processed file
+        my @pck_list = $self->srcfile->get_package_list;
+        pop @pck_list;
+        my @pknames  = split '__', pop (@pck_list);
+        @path        = map {
+          catfile ($_, @pknames);
+        } @{ $self->config->setting (qw/PATH PPSRC/) };
+
+      } else { # if ($self->actiontype eq 'GENINTERFACE')
+        # Invoke the interface generator
+        # ----------------------------------------------------------------------
+        # Get new interface lines
+        $newlines = $self->srcfile->gen_interface;
+
+        # Get search path for the existing interface file
+        $base     = $self->srcfile->interfacebase;
+        @path     = @{ $self->config->setting (qw/PATH INC/) },
+      }
+
+
+      # If pre-processed or interface file exists,
+      # compare its content with new lines to see if it has been updated
+      my $update_required = 1;
+      my $oldfile = find_file_in_path ($base, \@path);
+
+      if ($oldfile and -r $oldfile) {
+        # Read old file
+        open FILE, '<', $oldfile;
+        my @oldlines = readline 'FILE';
+        close FILE;
+
+        # Compare old contents and new contents
+        if (@oldlines eq @$newlines) {
+          $update_required = grep {
+            $oldlines[$_] ne $newlines->[$_];
+          } (0 .. $#oldlines);
+        }
+      }
+
+      if ($update_required) {
+        # Update the pre-processed source or interface file
+        # ----------------------------------------------------------------------
+        # Determine container directory of the  pre-processed or interface file
+        my $newfile = @path ? catfile ($path[0], $base) : $base;
+
+        # Create the container directory if necessary
+        if (not -d $path[0]) {
+          print 'Make directory: ', $path[0], "\n"
+            if $self->config->verbose > 1;
+          mkpath $path[0];
+        }
+
+        # Update the pre-processor or interface file
+        open FILE, '>', $newfile
+          or croak 'Cannot write to "', $newfile, '" (', $!, '), abort';
+        print FILE @$newlines;
+        close FILE
+          or croak 'Cannot write to "', $newfile, '" (', $!, '), abort';
+        print 'Generated: ', $newfile, "\n" if $self->config->verbose > 1;
+
+        # Set the name of the pre-processed file
+        $self->srcfile->ppsrc ($newfile) if $self->actiontype eq 'PP';
+
+        # Set the "current" flag of the container source package to "true"
+        $self->srcfile->srcpackage->current (1);
+
+      } else {
+        # Content in pre-processed source or interface file is up to date
+        # ----------------------------------------------------------------------
+        $uptodate = 1;
+
+        # Set the name of the pre-processed file
+        $self->srcfile->ppsrc ($oldfile) if $self->actiontype eq 'PP';
+      }
+
+      # Update the "done" file
+      print 'Update: ', $new_output, "\n" if $self->config->verbose > 2;
+      touch_file $new_output
+        or croak 'Unable to update "', $new_output, '", abort';
+      $self->output ($new_output);
+
+    } else {
+      carp 'Action type "', $self->actiontype, "' not supported";
+    }
+  }
+
+  return not $uptodate;
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/CfgFile.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/CfgFile.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/CfgFile.pm	(revision 7236)
@@ -0,0 +1,861 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Fcm::CfgFile
+#
+# DESCRIPTION
+#   This class is used for reading and writing FCM config files. A FCM config
+#   file is a line-based text file that provides information on how to perform
+#   a particular task using the FCM system.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::CfgFile;
+
+# Standard pragma
+use warnings;
+use strict;
+
+# Standard modules
+use Carp;
+use File::Basename;
+use File::Path;
+use File::Spec;
+use File::Spec::Functions;
+
+# FCM component modules
+use Fcm::Util;
+
+# Local module variables
+my $expand_type   = 'bld|ext'; # config file type that needs variable expansions
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cfgfile = Fcm::CfgFile->new (CONFIG=> $config, SRC => $src, TYPE => $type);
+#
+# DESCRIPTION
+#   This method constructs a new instance of the Fcm::CfgFile class.
+#
+# ARGUMENTS
+#   CONFIG - reference to a Fcm::Config instance
+#   SRC    - configuration file source
+#   TYPE   - type of expected configuration file
+# ------------------------------------------------------------------------------
+
+sub new {
+  my $this  = shift;
+  my %args  = @_;
+  my $class = ref $this || $this;
+
+  my $self = {
+    CONFIG     => exists $args{CONFIG} ? $args{CONFIG} : &main::cfg,
+    SRC        => exists $args{SRC}    ? $args{SRC}    : undef,
+    TYPE       => exists $args{TYPE}   ? $args{TYPE}   : undef,
+
+    # Version of the configuration file
+    VERSION    => undef,
+
+    # List of references to hash tables for each line in the file
+    LINES      => [],
+
+    # Actual source of configuration file
+    ACTUAL_SRC => undef,
+    PEGREV     => undef,
+  };
+  bless $self, $class;
+  return $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $config = $cfgfile->config;
+#
+# DESCRIPTION
+#   This method returns a reference to the Fcm::Config instance.
+# ------------------------------------------------------------------------------
+
+sub config {
+  my $self = shift;
+
+  return $self->{CONFIG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $src = $cfgfile->src ();
+#   $cfgfile->src ($src);
+#
+# DESCRIPTION
+#   This method returns the specified source of the configuration file. If an
+#   argument is specified, the source of the configuration file is modified to
+#   the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub src {
+  my $self = shift;
+
+  if (@_) {
+    $self->{SRC} = shift;
+  }
+
+  return $self->{SRC};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $src = $cfgfile->actual_src ();
+#
+# DESCRIPTION
+#   This method returns the actual source of the configuration file. If an
+#   argument is specified, the source of the configuration file is modified to
+#   the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub actual_src {
+  my $self = shift;
+
+  return $self->{ACTUAL_SRC};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rev = $cfgfile->pegrev ();
+#
+# DESCRIPTION
+#   This method returns the peg revision of the configuration file.
+# ------------------------------------------------------------------------------
+
+sub pegrev {
+  my $self = shift;
+
+  return $self->{PEGREV};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $type = $cfgfile->type ();
+#   $cfgfile->type ($type);
+#
+# DESCRIPTION
+#   This method returns the configuration file type. If an argument is
+#   specified, the type is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub type {
+  my $self = shift;
+
+  if (@_) {
+    $self->{TYPE} = shift;
+  }
+
+  return $self->{TYPE};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $version = $cfgfile->version ();
+#
+# DESCRIPTION
+#   This method returns the version of the configuration file.
+# ------------------------------------------------------------------------------
+
+sub version {
+  my $self = shift;
+
+  return $self->{VERSION};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @lines = $cfgfile->lines ();
+#
+# DESCRIPTION
+#   This method returns an array containing all "lines" in the configuration
+#   file. Each "line" is a reference to a hash table with the following keys:
+#
+#   SRC     - the source of the configuration file
+#   NUMBER  - the line number in the source
+#   LABEL   - the label of the of the configuration line
+#   VALUE   - the value of the configuration line
+#   COMMENT - comment in the configuration line
+# ------------------------------------------------------------------------------
+
+sub lines {
+  my $self = shift;
+
+  return @{ $self->{LINES} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $line = $cfgfile->line ($line_number);
+#
+# DESCRIPTION
+#   This method return a "line" at $line_number in the configuration file. A
+#   "line" is a reference to a hash table with the following keys:
+#
+#   SRC     - the source of the configuration file
+#   NUMBER  - the line number in the source
+#   LABEL   - the label of the of the configuration line
+#   VALUE   - the value of the configuration line
+#   COMMENT - comment in the configuration line
+# ------------------------------------------------------------------------------
+
+sub line {
+  my $self     = shift;
+  my $line_num = shift;
+
+  if (exists $self->{LINES}[$line_num]) {
+    return $self->{LINES}[$line_num]; # returns a ref to a label:value pair hash
+
+  } else {
+    return undef;
+  }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cfgfile->add_line (
+#     LABEL   => $label,
+#     VALUE   => $value,
+#     COMMENT => $comment,
+#     SRC     => $src,
+#     NUMBER  => $line_number
+#   );
+#
+# DESCRIPTION
+#   This method adds a "line" to the configuration file. LABEL is the
+#   configuration line label. VALUE is the configuration line value. COMMENT
+#   is the comment in the line. VALUE should only be specified if LABEL is
+#   specified. COMMENT can be specified without LABEL. In such case, the whole
+#   line is a comment line. A blank line is inserted if no argument is
+#   specified. SRC can be specified to indicate the name of the source file
+#   from which this line is obtained. If not specified, the source file of the
+#   current configuration file is used. NUMBER can be specified to indicate
+#   the line number of the source file from which this line is obtained.
+# ------------------------------------------------------------------------------
+
+sub add_line {
+  my $self = shift;
+  my %args = @_;
+
+  my $line = {
+    SRC     => exists $args{SRC    } ? $args{SRC    } : $self->actual_src,
+    NUMBER  => exists $args{NUMBER } ? $args{NUMBER } : 0,
+    LABEL   => exists $args{LABEL  } ? $args{LABEL  } : '',
+    VALUE   => exists $args{VALUE  } ? $args{VALUE  } : '',
+    COMMENT => exists $args{COMMENT} ? $args{COMMENT} : '',
+  };
+
+  push @{ $self->{LINES} }, $line;
+
+  return $line;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cfgfile->add_comment_block ($line1, [$line2, ...]);
+#
+# DESCRIPTION
+#   This method adds a comment block to the configuration file. Each argument
+#   represents a line in the comment block.
+# ------------------------------------------------------------------------------
+
+sub add_comment_block {
+  my $self = shift;
+
+  $self->add_line (COMMENT => '-' x 78,);
+
+  while (my $line = shift @_) {
+    $self->add_line (COMMENT => $line,)
+  }
+
+  $self->add_line (COMMENT => '-' x 78,);
+  $self->add_line;
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cfgfile->add_header ();
+#
+# DESCRIPTION
+#   This method adds a header to the configuration file, with its type and
+#   type version. It returns 1 on success.
+# ------------------------------------------------------------------------------
+
+sub add_header {
+  my $self = shift;
+
+  return undef unless $self->{TYPE};
+
+  $self->{VERSION} = $self->config->setting ('CFG_VERSION', uc ($self->{TYPE}))
+    if not $self->{VERSION};
+
+  $self->add_comment_block ('File header');
+
+  $self->add_line (
+    LABEL => $self->config->setting (qw/CFG_LABEL CFGFILE TYPE/),
+    VALUE => $self->{TYPE},
+  );
+
+  $self->add_line (
+    LABEL => $self->config->setting (qw/CFG_LABEL CFGFILE VERSION/),
+    VALUE => $self->{VERSION},
+  );
+
+  $self->add_line;
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $exist = $cfg->label_exists ($label);
+#   @lines = $cfg->label_exists ($label);
+#
+# DESCRIPTION
+#   This method returns the (number of) "lines" with their LABEL matching the
+#   argument $label.
+# ------------------------------------------------------------------------------
+
+sub label_exists {
+  my $self  = shift;
+  my $label = shift;
+
+  return grep {$_->{LABEL} eq $label} @{ $self->{LINES} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $mtime = $cfgfile->mtime ();
+#
+# DESCRIPTION
+#   This method returns the modified time of the configuration file source.
+# ------------------------------------------------------------------------------
+
+sub mtime {
+  my $self  = shift;
+  my $mtime = undef;
+
+  if (-f $self->{SRC}) {
+    $mtime = (stat $self->{SRC})[9];
+  }
+
+  return $mtime;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $read = $cfgfile->read_cfg ();
+#
+# DESCRIPTION
+#   This method reads the current configuration file. It returns the number of
+#   lines read from the config file, or "undef" if it fails. The result is
+#   placed in the LINES array of the current instance, and can be accessed via
+#   the "lines" method.
+# ------------------------------------------------------------------------------
+
+sub read_cfg {
+  my $self = shift;
+
+  my @lines = $self->_get_cfg_lines;
+
+  # List of CFG labels
+  my %cfg_labels = %{ $self->config->setting ('CFG_LABEL') };
+
+  # List of CFG types that need INC declarations expansion
+  my %exp_inc    = ();
+  for (split (/,/, $self->config->setting ('CFG_EXP_INC'))) {
+    $exp_inc{uc ($_)} = 1;
+  }
+
+  # List of CFG labels that are reserved keywords
+  my %cfg_keywords = ();
+  for (split (/,/, $self->config->setting ('CFG_KEYWORD'))) {
+    $cfg_keywords{$cfg_labels{$_}} = 1;
+  }
+
+  # Loop each line, to separate lines into label : value pairs
+  my $cont = undef;
+  my $here = undef;
+  for my $line_num (1 .. @lines) {
+    my $line = $lines[$line_num - 1];
+    chomp $line;
+
+    my $label   = '';
+    my $value   = '';
+    my $comment = '';
+
+    # If this line is a continuation, set $start to point to the line that
+    # starts this continuation. Otherwise, set $start to undef
+    my $start   = defined ($cont) ? $self->line ($cont) : undef;
+
+    if ($line =~ /^(\s*#.*)$/) { # comment line
+      $comment = $1;
+
+    } elsif ($line =~ /\S/) {    # non-blank line
+      if (defined $cont) {
+        # Previous line has a continuation mark
+        $value = $line;
+
+        # Separate value and comment
+        if ($value =~ s/((?:\s+|^)#\s+.*)$//) {
+          $comment = $1;
+        }
+
+        # Remove leading spaces
+        $value =~ s/^\s*\\?//;
+
+        # Expand environment variables
+        $value = $self->_expand_variable ($value, 1) if $value;
+
+        # Expand internal variables
+        $value = $self->_expand_variable ($value) if $value;
+
+        # Get "line" that begins the current continuation
+        ($start->{VALUE} .= $value) =~ s/\\$//;
+
+      } else {
+        # Previous line does not have a continuation mark
+        if ($line =~ /^\s*(\S+)(?:\s+(.*))?$/) {
+          # Check line contains a valid label:value pair
+          $label = $1;
+          $value = defined ($2) ? $2 : '';
+
+          # Separate value and comment
+          if ($value =~ s/((?:\s+|^)#\s+.*)$//) {
+            $comment = $1;
+          }
+
+          # Remove trailing spaces
+          $value =~ s/\s+$//;
+
+          # Value begins with $HERE?
+          $here  = ($value =~ /\$\{?HERE\}?(?:[^A-Z_]|$)/);
+
+          # Expand environment variables
+          $value = $self->_expand_variable ($value, 1) if $value;
+
+          # Expand internal variables
+          $value = $self->_expand_variable ($value) if $value;
+        }
+      }
+
+      # Determine whether current line ends with a continuation mark
+      if ($value =~ s/\\$//) {
+        $cont = scalar ($self->lines) unless $cont;
+
+      } else {
+        $cont = undef;
+      }
+    }
+
+    if (exists $exp_inc{uc ($self->type)} and
+        uc ($start ? $start->{LABEL} : $label) eq $cfg_labels{INC} and
+        not defined $cont) {
+      # Current configuration file requires expansion of INC declarations
+      # The start/current line is an INC declaration
+      # The current line is not a continuation or is the end of the continuation
+
+      # Get lines from an "include" configuration file
+      my $src = ($start ? $start->{VALUE} : $value);
+      $src   .= '@' . $self->pegrev if $here and $self->pegrev;
+
+      if ($src) {
+        # Invoke a new instance to read the source
+        my $cfg = Fcm::CfgFile->new (
+          SRC    => expand_tilde ($src),
+          TYPE   => $self->type,
+          CONFIG => $self->config,
+        );
+
+        $cfg->read_cfg;
+
+        # Add lines to the "LINES" array in the current configuration file
+        $comment = 'INC ' . $src . ' ';
+        $self->add_line (
+          COMMENT => $comment . '# Start',
+          NUMBER  => ($start ? $start->{NUMBER} : $line_num),
+        );
+        $self->add_line (%{ $_ }) for (($cfg->lines));
+        $self->add_line (COMMENT => $comment . '# End');
+
+      } else {
+        $self->add_line (NUMBER  => $line_num);
+        w_report 'Warning: ', $self->actual_src, ': line ', $line_num,
+                 ': empty INC declaration.' if $self->config->verbose > 2;
+      }
+
+    } else {
+      # Push label:value pair into "LINES" array
+      $self->add_line (
+        LABEL   => $label,
+        VALUE   => ($label ? $value : ''),
+        COMMENT => $comment,
+        NUMBER  => $line_num,
+      );
+    }
+
+    next if defined $cont; # current line not a continuation
+
+    my $slabel = ($start ? $start->{LABEL} : $label);
+    my $svalue = ($start ? $start->{VALUE} : $value);
+    next unless $slabel;
+
+    # Check config file type and version
+    if (uc ($slabel) eq $cfg_labels{CFGFILE}{TYPE}) {
+      $self->type ($svalue);
+
+    } elsif (uc ($slabel) eq $cfg_labels{CFGFILE}{VERSION}) {
+      $self->version ($svalue);
+    }
+
+    # Set internal variable
+    $slabel =~ s/^\%//; # Remove leading "%" from label
+
+    $self->config->assign_variable (
+      LABEL => $slabel,
+      VALUE => $svalue,
+    ) unless exists $cfg_keywords{$slabel};
+  }
+
+  return $self->lines;
+
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rc = $cfgfile->print_cfg ($file);
+#
+# DESCRIPTION
+#   This method prints the content of current configuration file. If no
+#   argument is specified, it prints output to the standard output. If $file
+#   is specified, and is a writable file name, the output is sent to the file.
+#   If the file already exists, its content is compared to the current output.
+#   Nothing will be written if the content is unchanged. Otherwise, for typed
+#   configuration files, the existing file is renamed using a prefix that
+#   contains its last modified time. The method returns 1 if there is no
+#   error.
+# ------------------------------------------------------------------------------
+
+sub print_cfg {
+  my $self = shift;
+  my $file = shift;
+
+  # Count maximum number of characters in the labels, (for pretty printing)
+  my $max_label_len = 0;
+  for my $line (@{ $self->{LINES} }) {
+    next unless $line->{LABEL};
+    my $label_len  = length $line->{LABEL};
+    $max_label_len = $label_len if $label_len > $max_label_len;
+  }
+
+  # Output string
+  my $out = '';
+
+  # Append each line of the config file to the output string
+  for my $line (@{ $self->{LINES} }) {
+    my $label   = $line->{LABEL};
+    my $value   = $line->{VALUE};
+    my $comment = $line->{COMMENT};
+
+    if ($label) {
+      # Line up label/value for pretty printing
+      $label   = $label . ' ' x ($max_label_len - length ($label));
+      $comment =~ s/^\s+/ / if $comment;
+
+      $out .= $label;
+      $out .= ' ' . $value if defined $value;
+
+    } else {
+      # Make sure comments begin with a "#"
+      $comment = '# ' . $comment if $comment and $comment !~ /^\s*($|#)/;
+      $comment =~ s/^\s*//;
+    }
+
+    $out .= $comment if $comment;
+    $out .= "\n";
+  }
+
+  if ($out) {
+
+    my $old_select = select;
+
+    # Open file if necessary
+    if ($file) {
+      # Make sure the host directory exists and is writable
+      my $dirname = dirname $file;
+      if (not -d $dirname) {
+        print 'Make directory: ', $dirname, "\n" if $self->config->verbose;
+        mkpath $dirname;
+      }
+      croak 'Cannot write to config file directory: "', $dirname, '", abort'
+        unless -d $dirname and -w $dirname;
+
+      # If config file already exists, make sure it is writable
+      if (-f $file) {
+        if (-r $file) {
+          # Read old config file to see if content has changed
+          open IN, '<', $file;
+          my $in_lines = '';
+          while (my $line = <IN>) {
+            $in_lines .= $line;
+          }
+          close IN;
+
+          # Return if content is up-to-date
+          if ($in_lines eq $out) {
+            print 'No change in ', lc ($self->{TYPE}), ' cfg: ', $file,
+                  "\n" if $self->config->verbose > 1 and $self->{TYPE};
+            return;
+          }
+        }
+
+        if (-w $file) {
+          if ($self->{TYPE}) {
+            # Existing config file writable, rename it using its time stamp
+            my $mtime = (stat $file)[9];
+            my ($sec, $min, $hour, $mday, $mon, $year) = (gmtime $mtime)[0 .. 5];
+            my $timestamp = sprintf '%4d%2.2d%2.2d_%2.2d%2.2d%2.2d_',
+                            $year + 1900, $mon + 1, $mday, $hour, $min, $sec;
+            my $oldfile   = catfile $dirname, $timestamp . basename ($file);
+            rename $file, $oldfile;
+            print 'Renamed existing ', lc ($self->{TYPE}), ' cfg: ',
+                  $oldfile, "\n" if $self->config->verbose > 1;
+          }
+        } else {
+          # Existing config file not writable, throw an error
+          croak 'Config file "', $file, '" not writable, abort';
+        }
+      }
+
+      # Open file and select file handle
+      open OUT, '>', $file
+        or croak 'Cannot write to config file "', $file, '" (', $!, '), abort';
+      select OUT;
+    }
+
+    # Print output
+    print $out;
+
+    # Close file if necessary
+    if ($file) {
+      select $old_select;
+      close OUT;
+
+      if ($self->{TYPE} and $self->config->verbose > 1) {
+        print 'Generated ', lc ($self->{TYPE}), ' cfg: ', $file, "\n";
+      } elsif ($self->config->verbose > 2) {
+        print 'Generated cfg: ', $file, "\n";
+      }
+    }
+
+  } else {
+
+    # Warn if nothing to print
+    my $warning = 'Empty configuration';
+    $warning   .= ' - nothing written to file: "' . $file . '"' if $file;
+    carp $warning if $self->{TYPE};
+
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @lines = $self->_get_cfg_lines ();
+#
+# DESCRIPTION
+#   This internal method reads from a configuration file residing in a
+#   Subversion repository or in the normal file system.
+# ------------------------------------------------------------------------------
+
+sub _get_cfg_lines {
+  my $self  = shift;
+  my @lines = ();
+
+  my $verbose = $self->config->verbose;
+
+  # Expand URL keywords if necessary
+  {
+    my $src = expand_url_keyword (URL => $self->src, CFG => $self->config);
+    $self->src ($src) if $src ne $self->src;
+  }
+
+  if (&is_url ($self->src)) {
+    # Config file resides in a SVN repository
+    # --------------------------------------------------------------------------
+    # Set URL source and version
+    my $src = $self->src;
+    my $rev = 'HEAD';
+
+    # Extract version from source if it exists
+    if ($src =~ s/@(.+)$//) {
+      $rev = $1;
+    }
+
+    # Expand revision keyword, if required
+    $rev = expand_rev_keyword (REV => $rev, URL => $src, HEAD => 1);
+
+    # Check whether URL is a config file
+    my $rc;
+    my @cmd = (qw/svn cat/, $src . '@' . $rev);
+    @lines = &run_command (
+      \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore',
+    );
+
+    # Error in "svn cat" command
+    if ($rc) {
+      # See whether specified config file is a known type
+      my %cfgname = %{ $self->config->setting ('CFG_NAME') };
+      my $key     = uc $self->type;
+      my $file    = exists $cfgname{$key} ? $cfgname{$key} : '';
+
+      # If config file is a known type, specified URL may be a directory
+      if ($file) {
+        # Check whether a config file with a default name exists in the URL
+        my $sep  = $self->config->setting (qw/MISC DIR_SEPARATOR/);
+        my $path = $src . $sep . $file;
+        my @cmd  = (qw/svn cat/, $path . '@' . $rev);
+
+        @lines = &run_command (
+          \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore',
+        );
+
+        # Check whether a config file with a default name exists under the "cfg"
+        # sub-directory of the URL
+        if ($rc) {
+          my $cfgdir = $self->config->setting (qw/DIR CFG/);
+          $path   = $src . $sep . $cfgdir . $sep . $file;
+          my @cmd = (qw/svn cat/, $path . '@' . $rev);
+
+          @lines  = &run_command (
+            \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore',
+          );
+        }
+
+        $src = $path unless $rc;
+      }
+    }
+
+    if ($rc) {
+      # Error in "svn cat"
+      croak 'Unable to locate config file from "', $self->src, '", abort';
+
+    } else {
+      # Print diagnostic, if necessary
+      if ($verbose and $self->type and $self->type =~ /$expand_type/) {
+        print '# Config file (', $self->type, '): ', $src;
+        print '@', $rev if $rev;
+        print "\n";
+      }
+    }
+
+    # Record the actual source location
+    $self->{PEGREV    } = $rev;
+    $self->{ACTUAL_SRC} = $src;
+
+  } else {
+    # Config file resides in the normal file system
+    # --------------------------------------------------------------------------
+    my $src = $self->src;
+
+    if (-d $src) { # Source is a directory
+      croak 'Config file "', $src, '" is a directory, abort' if not $self->type;
+
+      # Get name of the config file by looking at the type
+      my %cfgname = %{ $self->config->setting ('CFG_NAME') };
+      my $key     = uc $self->type;
+      my $file    = exists $cfgname{$key} ? $cfgname{$key} : '';
+
+      if ($file) {
+        my $cfgdir = $self->config->setting (qw/DIR CFG/);
+
+        # Check whether a config file with a default name exists in the
+        # specified path, then check whether a config file with a default name
+        # exists under the "cfg" sub-directory of the specified path
+        if (-f catfile $self->src, $file) {
+          $src = catfile $self->src, $file;
+
+        } elsif (-f catfile ($self->src, $cfgdir, $file)) {
+          $src = catfile $self->src, $cfgdir, $file;
+
+        } else {
+          croak 'Unable to locate config file from "', $self->src, '", abort';
+        }
+
+      } else {
+        croak 'Unknown config file type "', $self->type, '", abort';
+      }
+    }
+
+    if (-r $src) {
+      open FILE, '<', $src;
+      print '# Config file (', $self->type, '): ', $src, "\n"
+        if $verbose and $self->type and $self->type =~ /$expand_type/;
+
+      @lines = readline 'FILE';
+      close FILE;
+
+    } else {
+      croak 'Unable to read config file "', $src, '", abort';
+    }
+
+    # Record the actual source location
+    $self->{ACTUAL_SRC} = $src;
+  }
+
+  return @lines;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $string = $self->_expand_variable ($string[, $env]);
+#
+# DESCRIPTION
+#   This internal method expands variables in $string. If $env is specified
+#   and is true, it expands environment variables. Otherwise, it expands
+#   local variables.
+# ------------------------------------------------------------------------------
+
+sub _expand_variable {
+  my ($self, $string, $env) = @_;
+
+  # Pattern for environment/local variable
+  my $pattern = $env ? '\$\{?([A-Z][A-Z0-9_]+)\}?' : '%\{?([\w:]+)\}?';
+
+  while ($string and $string =~ /$pattern/) {
+    my $var_label = $1; # variable label
+
+    # Get variable value from environment or local configuration
+    my $variable = $env
+                   ? (exists $ENV{$var_label} ? $ENV{$var_label} : undef)
+                   : $self->config->variable ($var_label);
+
+    $variable = dirname ($self->actual_src)
+      if $env and $var_label eq 'HERE' and not defined $variable;
+
+    # Substitute match with value of variable
+    if (defined $variable) {
+      $string =~ s/$pattern/$variable/;
+
+    } else {
+      w_report 'Warning: ', $self->actual_src, ': variable "',
+               ($env ? '$' : '%'), $var_label, '" not expanded.';
+      last;
+    }
+  }
+
+  return $string;
+}
+
+1;
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Cm.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Cm.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Cm.pm	(revision 7236)
@@ -0,0 +1,2243 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Fcm::Cm
+#
+# DESCRIPTION
+#   This module contains the FCM code management functionalities and wrappers
+#   to Subversion commands.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::Cm;
+
+# Standard pragma
+use warnings;
+use strict;
+
+# Standard modules
+our (@ISA, @EXPORT, @EXPORT_OK);
+use Getopt::Long;
+use File::Basename;
+use File::Path;
+use File::Spec;
+use File::Temp qw/tempfile/;
+use Cwd;
+
+# FCM component modules
+use Fcm::CmBranch;
+use Fcm::CmUrl;
+use Fcm::Util;
+
+sub cm_command;
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(
+  cm_command
+);
+
+# Function declaration:
+sub cm_add;
+sub cm_branch;
+sub cm_commit;
+sub cm_conflicts;
+sub cm_delete;
+sub cm_diff;
+sub cm_merge;
+sub cm_mkpatch;
+sub cm_svn;
+sub cm_switch;
+sub _construct_branch_url;
+
+# ------------------------------------------------------------------------------
+
+my @subcommand_url = qw/
+  blame     praise annotate ann
+  branch    br
+  cat
+  checkout  co
+  copy      cp
+  delete    del    remove   rm
+  diff      di
+  export
+  import
+  info
+  list      ls
+  lock
+  log
+  merge
+  mkdir
+  mkpatch
+  move      mv     rename   ren
+  propdel   pdel   pd
+  propedit  pedit  pe
+  propget   pget   pg
+  proplist  plist  pl
+  propset   pset   ps
+  switch    sw
+  unlock
+/; # List of subcommands that accept URL inputs
+
+my @subcommand_rev = qw/
+  blame     praise annotate ann
+  branch    br
+  cat
+  checkout  co
+  copy      cp
+  diff      di
+  export
+  info
+  list      ls
+  log
+  merge
+  mkpatch
+  move      mv     rename   ren
+  propdel   pdel   pd
+  propedit  pedit  pe
+  propget   pget   pg
+  proplist  plist  pl
+  propset   pset   ps
+  switch    sw
+  update    up
+/; # List of subcommands that accept revision inputs
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &cm_command ($function);
+#
+# DESCRIPTION
+#   This is the generic FCM code management wrapper. It calls the correct FCM
+#   code management function or a wrapper to a Subversion command based on the
+#   value of the argument $function.
+# ------------------------------------------------------------------------------
+
+sub cm_command {
+
+  my ($function) = shift @_;
+
+  # Expand URL keywords if necessary
+  if (grep {$_ eq $function} @subcommand_url) {
+    for my $arg (@ARGV) {
+      my $var = expand_url_keyword (URL => $arg);
+      $arg = $var if $arg ne $var;
+    }
+  }
+
+  # Expand revision keywords (for -r or --revision options) if necessary
+  if (grep {$_ eq $function} @subcommand_rev) {
+    my @new_argv = ();
+
+    while (defined (my $arg = shift @ARGV)) {
+      if ($arg eq '--revision') {
+        # Long --revision option, must be followed by a space before the
+        # revision argument
+        push @new_argv, $arg;
+
+      } elsif ($arg =~ s/^-r//) {
+        # Short -r option, may be followed by the revision argument with or
+        # without a space in between
+        push @new_argv, '--revision';
+        unshift @ARGV, $arg if $arg;
+
+      } else {
+        # Other option or argument
+        push @new_argv, $arg;
+        next;
+      }
+
+      # First revision number/keyword
+      my $rev1 = '';
+
+      # Get the next argument from the list
+      $arg = shift @ARGV;
+
+      if (index ($arg, '{') == 0) {
+        # A revision date argument may contain a space. Therefore, it may need
+        # the next argument(s) from the list
+        while (index ($arg, '}') == -1) {
+          my $shift = shift @ARGV;
+          last unless $shift;
+          $arg     .= ' ' . $shift;
+        }
+
+        $arg  =~ s/^(\{.+?\})//;
+        $rev1 = $1;
+
+      } else {
+        # Other revision argument
+        $arg  =~ s/^(\S+?)(?::|$)//;
+        $rev1 = $1;
+      }
+
+      # The rest of $arg is the second revision number/keyword
+      my $rev2 = $arg;
+      $rev2 =~ s/^:*//;
+
+      # A revision date argument may contain a space. Therefore, it may need
+      # the next argument(s) from the list
+      if (index ($rev2, '{') == 0) {
+        while (index ($rev2, '}') == -1) {
+          my $shift = shift @ARGV;
+          last unless $shift;
+          $rev2    .= ' ' . $shift;
+        }
+      }
+
+      # Expand revision keyword if necessary
+      if ($rev1 !~ /^(?:\d+|HEAD|BASE|COMMITTED|PREV|\{.+\})$/i or
+          $rev2 !~ /^(?:\d+|HEAD|BASE|COMMITTED|PREV|\{.+\})$/i) {
+        # Find out the associated URLs by inspecting the argument list
+        my $url1 = '';
+        my $url2 = '';
+
+        for (@new_argv, @ARGV) {
+          my $arg = Fcm::CmUrl->new (URL => $_);
+          next unless $arg->is_url;
+
+          if ($url1) {
+            $url2 = $arg->url_peg;
+            last;
+
+          } else {
+            $url1 = $arg->url_peg;
+          }
+        }
+
+        # Argument list does not contain a URL, try "svn info" on WC
+        $url1 = &get_url_of_wc () if not $url1;
+        $url2 = $url1 if not $url2;
+
+        # Expand 1st revision keyword if necessary
+        $rev1 = expand_rev_keyword (REV => $rev1, URL => $url1)
+          if $rev1 !~ /^(?:\d+|HEAD|BASE|COMMITTED|PREV|\{.+\})$/i;
+
+        # Expand 2nd revision keyword if necessary
+        $rev2 = expand_rev_keyword (REV => $rev2, URL => $url2)
+          if $rev2 and $rev2 !~ /^(?:\d+|HEAD|BASE|COMMITTED|PREV|\{.+\})$/i;
+      }
+
+      # Append revision argument to argument list
+      push @new_argv, ($rev2 ? $rev1 . ':' . $rev2 : $rev1);
+    }
+
+    @ARGV = @new_argv;
+  }
+
+  # Expand revision keywords (for peg revision TARGET@REVSION) if necessary
+  for (@ARGV) {
+    if (m#^(\w+://\S+)@(\S+)$#) {
+      my $url = $1;
+      my $rev = $2;
+
+      my $new_rev = expand_rev_keyword (URL => $url, REV => $rev, HEAD => 1);
+
+      $_ = $url . '@' . $new_rev if $new_rev ne $rev;
+    }
+  }
+
+  # List of special sub-commands recognised by FCM
+  my %subcommand = (
+    ADD       => [qw/add/],
+    BRANCH    => [qw/branch br/],
+    COMMIT    => [qw/commit ci/],
+    CONFLICTS => [qw/conflicts cf/],
+    CHECKOUT  => [qw/checkout co/],
+    DELETE    => [qw/delete del remove rm/],
+    DIFF      => [qw/diff di/],
+    MERGE     => [qw/merge/],
+    MKPATCH   => [qw/mkpatch/],
+    SWITCH    => [qw/switch sw/],
+  );
+
+  if (grep {$_ eq $function} @{ $subcommand{ADD} }) {
+    cm_add;
+
+  } elsif (grep {$_ eq $function} @{ $subcommand{BRANCH} }) {
+    cm_branch;
+
+  } elsif (grep {$_ eq $function} @{ $subcommand{CHECKOUT} }) {
+    # Check whether the last argument is a PATH.
+    # If so, check whether it is a working copy.
+    # Otherwise, check whether the current directory is a working copy.
+    # If current working direcory (or PATH) is a working copy, fail the command.
+    if (@ARGV) {
+      my $arg  = Fcm::CmUrl->new (URL => $ARGV [-1]);
+      my $path = $arg->is_url ? cwd () : $ARGV [-1];
+
+      e_report $path, ': already a working copy, abort checkout.'
+        if &is_wc ($path);
+    }
+
+    # Invoke checkout
+    cm_svn ('checkout');
+
+  } elsif (grep {$_ eq $function} @{ $subcommand{COMMIT} }) {
+    cm_commit;
+
+  } elsif (grep {$_ eq $function} @{ $subcommand{CONFLICTS} }) {
+    cm_conflicts;
+
+  } elsif (grep {$_ eq $function} @{ $subcommand{DELETE} }) {
+    cm_delete;
+
+  } elsif (grep {$_ eq $function} @{ $subcommand{DIFF} }) {
+    cm_diff;
+
+  } elsif (grep {$_ eq $function} @{ $subcommand{MERGE} }) {
+    cm_merge;
+
+  } elsif (grep {$_ eq $function} @{ $subcommand{MKPATCH} }) {
+    cm_mkpatch;
+
+  } elsif (grep {$_ eq $function} @{ $subcommand{SWITCH} }) {
+    cm_switch;
+
+  } else {
+    cm_svn ($function);
+  }
+
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &Fcm::Cm::cm_add ();
+#
+# DESCRIPTION
+#   This is a wrapper to "svn add". It adds an extra functionality to check
+#   for any files or directories reported by "svn status" as not under version
+#   control, and to prompt the user whether these files or directories should
+#   be added.
+# ------------------------------------------------------------------------------
+
+sub cm_add {
+
+  # Print usage message if requested
+  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
+    print <<EOF;
+usage: fcm add [options] [args]
+
+Valid options:
+  -c [--check]  : Check for any files or directories reported by svn status as
+                  not under version control and add them.
+  <SVN options> : Standard options to svn add as described below ...
+
+EOF
+
+    &run_command ([qw/svn add --help/], PRINT => 1, METHOD => 'exec');
+  }
+
+  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--check -c)) {
+    # The --check option is specified, add any new files
+    # Execute "svn status", print lines starting with a "?"
+    my $pat    = '^\?.{4}\s*';
+    my @status = grep /$pat.*/, &run_command ([qw/svn status/], METHOD => 'qx');
+    print @status if @status;
+
+    # Get list of "?" files
+    my @files  = map {chomp; s/$pat//; $_} @status;
+    my $reply  = '';
+
+    # Execute "add" command depending on user reply
+    for my $file (@files) {
+      # Get a user reply, unless previous reply is "a" for "all"
+      $reply = &main::get_input (
+        TITLE   => 'fcm add',
+        MESSAGE => "Add file '$file'?",
+        TYPE    => 'yna',
+        DEFAULT => 'n',
+      ) unless $reply eq "a";
+
+      # Add current $file if reply is "y" for "yes" or "a" for "all"
+      &run_command ([qw/svn add/, $file]) if $reply =~ /^[ya]$/;
+    }
+
+  } else {
+    # The --check option is not specified, just call "svn add"
+    cm_svn ("add");
+  }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &Fcm::Cm::cm_branch ();
+#
+# DESCRIPTION
+#   This is a FCM command to check information, create or delete a branch in
+#   a Subversion repository.
+# ------------------------------------------------------------------------------
+
+sub cm_branch {
+  my $usage = <<EOF;
+branch: Create, delete or display information of a branch
+usage: 1. fcm branch [--info] [OPTIONS] [TARGET]
+       2. fcm branch --delete [OPTIONS] [TARGET]
+       3. fcm branch --create [OPTIONS] [SOURCE]
+       4. fcm branch --list   [OPTIONS] [SOURCE]
+
+  1. --info or -i: Display information about a branch. This is the default
+     option if --create, --delete and --list are not specified.
+
+  2. --delete or -d: Delete a branch.
+
+  3. --create or -c: Create a new branch from SOURCE. The --name option must be
+     used to specify a short name for the new branch.
+
+  4. --list or -l: List all the branches owned by the current user in SOURCE. If
+     the --user option is specified with a list of users, list all the branches
+     owned by these users instead of the current user.
+
+  TARGET (and SOURCE) can be an URL or a Subversion working copy. Otherwise,
+  the current working directory must be a working copy. For --info and
+  --delete, the specified URL (or the URL of the working copy) must be a URL
+  under a valid branch in a standard FCM project. For --create and --list, it
+  must be a URL under a standard FCM project.
+
+Valid options with --info and --delete:
+  -v [--verbose]        : Print extra information.
+  -a [--show-all]       : Set --show-children, --show-other and --show-siblings.
+  --show-children       : Report children of the current branch.
+  --show-other          : Report custom/ reverse merges into the current branch.
+  --show-siblings       : Report merges with siblings of the current branch.
+
+Valid options with --delete and --create:
+  --non-interactive     : Do no interactive prompting. This option implies
+                          --svn-non-interactive.
+  --password arg        : Specify a password for write access to the repository.
+  --svn-non-interactive : Do no interactive prompting at commit time. This
+                          option is implied by --non-interactive.
+
+Valid options with --create and --list:
+  -r [--revision] arg   : Specify the operative revision of the SOURCE for
+                          creating the branch.
+
+Valid options with --create:
+  --branch-of-branch    : If this option is specified and the SOURCE is a
+                          branch, it will create a new branch from the SOURCE
+                          branch. Otherwise, the branch is created from the
+                          trunk.
+  -k [--ticket] arg     : Specify one (or more) Trac ticket. If specified, the
+                          command will add to the commit log the line "Relates
+                          to ticket #<ticket>". Multiple tickets can be set by
+                          specifying this option multiple times, or by
+                          specifying the tickets in a comma-separated list.
+  -n [--name] arg       : Specify a short name for the branch, which should
+                          contain only word characters, i.e. [A-Za-z0-9_].
+  --rev-flag arg        : Specify a flag for determining the prefix of the
+                          branch name. The flag can be the the string "NORMAL",
+                          "NUMBER" or "NONE".  "NORMAL" is the default
+                          behaviour, in which the branch name will be prefixed
+                          with a Subversion revision number if the revision is
+                          not associated with a registered FCM revision
+                          keyword. If the revision is registered with a FCM
+                          revision keyword, the keyword will be used in place
+                          of the number. If "NUMBER" is specified, the branch
+                          name will always be prefixed with a Subversion
+                          revision number. If "NONE" is specified, the branch
+                          name will not be prefixed by a revision number or
+                          keyword.
+  -t [--type] arg       : Specify the type of the branch to be created. It must
+                          be one of the following:
+                            DEV::USER   - a development branch for the user
+                            DEV::SHARE  - a shared development branch
+                            DEV         - same as DEV::USER
+                            TEST::USER  - a test branch for the user
+                            TEST::SHARE - a shared test branch
+                            TEST        - same as TEST::USER
+                            PKG::USER   - a package branch for the user
+                            PKG::SHARE  - a shared package branch
+                            PKG::CONFIG - a configuration branch
+                            PKG::REL    - a release branch
+                            PKG         - same as PKG::USER
+                            CONFIG      - same as PKG::CONFIG
+                            REL         - same as PKG::REL
+                            SHARE       - same as DEV::SHARE
+                            USER        - same as DEV::USER
+                          If not specified, the default is to create a
+                          development branch for the current user, i.e.
+                          DEV::USER.
+
+Valid options with --list:
+  -u [--user] arg       : Specify a colon-separated list of users. List branches
+                          owned by these users instead of the current user.
+  -v [--verbose]        : Print Subversion URL instead of FCM URL keywords.
+EOF
+
+  # Print usage message if requested
+  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
+    print $usage;
+    return 1;
+  }
+
+  # Process command line options
+  # ----------------------------------------------------------------------------
+  my (
+    $info,
+    $delete,
+    $create,
+    $list,
+    $branch_of_branch,
+    $name,
+    $non_interactive,
+    $password,
+    $rev,
+    $rev_flag,
+    $show_all,
+    $show_children,
+    $show_other,
+    $show_siblings,
+    $svn_non_interactive,
+    @tickets,
+    $type,
+    @userlist,
+    $verbose,
+  );
+  GetOptions (
+    'info|i'              => \$info,
+    'delete|d'            => \$delete,
+    'create|c'            => \$create,
+    'list|l'              => \$list,
+    'branch-of-branch'    => \$branch_of_branch,
+    'name|n=s'            => \$name,
+    'non-interactive'     => \$non_interactive,
+    'password=s'          => \$password,
+    'revision|r=s'        => \$rev,
+    'rev-flag=s'          => \$rev_flag,
+    'show-all|a'          => \$show_all,
+    'show-children'       => \$show_children,
+    'show-other'          => \$show_other,
+    'show-siblings'       => \$show_siblings,
+    'svn-non-interactive' => \$svn_non_interactive,
+    'ticket|k=s'          => \@tickets,
+    'type|t=s'            => \$type,
+    'user|u=s'            => \@userlist,
+    'verbose|v'           => \$verbose,
+  );
+
+  my $num_options = 0;
+  $num_options++ if defined $info;
+  $num_options++ if defined $delete;
+  $num_options++ if defined $create;
+  $num_options++ if defined $list;
+
+  # Report invalid usage
+  # ----------------------------------------------------------------------------
+  e_report $usage if $num_options > 1;
+
+  # Get URL of repository or branch
+  # ----------------------------------------------------------------------------
+  my $url;
+  if ($ARGV[0]) {
+    $url = Fcm::CmUrl->new (URL => $ARGV[0]);
+
+    if (not $url->is_url) {
+      # An argument is specified and is not a URL
+      # Assume that it is a path with a working copy
+      if (&is_wc ($ARGV[0])) {
+        $url = Fcm::CmUrl->new (URL => &get_url_of_wc ($ARGV[0]));
+
+      } else {
+        e_report $ARGV[0], ': is not a working copy, abort.';
+      }
+    }
+
+  } else {
+    # An argument is not specified
+    # Assume that the current directory is a working copy
+    if (&is_wc ()) {
+      $url = Fcm::CmUrl->new (URL => &get_url_of_wc ());
+
+    } else {
+      e_report 'The current directory is not a working copy, please specify a ',
+               'URL or a path to a working copy, abort.';
+    }
+  }
+
+  # Ensure $url->url_peg is a URL of a standard FCM project
+  e_report $url->url_peg, ': not a URL of a standard FCM project, abort.'
+    if not $url->project_url;
+
+  if ($create) {
+    # The --create option is specified, create a branch
+    # --------------------------------------------------------------------------
+
+    # Check branch type flags
+    if ($type) {
+      $type = uc ($type);
+
+      if ($type =~ /^(USER|SHARE)$/) {
+        $type = 'DEV::' . $1;
+
+      } elsif ($type =~ /^(CONFIG|REL)$/) {
+        $type = 'PKG::' . $1;
+
+      } elsif ($type =~ /^(DEV|TEST|PKG)$/) {
+        $type = $1 . '::USER';
+
+      } elsif ($type !~ /^(?:DEV|TEST|PKG)::(?:USER|SHARE)$/ and
+               $type !~ /^PKG::(?:CONFIG|REL)/) {
+        e_report $type, ': is not a valid type flag, abort.';
+      }
+
+    } else {
+      $type = 'DEV::USER';
+    }
+
+    # Check branch name
+    e_report 'The option --name must be used to specify a branch name, abort.'
+      if not $name;
+
+    e_report $name, ': invalid characters in name, abort.' if $name !~ /^\w+$/;
+
+    # Check revision flag is valid
+    if ($rev_flag) {
+      $rev_flag = uc ($rev_flag);
+
+      e_report $rev_flag, ': invalid argument to the --rev-flag option, abort.'
+        if $rev_flag !~ /^(?:NORMAL|NUMBER|NONE)$/;
+
+    } else {
+      $rev_flag = 'NORMAL';
+    }
+
+    # Handle multiple tickets
+    @tickets = split (/,/, join (',', @tickets));
+    s/^#// for (@tickets);
+    @tickets = sort {$a <=> $b} @tickets;
+
+    # Determine whether to create a branch of a branch
+    $url->branch ('trunk') unless $branch_of_branch;
+
+    # Create the branch
+    my $branch = Fcm::CmBranch->new;
+    $branch->create (
+      SRC                 => $url,
+      TYPE                => $type,
+      NAME                => $name,
+      PASSWORD            => $password,
+      REV_FLAG            => $rev_flag,
+      TICKET              => \@tickets,
+      REV                 => $rev,
+      NON_INTERACTIVE     => $non_interactive,
+      SVN_NON_INTERACTIVE => $svn_non_interactive,
+    );
+
+  } elsif ($list) {
+    # The option --list is specified
+    # List branches owned by current or specified users
+    # --------------------------------------------------------------------------
+    # Get URL of the project "branches/" sub-directory
+    $url->subdir ('');
+    $url->branch ('');
+    my @list = map {$_, 1} $url->branch_list ($rev);
+
+    if (@userlist) {
+      # Sort list of users
+      @userlist = sort (split /:/, join (':', @userlist));
+
+    } else {
+      # No user specified, add currrent user to list
+      push @userlist, $ENV{LOGNAME} unless @userlist;
+    }
+
+    # Filter branches matching user list
+    my @branches;
+    for my $branch (@list) {
+      next unless $branch =~ m#/([^/]+)/[^/]+/*$#;
+
+      my $user = $1;
+
+      push @branches, $branch if grep {$user eq $_} @userlist;
+    }
+
+    # Output, number of branches found
+    print scalar (@branches), ' ',
+          (scalar (@branches) > 1 ? 'branches' : 'branch'), ' found for ',
+          join (', ', @userlist), ' in ', $url->project_url_peg,
+          ($rev ? (' at r', $rev) : ()), "\n";
+
+    if (@branches) {
+      # Output the URL of each branch
+      if (not $verbose) {
+        my $project = $url->project_url;
+        my $keyword = &get_url_keyword (URL => $project);
+        @branches = map {s#^$project/+branches#$keyword-br#; $_} @branches
+          if defined $keyword;
+      }
+      @branches = map {$_ . "\n"} sort @branches;
+      print @branches;
+
+    } else {
+      # No branch found, exit with an error code
+      exit 1;
+    }
+
+  } else {
+    # The option --info or --delete is specified
+    # Report branch information (and/or delete a branch)
+    # --------------------------------------------------------------------------
+    # Set verbose level
+    &main::cfg->verbose ($verbose ? 1 : 0);
+
+    # Set up the branch, report any error
+    my $branch = Fcm::CmBranch->new (URL => $url->url_peg);
+    e_report $branch->url_peg, ': not a branch, abort.' unless $branch->branch;
+
+    e_report $branch->url_peg, ': does not exist, abort.'
+      unless $branch->url_exists;
+
+    # Remove the sub-directory part of the URL
+    $branch->subdir ('');
+
+    # Report branch info
+    $branch->display_info (
+      SHOW_CHILDREN => ($show_all || $show_children),
+      SHOW_OTHER    => ($show_all || $show_other   ),
+      SHOW_SIBLINGS => ($show_all || $show_siblings),
+    );
+
+    # Delete branch if --delete is specified
+    $branch->del (
+      PASSWORD            => $password,
+      NON_INTERACTIVE     => $non_interactive,
+      SVN_NON_INTERACTIVE => $svn_non_interactive,
+    ) if $delete;
+  }
+
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &Fcm::Cm::cm_commit ();
+#
+# DESCRIPTION
+#   This is a FCM wrapper to the "svn commit" command.
+# ------------------------------------------------------------------------------
+
+sub cm_commit {
+
+  # Print usage message if requested
+  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
+    print <<EOF;
+commit (ci): Send changes from your working copy to the repository.
+usage: fcm commit [PATH]
+
+  Invoke your favourite editor to prompt you for a commit log message. Send
+  changes from your working copy to the repository. Update your working copy
+  following the commit.
+
+Valid options:
+  --dry-run             : Allows you to add to the commit message without
+                          committing.
+  --svn-non-interactive : Do no interactive prompting at commit time.
+  --password arg        : Specify a password ARG.
+EOF
+    return 1;
+  }
+
+  my ($dry_run, $svn_non_interactive, $password);
+  GetOptions (
+    'dry-run'             => \$dry_run,
+    'svn-non-interactive' => \$svn_non_interactive,
+    'password'            => \$password,
+  );
+
+  # The remaining argument is the path to a working copy
+  my ($path) = @ARGV;
+
+  if ($path) {
+    # Check that specified path exists
+    e_report $path, ': does not exist, abort.' if not -e $path;
+
+  } else {
+    # No argument specified, use current working directory
+    $path = cwd ();
+  }
+
+  # Make sure we are in a working copy
+  e_report $path, ': not a working copy, abort.' if not &is_wc ($path);
+
+  # Make sure we are at the top level of the working copy
+  # (otherwise we might miss any template commit message)
+  my $dir = &get_wct ($path);
+
+  if ($dir ne cwd ()) {
+    chdir $dir or die 'Cannot change directory to: ', $dir;
+    print 'Committing changes from ', $dir, ' ...', "\n";
+  }
+
+  # Get update status of working copy
+  # Check working copy files are not in conflict, missing, or out of date
+  my @status = &run_command ([qw/svn status --show-updates/], METHOD => 'qx');
+  unless (defined $dry_run) {
+    my (@conflict, @missing, @outdate);
+
+    for (@status) {
+      if (/^C/) {
+        push @conflict, $_;
+        next;
+      }
+
+      if (/^!/) {
+        push @missing, $_;
+        next;
+      }
+
+      if (/^.{7}\*/) {
+        push @outdate, $_;
+        next;
+      }
+
+      # Check that all files which have been added have the svn:executable
+      # property set correctly (in case the developer adds a script before they
+      # remember to set the execute bit)
+      next unless /^A.{7} *\d+ +(.*)/;
+      my $file = $1;
+
+      next unless -f $file;
+      my @command = (-x $file)
+                    ? (qw/svn propset -q svn:executable */, $file)
+                    : (qw/svn propdel -q svn:executable/  , $file);
+      &run_command (\@command);
+    }
+
+    # Abort commit if files are in conflict, missing, or out of date
+    if (@conflict or @missing or @outdate) {
+      w_report 'File(s) in conflict:', "\n", @conflict if @conflict;
+      w_report 'File(s) missing:'    , "\n", @missing  if @missing;
+      w_report 'File(s) out of date:', "\n", @outdate  if @outdate;
+      e_report 'Abort commit.';
+    }
+  }
+
+  # Read in any existing message
+  my $ci_mesg = Fcm::CmCommitMessage->new ();
+  $ci_mesg->read_file;
+
+  # Execute "svn status" for a list of changed items
+  @status = grep !/^\?/, &run_command ([qw/svn status/], METHOD => 'qx');
+
+  # Abort if there is no change in the working copy
+  if (not @status) {
+    print 'No change in working copy, abort.', "\n";
+    return;
+  }
+
+  # Get associated URL of current working copy
+  my $url = Fcm::CmUrl->new (URL => &get_url_of_wc ());
+
+  # Include URL, or project, branch and sub-directory info in @status
+  unshift @status, "\n";
+
+  if ($url->project and $url->branch) {
+    unshift @status, (
+      '[Project: ' . $url->project                           . ']' . "\n",
+      '[Branch : ' . $url->branch                            . ']' . "\n",
+      '[Sub-dir: ' . ($url->subdir ? $url->subdir : '<top>') . ']' . "\n",
+    );
+
+  } else {
+    unshift @status, '[URL: ' . $url->url . ']' . "\n";
+  }
+
+  # Use a temporary file to store the final commit log message
+  $ci_mesg->ignore_mesg (@status);
+  my $logfile = $ci_mesg->edit_file (TEMP => 1);
+
+  # Check with the user to see if he/she wants to go ahead
+  my $reply = 'n';
+  if (not defined $dry_run) {
+    # Add extra warning for trunk commit
+    my $mesg = $url->is_trunk
+      ? "\n" .
+        '*** WARNING: YOU ARE COMMITTING TO THE TRUNK.' . "\n" .
+        '*** Please ensure that your change conforms to your project\'s ' .
+        'working practices.' . "\n\n"
+      : '';
+    $mesg   .= 'Would you like to commit this change?';
+
+    # Prompt the user
+    $reply = &main::get_input (
+      TITLE   => 'fcm commit',
+      MESSAGE => $mesg,
+      TYPE    => 'yn',
+      DEFAULT => 'n',
+    );
+  }
+
+  if ($reply eq 'y') {
+    # Commit the change if user replies "y" for "yes"
+    my @command = (
+      qw/svn commit -F/, $logfile,
+      ($svn_non_interactive  ? '--non-interactive'       : ()),
+      (defined $password     ? ('--password', $password) : ()),
+    );
+    my $rc;
+    &run_command (\@command, RC => \$rc, ERROR => 'warn');
+
+    if ($rc) {
+      # Commit failed
+      # Write temporary commit log content to commit log message file
+      $ci_mesg->write_file;
+
+      # Fail the command
+      e_report;
+    }
+
+    # Remove commit message file
+    unlink $ci_mesg->file;
+
+    # Update the working copy
+    print 'Performing update to make sure your working copy is at this new ',
+          'revision ...', "\n";
+    &run_command ([qw/svn update/]);
+
+  } else {
+    # Abort commit if dry run or user replies "n" for "no"
+    w_report 'Commit aborted by user.' unless $dry_run;
+
+    # Write temporary commit log content to commit log message file
+    $ci_mesg->write_file;
+  }
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &Fcm::Cm::cm_conflicts ();
+#
+# DESCRIPTION
+#   This is a FCM command for resolving conflicts within working copy using a
+#   graphical merge tool.
+# ------------------------------------------------------------------------------
+
+sub cm_conflicts {
+
+  # Print usage message if requested
+  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
+    print <<EOF;
+conflicts: Use graphical tool to resolve any conflicts within your working copy.
+usage: fcm conflicts [PATH]
+
+  Invoke the xxdiff graphical merge tool to help you resolve conflicts in your
+  working copy. It prompts you to run "svn resolved" each time you have
+  resolved the conflicts in a file.
+EOF
+    return 1;
+  }
+
+  # Path to the working copy
+  my $path = $ARGV[0];
+  $path    = cwd () if not $path;
+
+  # Check for any files with conflicts
+  my @status = grep /^C.{4} *(.*)/, &run_command (
+    [qw/svn st/, ($path eq cwd () ? () : $path)], METHOD => 'qx',
+  );
+  my @files  = map {m/^C.{4} *(.*)/; $1} @status;
+
+  # Save current working directory
+  my $topdir = cwd ();
+
+  for my $file (@files) {
+    # Print name of file in conflicts
+    print "Conflicts in file: $file\n";
+
+    # Determine directory and base name of file in conflicts
+    my $base = basename $file;
+    my $dir  = dirname $file;
+
+    # Change to container directory of file in conflicts
+    chdir File::Spec->catfile ($topdir, $dir) or die "Directory change to $dir failed";
+
+    # Use "svn info" to determine conflict marker files
+    my @info = &run_command ([qw/svn info/, $base], METHOD => 'qx');
+
+    # Ignore if $base is a binary file
+    if (-B $base) {
+      w_report $base,
+               ': ignoring binary file, please resolve conflicts manually.';
+      next;
+    }
+
+    # Get conflicts markers files
+    my ($older, $mine, $yours);
+
+    for (@info) {
+      $older = $1 if (/^Conflict Previous Base File: (.*)/);
+      $mine  = $1 if (/^Conflict Previous Working File: (.*)/);
+      $yours = $1 if (/^Conflict Current Base File: (.*)/);
+    }
+
+    if ((stat $base)[9] > (stat $mine)[9]) {
+      # If $base is newer, it may contain saved changes
+      my $reply = &main::get_input (
+        TITLE   => 'fcm conflicts',
+        MESSAGE => 'Existing changes in ' . $base . ' will be overwritten.' .
+                   "\n" . 'Do you wish to continue?',
+        TYPE    => 'yn',
+        DEFAULT => 'n',
+      );
+
+      next if $reply ne 'y';
+    }
+
+    # Launch "xxdiff" to allow user to perform graphical merging
+    my $xxdiffrc;
+    my @command  = (qw/xxdiff -m -M/, $base, qw/-O -X/, $mine, $older, $yours);
+    my ($decision) = &run_command (
+      \@command, METHOD => 'qx', RC => \$xxdiffrc, ERROR => 'ignore',
+    );
+    die &get_command_string (\@command), ' failed' if $xxdiffrc and ! $decision;
+    chomp $decision;
+
+    # Perform different actions depending on the user's decision
+    if ($decision eq "NODECISION") {
+      print "No decision taken\n";
+
+    } elsif ($decision eq "MERGED" and $xxdiffrc != 0) {
+      print "Merge conflicts were not all resolved\n";
+
+    } else {
+      # User has MERGED, ACCEPTED or REJECTED all changes
+      if ($decision eq "MERGED") {
+        print "All merge conflicts resolved\n";
+
+      } else {
+        print "You have chosen to $decision all the changes\n";
+      }
+
+      # Prompt user to run "svn resolved" on the file
+      my $reply = &main::get_input (
+        TITLE   => 'fcm conflicts',
+        MESSAGE => 'Would you like to run "svn resolved"?',
+        TYPE    => 'yn',
+        DEFAULT => 'n',
+      );
+
+      # If reply is "yes"...
+      &run_command ([qw/svn resolved/, $base]) if $reply eq 'y';
+    }
+  }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &Fcm::Cm::cm_delete ();
+#
+# DESCRIPTION
+#   This is a wrapper to "svn delete". It adds an extra functionality to check
+#   for any files or directories reported by "svn status" as missing, and to
+#   prompt the user whether these files or directories should be deleted.
+# ------------------------------------------------------------------------------
+
+sub cm_delete {
+
+  # Print usage message if requested
+  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
+    print <<EOF;
+usage: fcm delete [options] [args]
+
+Valid options:
+  -c [--check]  : Check for any files or directories reported by svn status as
+                  missing and delete them.
+  <SVN options> : Standard options to svn delete as described below ...
+
+EOF
+
+    &run_command ([qw/svn delete --help/], PRINT => 1, METHOD => 'exec');
+  }
+
+  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--check -c)) {
+    # The --check option is specified, delete any missing files
+    # Execute "svn status", print lines starting with a "!"
+    my $pat    = '^!.{4}\s*';
+    my @status = grep /$pat.*/, &run_command ([qw/svn status/], METHOD => 'qx');
+    print @status if @status;
+
+    # Get list of "!" files
+    my @files  = map {chomp; s/$pat//; $_} @status;
+    my $reply  = '';
+
+    # Execute "delete" command depending on user reply
+    for my $file (@files) {
+      # Get a user reply, unless previous reply is "a" for "all"
+      $reply = &main::get_input (
+        TITLE   => 'fcm delete',
+        MESSAGE => "Delete file '$file'?",
+        TYPE    => 'yna',
+        DEFAULT => 'n',
+      ) unless $reply eq "a";
+
+      # Delete current $file if reply is "y" for "yes" or "a" for "all"
+      &run_command ([qw/svn delete/, $file]) if $reply =~ /^[ya]$/;
+    }
+
+  } else {
+    # The --check option is not specified, just call "svn delete"
+    cm_svn ("delete");
+  }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &Fcm::Cm::cm_diff ();
+#
+# DESCRIPTION
+#   This is a wrapper to "svn diff". It adds two extra functionalities. The
+#   first one allows the command to show differences relative to the base of
+#   the branch. The second one allows differences to be displayed via a
+#   graphical tool.
+# ------------------------------------------------------------------------------
+
+sub cm_diff {
+
+  # Print usage message if requested
+  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
+    print <<EOF;
+usage: 1. fcm diff --branch [OPTIONS] [TARGET]
+       2. fcm diff [OPTIONS] [ARGS]
+
+  1. --branch or -b: Show differences relative to the base of the target branch,
+     i.e. the changes available for merging from the target branch into its
+     parent. If TARGET is specified, it must either be a URL or a working copy.
+     Otherwise, the target is the the current directory which must be a working
+     copy. The target URL must be a branch in a standard FCM project.
+
+  2. See description of "svn diff" below.
+
+Valid options:
+  -g [--graphical] : Use a graphical diff tool to display the differences. This
+                     option should not be used in combination with --diff-cmd.
+  <SVN options>    : Standard options to "svn diff" as described below.
+
+Valid options with --branch:
+  --diff-cmd arg        : As described below in the help for "svn diff".
+  -g [--graphical]      : As described above.
+  -t [--trac]           : If TARGET is a URL, use Trac to display the diff.
+  --wiki                : If TARGET is a URL, print Trac link for the diff.
+  -x [--extensions] arg : As described below in the help for "svn diff".
+
+EOF
+
+    &run_command ([qw/svn diff --help/], PRINT => 1, METHOD => 'exec');
+  }
+
+  # Set up environment for graphical diff
+  # Use environment variable if set, otherwise use default setting
+  my $env = 'FCM_GRAPHIC_DIFF';
+  $ENV{$env} = &main::cfg->setting (qw/TOOL GRAPHIC_DIFF/)
+    unless exists $ENV{$env} or not &main::cfg->setting (qw/TOOL GRAPHIC_DIFF/);
+
+  # Check for the --branch options
+  # ----------------------------------------------------------------------------
+  my $branch = grep {$_ eq '-b' or $_ eq '--branch'} @ARGV;
+
+  if (not $branch) {
+    # The --branch option not specified, just call "svn diff"
+    # Convert the --graphical to qw/--diff-cmd fcm_graphical_diff/
+    @ARGV = map {
+      ($_ eq '-g' or $_ eq '--graphical')
+      ? (qw/--diff-cmd fcm_graphic_diff/)
+      : $_
+    } @ARGV;
+
+    # Execute the command
+    cm_svn ('diff');
+  }
+
+  # The --branch option is specified
+  # ----------------------------------------------------------------------------
+
+  # Determine whether the --graphical option is specified,
+  # if so set the appropriate command
+  # ----------------------------------------------------------------------------
+  my ($diff_cmd, $extensions, $graphical, $trac, $wiki);
+  GetOptions (
+    'b|branch'       => \$branch,
+    'diff-cmd=s'     => \$diff_cmd,
+    'x|extensions=s' => \$extensions,
+    'g|graphical'    => \$graphical,
+    't|trac'         => \$trac,
+    'wiki'           => \$wiki,
+  );
+
+  my @diff_cmd = ();
+  
+  if ($graphical) {
+    @diff_cmd = (qw/--diff-cmd fcm_graphic_diff/);
+
+  } elsif ($diff_cmd) {
+    @diff_cmd = ('--diff-cmd', $diff_cmd);
+
+    push @diff_cmd, '--extensions', split (/\s+/, $extensions) if $extensions;
+  }
+
+  # The remaining argument should either be a URL or a PATH
+  my ($url_arg, $path_arg);
+
+  if (@ARGV) {
+    my $arg = Fcm::CmUrl->new (URL => $ARGV[0]);
+
+    if ($arg->is_url) {
+      $url_arg = $ARGV[0];
+
+    } else {
+      $path_arg = $ARGV[0];
+    }
+  }
+
+  # Get repository and branch information
+  # ----------------------------------------------------------------------------
+  my ($url, $path);
+  if (defined $url_arg) {
+    # If a URL is specified, get repository and branch information from it
+    $url = Fcm::CmBranch->new (URL => $url_arg);
+
+  } else {
+    # Get repository and branch information from the specified path or the
+    # current directory if it is a working copy
+    $path = $path_arg ? $path_arg : cwd ();
+    e_report $path, ': not a working copy, abort.' unless &is_wc ($path);
+
+    $url  = Fcm::CmBranch->new (URL => &get_url_of_wc ($path));
+  }
+
+  # Check that URL is a standard FCM branch
+  e_report $url->url_peg, ': not a standard FCM branch, abort.'
+    unless $url->is_branch;
+
+  # Save and remove sub-directory part of the URL
+  my $subdir = $url->subdir ();
+  $url->subdir ('');
+
+  # Check that $url exists
+  e_report $url->url_peg, ': not a valid URL, abort.' unless $url->url_exists;
+
+  # Compare current branch with its parent
+  # ----------------------------------------------------------------------------
+  my $parent = Fcm::CmBranch->new (URL => $url->parent->url);
+  $parent->pegrev ($url->pegrev) if $url->pegrev;
+
+  e_report $parent->url, ': branch parent no longer exists',
+           ($parent->pegrev ? ' at ' . $parent->pegrev : ''), ', abort.'
+    unless $parent->url_exists;
+
+  my $base = $parent->base_of_merge_from ($url);
+
+  # Ensure the correct diff (syntax) is displayed
+  # ----------------------------------------------------------------------------
+  # Reinstate the sub-tree part into the URL
+  $url->subdir ($subdir);
+  $base->subdir ($subdir);
+
+  # Ensure the branch URL has a peg revision
+  $url->pegrev ($url->svninfo (FLAG => 'Last Changed Rev')) if not $url->pegrev;
+
+  if ($trac or $wiki) {
+    # Trac/wiki
+    # --------------------------------------------------------------------------
+    if (not $url_arg) {
+      if (&run_command ([qw/svn status/], METHOD => 'qx')) {
+        w_report 'WARNING: the working copy at "', ($path_arg ? $path_arg : '.'),
+                 '" contains local changes, which cannot be displayed in Trac.';
+      }
+    }
+
+    # Trac wiki syntax
+    my $wiki_syntax = 'diff:' . $base->path_peg . '//' . $url->path_peg;
+
+    if ($wiki) {
+      # Print Trac wiki syntax only
+      print $wiki_syntax, "\n";
+
+    } else { # if $trac
+      # Use Trac to view "diff"
+      my $browser  = &main::cfg->setting (qw/MISC WEB_BROWSER/);
+      die 'ERROR: web browser not set, abort' if not $browser;
+
+      my $trac_url = &get_browser_url (URL => $url->project_url);
+      e_report 'ERROR: ', $url->project_url,
+               ': not associated with a Trac URL, abort.'
+        if not $trac_url;
+
+      $trac_url =~ s#/browser/.*$#/intertrac/$wiki_syntax#;
+
+      &run_command ([$browser, $trac_url], METHOD => 'exec', PRINT => 1);
+    }
+
+  } else {
+    # Execute the "diff" command
+    # --------------------------------------------------------------------------
+    my @command = (
+      qw/svn diff/, @diff_cmd,
+      '--old', $base->url_peg,
+      '--new', ($url_arg ? $url->url_peg : ($path_arg ? $path_arg : '.')),
+    );
+    &run_command (\@command, PRINT => 1);
+  }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &Fcm::Cm::cm_merge ();
+#
+# DESCRIPTION
+#   This is a wrapper to "svn merge".
+# ------------------------------------------------------------------------------
+
+sub cm_merge {
+
+  # Print usage message if requested
+  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
+    print <<EOF;
+merge: Merge changes from a source into your working copy.
+usage: 1. fcm merge SOURCE
+       2. fcm merge --custom  --revision N[:M] SOURCE
+          fcm merge --custom  URL[\@REV1] URL[\@REV2]
+       3. fcm merge --reverse --revision [M:]N
+
+  1. If neither --custom nor --reverse is specified, the command merges changes
+     automatically from SOURCE into your working copy. SOURCE must be a valid
+     URL[\@REV] of a branch in a standard FCM project. The base of the merge
+     will be calculated automatically based on the common ancestor and latest
+     merge information between the SOURCE and the branch of the working copy.
+
+  2. If --custom is specified, the command can be used in two forms.
+  
+     In the first form, it performs a custom merge from the specified
+     changeset(s) of SOURCE into your working copy. SOURCE must be a valid
+     URL[\@REV] of a branch in a standard FCM project. If a single revision is
+     specified, the merge delta is (N - 1):N of SOURCE. Otherwise, the merge
+     delta, is N:M of SOURCE, where N < M.
+     
+     In the second form, it performs a custom merge using the delta between the
+     two specified branch URLs. For each URL, if a peg revision is not
+     specified, the command will peg the URL with its last changed revision.
+
+  3. If --reverse is specified, the command performs a reverse merge of the
+     changeset(s) specified by the --revision option. If a single revision is
+     specified, the merge delta is N:(N - 1). Otherwise, the merge delta is
+     M:N, where M > N. Note that you do not have to specify a SOURCE for a
+     reverse merge, because the SOURCE should always be the branch your working
+     copy is pointing to.
+  
+  The command provide a commit log message template following the merge.
+
+Valid options:
+  --dry-run          : Try operation but make no changes.
+  --non-interactive  : Do no interactive prompting.
+  -r [--revision] arg: Specify a (range of) revision number(s).
+  --verbose          : Print extra information.
+EOF
+    return 1;
+  }
+
+  # Options
+  # ----------------------------------------------------------------------------
+  my ($custom, $dry_run, $non_interactive, $reverse, $rev, $verbose);
+  GetOptions (
+    'custom'          => \$custom,
+    'dry-run'         => \$dry_run,
+    'non-interactive' => \$non_interactive,
+    'reverse'         => \$reverse,
+    'revision|r=s'    => \$rev,
+    'verbose|v'       => \$verbose,
+  );
+
+  # Find out the URL of the working copy
+  # ----------------------------------------------------------------------------
+  my ($target, $wct);
+  if (&is_wc ()) {
+    $wct = &get_wct ();
+
+    if ($wct ne cwd ()) {
+      print 'Change directory to top of working copy: ', $wct, "\n";
+      chdir $wct or die 'Cannot change directory to: ', $wct;
+    }
+
+    $target = Fcm::CmBranch->new (URL => &get_url_of_wc ($wct));
+
+  } else {
+    e_report 'The current directory is not a working copy, abort.';
+  }
+
+  e_report 'Your working copy URL does not exist at the HEAD revision, abort.'
+    unless $target->url_exists;
+
+  # The target must be at the top of a branch
+  # $subdir will be used later to determine whether the merge is allowed or not
+  my $subdir = $target->subdir;
+  $target->subdir ('') if $subdir;
+
+  # Check for any local modifications
+  # ----------------------------------------------------------------------------
+  return
+    if ! ($dry_run or $non_interactive) and &_abort_modified_wc ('fcm merge');
+
+  # Determine the SOURCE URL
+  # ----------------------------------------------------------------------------
+  my $source;
+
+  if ($reverse) {
+    # Reverse merge, the SOURCE is the the working copy URL
+    $source = Fcm::CmBranch->new (URL => $target->url);
+
+  } else {
+    # Automatic/custom merge, argument 1 is the SOURCE of the merge
+    my $source_url = shift (@ARGV);
+    e_report 'Error: argument 1 must be the URL/name of a source branch in ',
+             'automatic/custom mode, abort.'
+      if not $source_url;
+
+    $source = &_construct_branch_url ($source_url, $target);
+  }
+
+  # Parse the revision option
+  # ----------------------------------------------------------------------------
+  my @revs;
+  if ($reverse or $custom) {
+    if ($reverse and not $rev) {
+      e_report 'Error: a revision (range) must be specified with ',
+               '--revision in reverse mode, abort.'
+    }
+
+    @revs = split (/:/, $rev) if $rev;
+  }
+
+  # Determine the merge delta and the commit log message
+  # ----------------------------------------------------------------------------
+  my (@delta, $mesg);
+  my $separator = '-' x 80 . "\n";
+
+  if ($reverse) {
+    # Reverse merge
+    # --------------------------------------------------------------------------
+    if (@revs == 1) {
+      $revs[1] = ($revs[0] - 1);
+
+    } else {
+      @revs = sort {$b <=> $a} @revs;
+    }
+
+    $source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev'))
+      unless $source->pegrev;
+    $source->subdir ($subdir);
+
+    # "Delta" of the "svn merge" command
+    @delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg);
+
+    # Template message
+    $mesg = 'Reversed r' . $revs[0] .
+            (($revs[1] < $revs[0] - 1) ? ':' . $revs[1] : '') . ' of ' .
+            $source->path . "\n";
+
+  } elsif ($custom) {
+    # Custom merge
+    # --------------------------------------------------------------------------
+    if (@revs) {
+      # Revision specified
+      # ------------------------------------------------------------------------
+      # Only one revision N specified, use (N - 1):N as the delta
+      unshift @revs, ($revs[0] - 1) if @revs == 1;
+
+      $source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev'))
+        unless $source->pegrev;
+      $source->subdir ($subdir);
+      $target->subdir ($subdir);
+
+      # "Delta" of the "svn merge" command
+      @delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg);
+
+      # Template message
+      $mesg = 'Custom merge into ' . $target->path . ': r' . $revs[1] .
+              ' cf. r' . $revs[0] . ' of ' . $source->path_peg . "\n";
+
+    } else {
+      # Revision not specified
+      # ------------------------------------------------------------------------
+      # Get second source URL
+      my $source2_url = shift (@ARGV);
+      e_report 'Error: argument 2 must be the URL/name of a source branch in ',
+               'custom mode when --revision is not specified, abort.'
+        if not $source2_url;
+
+      my $source2 = &_construct_branch_url ($source2_url, $target);
+
+      $source->pegrev  ($source->svninfo  (FLAG => 'Last Changed Rev'))
+        unless $source->pegrev;
+      $source2->pegrev ($source2->svninfo (FLAG => 'Last Changed Rev'))
+        unless $source2->pegrev;
+      $source->subdir  ($subdir);
+      $source2->subdir ($subdir);
+      $target->subdir  ($subdir);
+
+      # "Delta" of the "svn merge" command
+      @delta = ($source->url_peg, $source2->url_peg);
+
+      # Template message
+      $mesg = 'Custom merge into ' . $target->path . ': ' . $source->path_peg .
+              ' cf. ' . $source2->path_peg . "\n";
+    }
+
+  } else {
+    # Automatic merge
+    # --------------------------------------------------------------------------
+    # Check to ensure source branch is not the same as the target branch
+    e_report 'Error: cannot merge ', $source->branch,
+             ' to its own working copy, abort.'
+      if $source->branch eq $target->branch;
+
+    # Only allow the merge if the source and target are "directly related"
+    # --------------------------------------------------------------------------
+    my $anc = $target->ancestor ($source);
+    e_report 'Error: source and target are not directly related' unless
+      ($anc->url eq $target->url and $anc->url_peg eq $source->parent->url_peg)
+      or
+      ($anc->url eq $source->url and $anc->url_peg eq $target->parent->url_peg)
+      or
+      ($anc->url eq $source->parent->url and $anc->url eq $target->parent->url);
+
+    # Check for available merges from the source
+    # --------------------------------------------------------------------------
+    my @revs = $target->avail_merge_from ($source, 1);
+
+    if (@revs) {
+      print 'Available Merge', (@revs > 1 ? 's' : ''), ' From ',
+            $source->path_peg, ':';
+
+      if ($verbose) {
+        # Verbose mode, print log messages of available merges
+        print "\n";
+
+        for (@revs) {
+          print $separator, $source->display_svnlog ($_);
+        }
+
+        print $separator;
+
+      } else {
+        # Normal mode, list revisions of available merges
+        print ' ', join (' ', @revs), "\n";
+      }
+
+    } else {
+      w_report 'No merge available from ', $source->path_peg, ', abort.';
+      return;
+    }
+
+    # If more than one merge available, prompt user to enter a revision number
+    # to merge from, default to $revs [0]
+    # --------------------------------------------------------------------------
+    my $reply = ($non_interactive or @revs == 1) ? $revs[0] : &main::get_input (
+      TITLE   => 'fcm merge',
+      MESSAGE => 'Please enter the revision you wish to merge from',
+      DEFAULT => $revs [0],
+    );
+
+    if (not defined ($reply)) {
+      w_report 'Merge aborted by user.';
+      return;
+    }
+
+    # Expand revision keyword if necessary
+    if ($reply) {
+      $reply = expand_rev_keyword (REV => $reply, URL => $target->project_url);
+    }
+
+    # Check that the reply is a number in the available merges list
+    e_report $reply, ': not a revision in the list of available merges.'
+      unless (grep {$_ == $reply} @revs);
+
+    $source->pegrev ($1) if ($reply =~ /^(\d+)/);
+
+    # If the working copy top is pointing to a sub-directory of a branch,
+    # we need to check whether the merge will result in losing changes made in
+    # other sub-directories of the source.
+    if ($subdir and not $target->allow_subdir_merge_from ($source, $subdir)) {
+      e_report 'SOURCE contains changes outside the current sub-directory.', "\n",
+               'Please use a full tree for the merge, abort.';
+    }
+
+    # Calculate the base of the merge
+    my $base = $target->base_of_merge_from ($source);
+
+    # $source and $base must take into account the sub-directory
+    my $s = Fcm::CmBranch->new (URL => $source->url_peg);
+    my $b = Fcm::CmBranch->new (URL => $base->url_peg);
+
+    $s->subdir ($subdir) if $subdir;
+    $b->subdir ($subdir) if $subdir;
+
+    # Diagnostic
+    print 'About to merge in changes from ', $s->path_peg, ' compared with ',
+          $b->path_peg, "\n";
+
+    # Delta of the "svn merge" command
+    @delta = ($b->url_peg, $s->url_peg);
+
+    # Template message
+    $mesg = 'Merged into ' . $target->path . ': ' . $source->path_peg .
+            ' cf. ' . $base->path_peg . "\n";
+  }
+
+  # Run "svn merge" in "--dry-run" mode to see the result
+  # ----------------------------------------------------------------------------
+  my @out   = &run_command (
+    [qw/svn merge --dry-run/, @delta],
+    METHOD => 'qx', PRINT => ($dry_run and $verbose),
+  );
+
+  # Abort merge if it will result in no change
+  if (not @out) {
+    print 'This merge will not result in any change, abort.', "\n";
+    return;
+  }
+
+  # Report result of "svn merge --dry-run"
+  if (not $non_interactive) {
+    print 'This merge will result in the following change',
+          (@out > 1 ? 's' : ''), ':', "\n";
+    print $separator, @out, $separator;
+  }
+
+  return if $dry_run;
+
+  # Prompt the user to see if (s)he would like to go ahead
+  # ----------------------------------------------------------------------------
+  my $reply = $non_interactive ? 'y' : &main::get_input (
+    TITLE   => 'fcm merge',
+    MESSAGE => 'Would you like to go ahead with the merge?',
+    TYPE    => 'yn',
+    DEFAULT => 'n',
+  );
+
+  # Go ahead with merge only if user replies "y"
+  if ($reply eq "y") {
+    print "Performing merge ...\n";
+    &run_command ([qw/svn merge/, @delta], PRINT => $verbose);
+
+  } else {
+    w_report 'Merge aborted by user.';
+    return;
+  }
+
+  # Prepare the commit log
+  # ----------------------------------------------------------------------------
+  # Read in any existing message
+  my $ci_mesg = Fcm::CmCommitMessage->new;
+  $ci_mesg->read_file;
+  $ci_mesg->auto_mesg ($mesg, ($ci_mesg->auto_mesg));
+  $ci_mesg->write_file;
+
+  if ($verbose) {
+    print <<EOF;
+${separator}The following line has been added to your commit message file:
+$mesg
+EOF
+  }
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &Fcm::Cm::cm_mkpatch ();
+#
+# DESCRIPTION
+#   This is a FCM command to create a patching script from particular revisions
+#   of a URL.
+# ------------------------------------------------------------------------------
+
+sub cm_mkpatch {
+  my $usage = <<EOF;
+mkpatch: Create patches from specified revisions of a URL
+usage: fcm mkpatch [OPTIONS] URL [OUTDIR]
+
+  URL must be the URL of a branch in a FCM project. If the URL is a
+  sub-directory of a branch, it will use the root of the branch.
+
+  Create patches from specified revisions of the specified URL. If OUTDIR is
+  specified, the output is sent to OUTDIR. Otherwise, the output will be sent
+  to a default location in the current directory (\$PWD/fcm-mkpatch-out). The
+  output directory will contain the patch for each revision as well as a script
+  for importing the patch.
+
+  If a revision is specified with the --revision option, it will attempt to
+  create a patch based on the changes at that revision. If a revision is not
+  specified, it will attempt to create a patch based on the changes at the HEAD
+  revision. If a revision range is specified, it will attempt to create a patch
+  for each revision in that range (including the change in the lower range)
+  where changes have taken place in the URL. No output will be written if there
+  is no change in the given revision (range).
+
+  The --exclude option can be used to exclude a path in the URL. The specified
+  path must be a relative path of the URL. Glob patterns such as * and ? are
+  acceptable. Changes in an excluded path will not be considered in the patch.
+  A changeset containing changes only in the excluded path will not be
+  considered at all.
+
+  The --organisation option can be used to specify the name of your
+  organisation. The command will attempt to parse the commit log message for
+  each revision in the patch. It will remove all merge templates, replace links
+  to Trac tickets with a simple string, and add information about the original
+  changeset. If you specify the name of your organisation, it will replace Trac
+  ticket links such as "ticket:123" to "Original \$organisation ticket 123",
+  and report the orginal changeset with a message such as "Original
+  \$organisation changeset 1000". Otherwise, it will report without the
+  organisation name, e.g. "Original ticket 123" and "Original  changeset 1000".
+
+Valid options:
+  --exclude       arg : Exclude a path in the URL. Multiple paths can be
+                        specified by using a colon-separated list of paths, or
+                        by specifying this option multiple times.
+  --organisation  arg : Specify the name of your organisation.
+  -r [--revision] arg : Specify a revision number or a revision number range.
+EOF
+
+  # Print usage message if requested
+  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
+    print $usage;
+    return 1;
+  }
+
+  # Process command line options and arguments
+  # ----------------------------------------------------------------------------
+  my (@exclude, $organisation, $revision);
+  GetOptions (
+    'exclude=s'      => \@exclude,
+    'organisation=s' => \$organisation,
+    'r|revision=s'   => \$revision,
+  );
+
+  # Excluded paths, convert glob into regular patterns
+  @exclude = split (/:/, join (':', @exclude));
+  for (@exclude) {
+    s#\*#[^/]*#; # match any number of non-slash character
+    s#\?#[^/]#;  # match a non-slash character
+    s#/*$##;     # remove trailing slash
+  }
+
+  # Organisation prefix
+  $organisation = $organisation ? $organisation : 'original';
+
+  # Make sure revision option is set correctly
+  my @revs = $revision ? split (/:/, $revision) : ();
+  @revs    = @revs [0, 1] if @revs > 2;
+
+  # Arguments
+  my ($u, $outdir) = @ARGV;
+
+  if (not $u) {
+    print $usage;
+    return 1;
+  }
+
+  my $url = Fcm::CmUrl->new (URL => $u);
+  e_report $u, ': URL is not a URL, abort.' if not $url->is_url;
+  e_report $u, ': URL does not exist, abort.' if not $url->url_exists;
+  e_report $u, ': URL is not a valid branch in a FCM project, abort.'
+    if not $url->branch;
+
+  $url->subdir ('');
+
+  if (@revs) {
+    # If HEAD revision is given, convert it into a number
+    # --------------------------------------------------------------------------
+    for my $rev (@revs) {
+      $rev = $url->svninfo (FLAG => 'Revision') if uc ($rev) eq 'HEAD';
+    }
+
+  } else {
+    # If no revision is given, use the HEAD
+    # --------------------------------------------------------------------------
+    $revs[0] = $url->svninfo (FLAG => 'Revision');
+  }
+
+  $revs[1] = $revs[0] if @revs == 1;
+
+  # Check that output directory is set
+  # ----------------------------------------------------------------------------
+  $outdir = File::Spec->catfile (cwd (), 'fcm-mkpatch-out') if not $outdir;
+
+  if (-e $outdir) {
+    # Ask user to confirm removal of old output directory if it exists
+    my $reply = &main::get_input (
+      TITLE   => 'fcm mkpatch',
+      MESSAGE => 'Output location ' . $outdir . ' exists. OK to overwrite?',
+      TYPE    => 'yn',
+      DEFAULT => 'n',
+    );
+
+    if ($reply ne 'y') {
+      w_report 'fcm mkpatch: command aborted by user.';
+      return 1;
+    }
+
+    rmtree $outdir or die $outdir, ': cannot remove';
+  }
+
+  # (Re-)create output directory
+  mkpath $outdir or die $outdir, ': cannot create';
+  print 'Output directory: ', $outdir, "\n";
+
+  # Get and process log of URL
+  # ----------------------------------------------------------------------------
+  my @script     = (); # output script, from the log
+  my %log        = $url->svnlog (REV => \@revs);
+  my $url_path   = $url->path;
+  my $file_count = 0;
+
+  for my $rev (sort {$a <=> $b} keys %log) {
+    # Look at the changed paths for each revision
+    my @paths;
+
+    # Skip excluded paths if necessary
+    PATH: for my $path (sort keys %{ $log{$rev}{paths} }) {
+      for my $exclude (@exclude) {
+        (my $file = $path) =~ s#^$url_path/*##;
+
+        next PATH if $file =~ m#^$exclude(?:/*|$)#;
+      }
+
+      push @paths, $path;
+    }
+
+    next unless @paths;
+
+    # Parse commit log message
+    my @msg = split /\n/, $log{$rev}{msg};
+    for (@msg) {
+      # Re-instate line break
+      $_ .= "\n";
+
+      # Remove line if it matches a merge template
+      $_ = '' if /^Reversed r\d+(?::\d+)? of \S+$/;
+      $_ = '' if /^Custom merge into \S+:.+$/;
+      $_ = '' if /^Merged into \S+: \S+ cf\. \S+$/;
+
+      # Modify Trac ticket link
+      s/(?:#|ticket:)(\d+)/[$organisation ticket $1]/g;
+
+      # Modify Trac changeset link
+      s/(?:r|changeset:)(\d+)/[$organisation changeset $1]/g;
+      s/\[(\d+)\]/[$organisation changeset $1]/g;
+    }
+
+    push @msg, '[' . $organisation . ' changeset ' . $rev . ']' . "\n";
+
+    # Write commit log message in a file
+    my $f_revlog = File::Spec->catfile ($outdir, $rev . '-log');
+    open FILE, '>', $f_revlog or die $f_revlog, ': cannot open (', $!, ')';
+    print FILE @msg;
+    close FILE or die $f_revlog, ': cannot close (', $!, ')';
+
+    # Create a directory for this revision in the output directory
+    my $outdir_rev = File::Spec->catfile ($outdir, $rev);
+    mkpath $outdir_rev or die $outdir_rev, ': cannot create';
+
+    # Handle modified/copy/new path, export the path, + script to copy/add it
+    for my $path (@paths) {
+      next unless $log{$rev}{paths}{$path}{action} =~ /^[AMR]$/;
+
+      (my $file = $path) =~ s#^$url_path/*##;
+
+      # Download the file using "svn export"
+      my $patch    = File::Spec->catfile ($outdir_rev, $file_count++);
+      my $url_file = $url->url . '/' . $file . '@' . $rev;
+      &run_command ([qw/svn export -q -r/, $rev, $url_file, $patch]);
+
+      (my $patch_path = $patch) =~ s#^$outdir/*##;
+
+      # Script to copy the file, if required
+      my $is_newfile = 0;
+      if ($log{$rev}{paths}{$path}{action} eq 'A') {
+        if (exists $log{$rev}{paths}{$path}{'copyfrom-path'}) {
+          # History exists for this file
+          my $copyfrom_path = $log{$rev}{paths}{$path}{'copyfrom-path'};
+          my $copyfrom_rev  = $log{$rev}{paths}{$path}{'copyfrom-rev'};
+
+          # Check whether file is copied from a file under the specified URL
+          # It is likely to be a new file if it is copied from outside of the
+          # specified URL.
+          $is_newfile = not ($copyfrom_path =~ s#^$url_path/*##);
+
+          if ($is_newfile) {
+            # File copied from outside of the specified URL
+            # If it is copied from a branch, follow its history, stop on copy
+            my $cp_url = Fcm::CmUrl->new (
+              URL => $url->root . $copyfrom_path . '@' . $copyfrom_rev,
+            );
+
+            # Log of the copied file
+            my %cp_log = $cp_url->svnlog (STOP_ON_COPY => 1);
+
+            # "First" revision of the copied file
+            my $cp_rev = (sort {$a <=> $b} keys %cp_log) [0];
+            my %attrib = exists $cp_log{$cp_rev}{paths}{$cp_url->path}
+                         ? %{ $cp_log{$cp_rev}{paths}{$cp_url->path} } : ();
+
+            # Check whether the "first" revision is copied from elsewhere.
+            if (exists $attrib{'copyfrom-path'}) {
+              # Check whether source exists in the current branch
+              my $cp_cp_url = Fcm::CmUrl->new (
+                URL => $url->root . $attrib{'copyfrom-path'} . '@' .
+                       $attrib{'copyfrom-rev'},
+              );
+
+              $cp_cp_url->branch ($url->branch);
+
+              # If source exists in current branch, set up copy from the source
+              if ($cp_cp_url->url_exists ($rev - 1)) {
+                $is_newfile     = 0;
+                (my $cp_cp_path = $cp_cp_url->path) =~ s#^$url_path/*##;
+
+                push @script, 'svn copy ' . $cp_cp_path .  ' ' . $file;
+              }
+            }
+
+          } else {
+            # File copied from a location under the specified URL
+            # Script to copy file
+            push @script, 'svn copy ' . $copyfrom_path .  ' ' . $file;
+          }
+
+        } else {
+          # History does not exist, must be a new file
+          $is_newfile = 1;
+        }
+      }
+
+      # Copy the "patch" into the file
+      push @script, 'cp -r ${fcm_patch_dir}/' . $patch_path . ' ' . $file;
+
+      # Script to add the file, if required
+      push @script, 'svn add ' . $file
+        if $log{$rev}{paths}{$path}{action} eq 'A' and $is_newfile;
+    }
+
+    # Handle deleted path, script to delete it
+    for my $path (@paths) {
+      next unless $log{$rev}{paths}{$path}{action} eq 'D';
+
+      (my $file = $path) =~ s#^$url_path/*##;
+
+      push @script, 'svn delete ' . $file;
+    }
+
+    # Script to commit the change
+    push @script, 'svn commit -F ${fcm_patch_dir}/' . $rev . '-log';
+    push @script, '';
+  }
+
+  # Write the script if necessary. Otherwise remove output directory
+  # ----------------------------------------------------------------------------
+  if (@script) {
+    # Add line break to each line in @script
+    @script = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")} @script;
+
+    # Write script to output
+    my $out = File::Spec->catfile ($outdir, 'fcm-import-patch');
+    open FILE, '>', $out or die $out, ': cannot open (', $!, ')';
+
+    # Script header
+    print FILE <<EOF;
+#!/bin/sh
+# ------------------------------------------------------------------------------
+# NAME
+#   fcm-import-patch
+#
+# SYNOPSIS
+#   fcm-import-patch TARGET
+#
+# DESCRIPTION
+#   This script is generated automatically by the "fcm mkpatch" command,
+#   together with the revision "patches" it creates. The script imports the
+#   patches into TARGET, which must either be a URL or a working copy of a
+#   valid project tree that can accept the import of the patches.
+#
+#   Patch created from $organisation URL: $u
+# ------------------------------------------------------------------------------
+
+this=`basename \$0`
+
+# Check argument
+target=\$1
+
+# First argument must be a URL or working copy
+if [[ -z \$target ]]; then
+  echo "\$this: the first argument must be a URL or a working copy, abort." >&2
+  exit 1
+fi
+
+if [[ \$target == svn://*  || \$target == svn+ssh://* || \\
+      \$target == http://* || \$target == https://*   || \\
+      \$target == file://* ]]; then
+  # A URL, checkout a working copy in a temporary location
+  fcm_tmp_dir=`mktemp -d \$TMPDIR/\$0.XXXXXX`
+  fcm_working_copy=\$fcm_tmp_dir
+  svn checkout -q \$target \$fcm_working_copy || exit 1
+
+else
+  # A working copy, check that it does not have local changes
+  status=`svn status \$target`
+
+  if [[ -n \$status ]]; then
+    echo "\$target: working copy contains changes, abort." >&2
+    exit 1
+  fi
+
+  fcm_working_copy=\$target
+fi
+
+# Location of the patches, base on the location of this script
+cd `dirname \$0` || exit 1
+fcm_patch_dir=\$PWD
+
+# Change directory to the working copy
+cd \$fcm_working_copy || exit 1
+
+# Commands to apply patches
+EOF
+
+    # Script content
+    print FILE @script;
+
+    # Script footer
+    print FILE <<EOF;
+# Remove temporary working copy, if necessary
+if [[ -d \$fcm_tmp_dir && -w \$fcm_tmp_dir ]]; then
+  rm -rf \$fcm_tmp_dir
+fi
+
+echo "\$this: finished normally."
+#EOF
+EOF
+
+    close FILE or die $out, ': cannot close (', $!, ')';
+
+    # Add executable permission
+    chmod 0755, $out;
+
+    # Diagnostic
+    print $outdir, ': patch generated.', "\n";
+
+  } else {
+    # Remove output directory
+    rmtree $outdir or die $outdir, ': cannot remove';
+
+    # Diagnostic
+    w_report 'No patch is required, abort.';
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &Fcm::Cm::cm_svn ();
+#
+# DESCRIPTION
+#   This is a generic wrapper for all "other" Subversion commands.
+# ------------------------------------------------------------------------------
+
+sub cm_svn {
+  &run_command (
+    ['svn', @_, @ARGV],
+    PRINT => ($_[0] ne 'cat' and not grep {$_ eq '--xml'} @ARGV),
+    METHOD => 'exec',
+  );
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &Fcm::Cm::cm_switch ();
+#
+# DESCRIPTION
+#   This is a wrapper for the Subversion "switch" command.
+# ------------------------------------------------------------------------------
+
+sub cm_switch {
+  if (grep {$_ eq '-h' or $_ eq '--help'} @ARGV or not @ARGV) {
+    # Print usage message if requested
+    print <<EOF;
+usage: 1. switch URL [PATH]
+       2. switch --relocate FROM TO [PATH...]
+
+Note: if --relocate is not specified, "fcm switch" will only support the
+      options --non-interactive, -r [--revision] and -q [--quiet].
+
+EOF
+
+    &run_command ([qw/svn switch --help/], PRINT => 1, METHOD => 'exec');
+
+  } elsif (grep {$_ eq '--relocate'} @ARGV) {
+    # If "--relocate" is specified, call the command "as is"
+    cm_svn ('switch');
+  }
+
+  # "--help" and "--relocate" not specified, implement custom switch command
+
+  # Get command line options
+  my ($non_interactive, $rev, $quiet);
+  GetOptions (
+    'non-interactive' => \$non_interactive,
+    'revision|r=s'    => \$rev,
+    'quiet|q'         => \$quiet,
+  );
+
+  # The remaining arguments
+  $rev = 'HEAD' if not $rev;
+
+  # The remaining arguments
+  my ($newurl_arg, $path) = @ARGV;
+
+  # Make sure we are in a working copy
+  if ($path) {
+    e_report $path, ': does not exist, abort.' if not -e $path;
+
+  } else {
+    $path = cwd ();
+  }
+
+  e_report $path, ': not a working copy, abort.' if not &is_wc ($path);
+
+  # Make sure we are at the top level of the working copy
+  my $dir = &get_wct ($path);
+
+  # Check for merge template in the commit log file in the working copy
+  my $ci_mesg = Fcm::CmCommitMessage->new (DIR => $dir);
+  $ci_mesg->read_file;
+  e_report (
+    (($path eq $dir) ? $ci_mesg->base : $ci_mesg->file),
+    ': merge template exists, please remove it before running switch, abort.',
+  ) if $ci_mesg->auto_mesg;
+
+  # Check for any local modifications
+  return if ! $non_interactive and &_abort_modified_wc ('fcm switch', $dir);
+
+  # Get current URL information associated with the working copy
+  my $oldurl = Fcm::CmBranch->new (URL => &get_url_of_wc ($dir));
+
+  # Analyse new URL
+  my $newurl = &_construct_branch_url ($newurl_arg, $oldurl);
+
+  # Construct the switch command
+  my @command = (
+    qw/svn switch/,
+    ($non_interactive ? '--non-interactive' : ()),
+    ($rev             ? ('-r', $rev)        : ()),
+    ($quiet           ? '--quiet'           : ()),
+    $newurl->url,
+    ($dir eq cwd () ? () : $dir),
+  );
+
+  # Execute the command
+  &run_command (\@command, METHOD => 'exec', PRINT => 1);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $source = &_construct_branch_url ($src_url, $target);
+#
+# DESCRIPTION
+#   The function takes a string $src_url, which is normally the SOURCE URL
+#   argument for "merge" and "switch", and a target, which is an instance of a
+#   Fcm::CmBranch object with a valid URL of a standard FCM branch. It returns
+#   an instance of a Fcm::CmBranch object that represents a valid URL for
+#   $src_url.
+# ------------------------------------------------------------------------------
+
+sub _construct_branch_url {
+  my ($src_url, $target) = @_;
+
+  my $source = Fcm::CmBranch->new (URL => $src_url);
+
+  if (not $source->is_url) {
+    # Not a full URL, construct full URL based on current URL
+    $source->url_peg ($target->url_peg);
+
+    my $path    = '';
+    my $project = $target->project;
+
+    # Construct the branch URL
+    if ($src_url =~ m#^/*$project/(?:trunk|branches|tags)$#) {
+      # Argument contains the full path under the repository root
+      $path = $src_url;
+
+    } elsif ($src_url =~ m#^/*trunk/*(?:@\d+)?$# or
+             $src_url =~ m#^/*(?:trunk|branches|tags)/+#) {
+      # Argument contains the full branch name
+      $src_url =~ s#^/*##;
+      $path    = $target->project_path . '/' . $src_url;
+
+    } else {
+      # Argument contains the shorter branch name
+      $src_url =~ s#^/*##;
+      $path    = $target->project_path . '/branches/' . $src_url;
+    }
+
+    $source->path_peg ($path);
+  }
+
+  # Replace source sub-directory with the target sub-directory
+  $source->subdir ($target->subdir);
+
+  # Ensure that the branch name exists
+  e_report $src_url, ': not a valid URL, abort.'
+    if not $source->url_exists;
+
+  # Ensure that the branch name is valid
+  e_report $src_url, ': not a standard branch in a FCM project, abort.'
+    if not $source->branch;
+
+  # Ensure that the source and target URLs are in the same project
+  e_report 'Source and target URLs are in different projects, abort.'
+    if $source->project_url ne $target->project_url;
+
+  return $source;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &_abort_modified_wc ($title, [$wc]);
+#
+# DESCRIPTION
+#   The function checks for any local modifications in a working copy and
+#   prompts the user whether he/she wants to continue with the command. $title
+#   is the title of the current command. If $wc is specified, it must be the
+#   path to a working copy. Otherwise, the current working directory is used.
+# ------------------------------------------------------------------------------
+
+sub _abort_modified_wc {
+  my ($title, $wc) = @_;
+
+  my @status = &run_command ([qw/svn status/, ($wc ? $wc : ())], METHOD => 'qx');
+
+  if (@status) {
+    print 'You have local modifications:', "\n", @status;
+    my $reply = &main::get_input (
+      TITLE   => $title,
+      MESSAGE => 'Are you sure you want to continue?',
+      TYPE    => 'yn',
+      DEFAULT => 'n',
+    );
+
+    # Abort if user gives any reply other than "y"
+    if ($reply ne 'y') {
+      w_report $title, ': command aborted by user.';
+      return 1;
+    }
+  }
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/CmBranch.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/CmBranch.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/CmBranch.pm	(revision 7236)
@@ -0,0 +1,1199 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Fcm::CmBranch
+#
+# DESCRIPTION
+#   This class contains methods for manipulating a branch. It is a sub-class of
+#   Fcm::CmUrl, and inherits all methods from that class.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::CmBranch;
+@ISA = qw(Fcm::CmUrl);
+
+# Standard pragma
+use warnings;
+use strict;
+
+# Standard modules
+use Carp;
+use File::Spec;
+
+# FCM component modules
+use Fcm::CmCommitMessage;
+use Fcm::CmUrl;
+use Fcm::Util qw/run_command e_report w_report get_rev_keyword svn_date/;
+
+my @properties = (
+  'CREATE_REV',  # revision at which the branch is created
+  'DELETE_REV',  # revision at which the branch is deleted
+  'PARENT',      # reference to parent branch Fcm::CmBranch
+  'ANCESTOR',    # list of common ancestors with other branches
+                 # key = URL, value = ancestor Fcm::CmBranch
+  'LAST_MERGE',  # list of last merges from branches
+                 # key = URL@REV, value = [TARGET, UPPER, LOWER]
+  'AVAIL_MERGE', # list of available revisions for merging
+                 # key = URL@REV, value = [REV ...]
+  'CHILDREN',    # list of children of this branch
+  'SIBLINGS',    # list of siblings of this branch
+);
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cm_branch = Fcm::CmBranch->new (
+#     CONFIG  => $config,
+#     URL     => $url,
+#   );
+#
+# DESCRIPTION
+#   This method constructs a new instance of the Fcm::CmBranch class.
+#
+# ARGUMENTS
+#   CONFIG - reference to a Fcm::Config instance
+#   URL    - URL of a branch
+# ------------------------------------------------------------------------------
+
+sub new {
+  my $this  = shift;
+  my %args  = @_;
+  my $class = ref $this || $this;
+
+  my $self = Fcm::CmUrl->new (%args);
+
+  $self->{$_} = undef for (@properties);
+
+  bless $self, $class;
+  return $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $url = $cm_branch->url_peg;
+#   $cm_branch->url_peg ($url);
+#
+# DESCRIPTION
+#   This method returns/sets the current URL.
+# ------------------------------------------------------------------------------
+
+sub url_peg {
+  my $self = shift;
+
+  if (@_) {
+    if (! $self->{URL} or $_[0] ne $self->{URL}) {
+      # Re-set URL and other essential variables in the SUPER-class
+      $self->SUPER::url_peg (@_);
+
+      # Re-set essential variables
+      $self->{$_} = undef for (@properties);
+    }
+  }
+
+  return $self->{URL};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rev = $cm_branch->create_rev;
+#
+# DESCRIPTION
+#   This method returns the revision at which the branch was created.
+# ------------------------------------------------------------------------------
+
+sub create_rev {
+  my $self = shift;
+
+  if (not $self->{CREATE_REV}) {
+    return unless $self->url_exists ($self->pegrev);
+
+    # Use "svn log" to find out the first revision of the branch
+    my %log = $self->svnlog (STOP_ON_COPY => 1);
+
+    # Look at log in ascending order
+    my $rev   = (sort {$a <=> $b} keys %log) [0];
+    my $paths = $log{$rev}{paths};
+
+    # Get revision when URL is first added to the repository
+    if (exists $paths->{$self->branch_path}) {
+      $self->{CREATE_REV} = $rev if $paths->{$self->branch_path}{action} eq 'A';
+    }
+  }
+
+  return $self->{CREATE_REV};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $parent = $cm_branch->parent;
+#
+# DESCRIPTION
+#   This method returns the parent (a Fcm::CmBranch object) of the current
+#   branch.
+# ------------------------------------------------------------------------------
+
+sub parent {
+  my $self = shift;
+
+  if (not $self->{PARENT}) {
+    # Use the log to find out the parent revision
+    my %log = $self->svnlog (REV => $self->create_rev);
+
+    if (exists $log{paths}{$self->branch_path}) {
+      my $path = $log{paths}{$self->branch_path};
+
+      if ($path->{action} eq 'A') {
+        if (exists $path->{'copyfrom-path'}) {
+          # Current branch is copied from somewhere, set the source as the parent
+          my $url = $self->root .  $path->{'copyfrom-path'};
+          my $rev = $path->{'copyfrom-rev'};
+          $self->{PARENT} = Fcm::CmBranch->new (URL => $url . '@' . $rev);
+
+        } else {
+          # Current branch is not copied from somewhere
+          $self->{PARENT} = $self;
+        }
+      }
+    }
+  }
+
+  return $self->{PARENT};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rev = $cm_branch->delete_rev;
+#
+# DESCRIPTION
+#   This method returns the revision at which the branch was deleted.
+# ------------------------------------------------------------------------------
+
+sub delete_rev {
+  my $self = shift;
+
+  if (not $self->{DELETE_REV}) {
+    return if $self->url_exists ('HEAD');
+
+    # Container of the current URL
+    (my $dir_url = $self->branch_url) =~ s#/+[^/]+/*$##;
+
+    # Use "svn log" on the container between a revision where the branch exists
+    # and the HEAD
+    my $dir = Fcm::CmUrl->new (URL => $dir_url);
+    my %log = $dir->svnlog (
+      REV => ['HEAD', ($self->pegrev ? $self->pegrev : $self->create_rev)],
+    );
+
+    # Go through the log to see when branch no longer exists
+    for my $rev (sort {$a <=> $b} keys %log) {
+      next unless exists $log{$rev}{paths}{$self->branch_path} and
+                  $log{$rev}{paths}{$self->branch_path}{action} eq 'D';
+
+      $self->{DELETE_REV} = $rev;
+      last;
+    }
+  }
+
+  return $self->{DELETE_REV};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = $cm_branch->is_child_of ($branch);
+#
+# DESCRIPTION
+#   This method returns true if the current branch is a child of $branch.
+# ------------------------------------------------------------------------------
+
+sub is_child_of {
+  my ($self, $branch) = @_;
+
+  # The trunk cannot be a child branch
+  return if $self->is_trunk;
+
+  # If $branch is a branch, use name of $self to see when it is created
+  if ($branch->is_branch and $self->url =~ m#/r(\d+)_[^/]+/*$#) {
+    my $rev = $1;
+
+    # $self can only be a child if it is copied from a revision > the create
+    # revision of $branch
+    return if $rev < $branch->create_rev;
+  }
+
+  return if $self->parent->url ne $branch->url;
+
+  # If $branch is a branch, ensure that it is created before $self
+  return if $branch->is_branch and $self->create_rev <= $branch->create_rev;
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = $cm_branch->is_sibling_of ($branch);
+#
+# DESCRIPTION
+#   This method returns true if the current branch is a sibling of $branch.
+# ------------------------------------------------------------------------------
+
+sub is_sibling_of {
+  my ($self, $branch) = @_;
+
+  # The trunk cannot be a sibling branch
+  return if $branch->is_trunk;
+
+  return if $self->parent->url ne $branch->parent->url;
+
+  # If the parent is a branch, ensure they are actually the same branch
+  return if $branch->parent->is_branch and
+            $self->parent->create_rev != $branch->parent->create_rev;
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_get_relatives ($relation);
+#
+# DESCRIPTION
+#   This method sets the $self->{$relation} variable by inspecting the list of
+#   branches at the current revision of the current branch. $relation can be
+#   either "CHILDREN" or "SIBLINGS".
+# ------------------------------------------------------------------------------
+
+sub _get_relatives {
+  my ($self, $relation) = @_;
+
+  my @branch_list = $self->branch_list;
+
+  $self->{$relation} = [];
+
+  # If we are searching for CHILDREN, get list of SIBLINGS, and vice versa
+  my $other = ($relation eq 'CHILDREN' ? 'SIBLINGS' : 'CHILDREN');
+  my %other_list;
+  if ($self->{$other}) {
+    %other_list = map {$_->url, 1} @{ $self->{$other} };
+  }
+
+  for my $u (@branch_list) {
+    # Ignore URL of current branch and its parent
+    next if $u eq $self->url;
+    next if $self->is_branch and $u eq $self->parent->url;
+
+    # Ignore if URL is a branch detected to be another type of relative
+    next if exists $other_list{$u};
+
+    # Construct new Fcm::CmBranch object from branch URL
+    my $url = $u . ($self->pegrev ? '@' . $self->pegrev : '');
+    my $branch = Fcm::CmBranch->new (URL => $url);
+
+    # Test whether $branch is a relative we are looking for
+    if ($relation eq 'CHILDREN') {
+      push @{ $self->{$relation} }, $branch if $branch->is_child_of ($self);
+
+    } else {
+      push @{ $self->{$relation} }, $branch if $branch->is_sibling_of ($self);
+    }
+  }
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @children = $cm_branch->children;
+#
+# DESCRIPTION
+#   This method returns a list of children (Fcm::CmBranch objects) of the
+#   current branch that exists in the current revision.
+# ------------------------------------------------------------------------------
+
+sub children {
+  my $self = shift;
+
+  $self->_get_relatives ('CHILDREN') if not $self->{CHILDREN};
+
+  return @{ $self->{CHILDREN} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @siblings = $cm_branch->siblings;
+#
+# DESCRIPTION
+#   This method returns a list of siblings (Fcm::CmBranch objects) of the
+#   current branch that exists in the current revision.
+# ------------------------------------------------------------------------------
+
+sub siblings {
+  my $self = shift;
+
+  $self->_get_relatives ('SIBLINGS') if not $self->{SIBLINGS};
+
+  return @{ $self->{SIBLINGS} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ancestor = $cm_branch->ancestor ($branch);
+#
+# DESCRIPTION
+#   This method returns the common ancestor (a Fcm::CmBranch object) of a
+#   specified $branch and the current branch. The argument $branch must be a
+#   Fcm::CmBranch object. Both the current branch and $branch are assumed to be
+#   in the same project.
+# ------------------------------------------------------------------------------
+
+sub ancestor {
+  my ($self, $branch) = @_;
+
+  if (not exists $self->{ANCESTOR}{$branch->url_peg}) {
+    if ($self->url_peg eq $branch->url_peg) {
+      $self->{ANCESTOR}{$branch->url_peg} = $self;
+
+    } else {
+      # Get family tree of current branch, from trunk to current branch
+      my @this_family = ($self);
+      while (not $this_family [0]->is_trunk) {
+        unshift @this_family, $this_family [0]->parent;
+      }
+
+      # Get family tree of $branch, from trunk to $branch
+      my @that_family = ($branch);
+      while (not $that_family [0]->is_trunk) {
+        unshift @that_family, $that_family [0]->parent;
+      }
+
+      # Find common ancestor from list of parents
+      my $ancestor = undef;
+
+      while (not $ancestor) {
+        # $this and $that should both start as some revisions on the trunk.
+        # Walk down a generation each time it loops around.
+        my $this = shift @this_family;
+        my $that = shift @that_family;
+
+        if ($this->url eq $that->url) {
+          if ($this->is_trunk or $this->create_rev eq $that->create_rev) {
+            # $this and $that are the same branch
+            if (@this_family and @that_family) {
+              # More generations in both branches, try comparing the next
+              # generations.
+              next;
+
+            } else {
+              # End of lineage in one of the branches, ancestor is at the lower
+              # revision of the current URL.
+              if ($this->pegrev and $that->pegrev) {
+                $ancestor = $this->pegrev < $that->pegrev ? $this : $that;
+
+              } else {
+                $ancestor = $this->pegrev ? $this : $that;
+              }
+            }
+
+          } else {
+            # Despite the same URL, $this and $that are different branches as
+            # they are created at different revisions. The ancestor must be the
+            # parent with the lower revision. (This should not occur at the
+            # start.)
+            $ancestor = $this->parent->pegrev < $that->parent->pegrev
+                        ? $this->parent : $that->parent;
+          }
+
+        } else {
+          # Different URLs, ancestor must be the parent with the lower revision.
+          # (This should not occur at the start.)
+          $ancestor = $this->parent->pegrev < $that->parent->pegrev
+                      ? $this->parent : $that->parent;
+        }
+      }
+
+      $self->{ANCESTOR}{$branch->url_peg} = $ancestor;
+    }
+  }
+
+  return $self->{ANCESTOR}{$branch->url_peg};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   ($target, $upper, $lower) = $cm_branch->last_merge_from (
+#     $branch, $stop_on_copy,
+#   );
+#
+# DESCRIPTION
+#   This method returns a 3-element list with information of the last merge
+#   into the current branch from a specified $branch. The first element in the
+#   list $target (a Fcm::CmBranch object) is the target at which the merge was
+#   performed. (This can be the current branch or a parent branch up to the
+#   common ancestor with the specified $branch.) The second and third elements,
+#   $upper and $lower, (both Fcm::CmBranch objects), are the upper and lower
+#   ends of the source delta. If there is no merge from $branch into the
+#   current branch from their common ancestor to the current revision, this
+#   method will return an empty list. If $stop_on_copy is specified, it ignores
+#   merges from parents of $branch, and merges into parents of the current
+#   branch.
+# ------------------------------------------------------------------------------
+
+sub last_merge_from {
+  my ($self, $branch, $stop_on_copy) = @_;
+
+  if (not exists $self->{LAST_MERGE}{$branch->url_peg}) {
+    # Get "log" of current branch down to the common ancestor
+    my %log = $self->svnlog (
+      REV => [
+       ($self->pegrev ? $self->pegrev : 'HEAD'),
+       $self->ancestor ($branch)->pegrev,
+      ],
+
+      STOP_ON_COPY => $stop_on_copy,
+    );
+
+    my $cr = $self;
+
+    # Go down the revision log, checking for merge template messages
+    REV: for my $rev (sort {$b <=> $a} keys %log) {
+      # Loop each line of the log message at each revision
+      my @msg = split /\n/, $log{$rev}{msg};
+
+      # Also consider merges into parents of current branch
+      $cr = $cr->parent if ($cr->is_branch and $rev < $cr->create_rev);
+
+      for (@msg) {
+        # Ignore unless log message matches a merge template
+        next unless /Merged into \S+: (\S+) cf\. (\S+)/;
+
+        # Upper $1 and lower $2 ends of the source delta
+        my $u_path = $1;
+        my $l_path = $2;
+
+        # Add the root directory to the paths if necessary
+        $u_path = '/' . $u_path if substr ($u_path, 0, 1) ne '/';
+        $l_path = '/' . $l_path if substr ($l_path, 0, 1) ne '/';
+
+        # Only consider merges with specified branch (and its parent)
+        (my $path = $u_path) =~ s/@(\d+)$//;
+        my $u_rev = $1;
+
+        my $br = $branch;
+        $br    = $br->parent while (
+          $br->is_branch and $u_rev < $br->create_rev and not $stop_on_copy
+        );
+
+        next unless $br->branch_path eq $path;
+
+        # If $br is a parent of branch, ignore those merges with the parent
+        # above the branch point of the current branch
+        next if $br->pegrev and $br->pegrev < $u_rev;
+
+        # Set the return values
+        $self->{LAST_MERGE}{$branch->url_peg} = [
+          Fcm::CmBranch->new (URL => $cr->url . '@' . $rev), # target
+          Fcm::CmBranch->new (URL => $self->root . $u_path), # delta upper
+          Fcm::CmBranch->new (URL => $self->root . $l_path), # delta lower
+        ];
+
+        last REV;
+      }
+    }
+  }
+
+  return (exists $self->{LAST_MERGE}{$branch->url_peg}
+          ? @{ $self->{LAST_MERGE}{$branch->url_peg} } : ());
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @revs = $cm_branch->avail_merge_from ($branch[, $stop_on_copy]);
+#
+# DESCRIPTION
+#   This method returns a list of revisions of a specified $branch, which are
+#   available for merging into the current branch. If $stop_on_copy is
+#   specified, it will not list available merges from the parents of $branch.
+# ------------------------------------------------------------------------------
+
+sub avail_merge_from {
+  my ($self, $branch, $stop_on_copy) = @_;
+
+  if (not exists $self->{AVAIL_MERGE}{$branch->url_peg}) {
+    # Find out the revision of the upper delta at the last merge from $branch
+    # If no merge is found, use revision of common ancestor with $branch
+    my @last_merge = $self->last_merge_from ($branch);
+    my $rev        = $self->ancestor ($branch)->pegrev;
+    $rev           = $last_merge [1]->pegrev
+      if @last_merge and $last_merge [1]->pegrev > $rev;
+
+    # Get the "log" of the $branch down to $rev
+    my %log = $branch->svnlog (
+      REV          => [($branch->pegrev ? $branch->pegrev : 'HEAD'), $rev],
+      STOP_ON_COPY => $stop_on_copy,
+    );
+
+    # No need to include $rev itself, as it has already been merged
+    delete $log{$rev};
+
+    # No need to include the branch create revision
+    delete $log{$branch->create_rev}
+      if $branch->is_branch and exists $log{$branch->create_rev};
+
+    if (keys %log) {
+      # Check whether there is a latest merge from $self into $branch, if so,
+      # all revisions of $branch below that merge should become unavailable
+      my @last_merge_into = $branch->last_merge_from ($self);
+
+      if (@last_merge_into) {
+        for my $rev (keys %log) {
+          delete $log{$rev} if $rev < $last_merge_into [0]->pegrev;
+        }
+      }
+    }
+
+    # Available merges include all revisions above the branch creation revision
+    # or the revision of the last merge
+    $self->{AVAIL_MERGE}{$branch->url_peg} = [sort {$b <=> $a} keys %log];
+  }
+
+  return @{ $self->{AVAIL_MERGE}{$branch->url_peg} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $lower = $cm_branch->base_of_merge_from ($branch);
+#
+# DESCRIPTION
+#   This method returns the lower delta (a Fcm::CmBranch object) for the next
+#   merge from $branch.
+# ------------------------------------------------------------------------------
+
+sub base_of_merge_from {
+  my ($self, $branch) = @_;
+
+  # Base is the ancestor if there is no merge between $self and $branch
+  my $return = $self->ancestor ($branch);
+
+  # Get configuration for the last merge from $branch to $self
+  my @merge_from = $self->last_merge_from ($branch);
+
+  # Use the upper delta of the last merge from $branch, as all revisions below
+  # that have already been merged into the $self
+  $return = $merge_from [1]
+    if @merge_from and $merge_from [1]->pegrev > $return->pegrev;
+
+  # Get configuration for the last merge from $self to $branch
+  my @merge_into = $branch->last_merge_from ($self);
+
+  # Use the upper delta of the last merge from $self, as the current revision
+  # of $branch already contains changes of $self up to the peg revision of the
+  # upper delta
+  $return = $merge_into [1]
+    if @merge_into and $merge_into [0]->pegrev > $return->pegrev;
+
+  return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = $cm_branch->allow_subdir_merge_from ($branch, $subdir);
+#
+# DESCRIPTION
+#   This method returns true if a merge from the sub-directory $subdir in
+#   $branch  is allowed - i.e. it does not result in losing changes made in
+#   $branch outside of $subdir.
+# ------------------------------------------------------------------------------
+
+sub allow_subdir_merge_from {
+  my ($self, $branch, $subdir) = @_;
+
+  # Get revision at last merge from $branch or ancestor
+  my @merge_from = $self->last_merge_from ($branch);
+  my $last       = @merge_from ? $merge_from [1] : $self->ancestor ($branch);
+  my $rev        = $last->pegrev;
+
+  if ($branch->pegrev > $rev) {
+    # Inspect log from revision at last merge/ancestor to current revision
+    my %log = $branch->svnlog (REV => [$branch->pegrev, $rev + 1]);
+    my $br  = $branch;
+
+    # Check whether there are changes outside of $subdir
+    for my $rev (sort {$b <=> $a} keys %log) {
+      $br = $br->parent if $br->is_branch and $rev < $br->create_rev;
+
+      for my $path (keys %{ $log{$rev}{paths} }) {
+        next if $path eq $br->branch_path; # Ignore branch creation
+
+        my $p_subdir = substr ($path, length ($br->branch_path) + 1);
+
+        return if $p_subdir !~ m#^$subdir(?:/|$)#;
+      }
+    }
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cm_branch->create (
+#     SRC                  => $src,
+#     TYPE                 => $type,
+#     NAME                 => $name,
+#     [PASSWORD            => $password,]
+#     [REV_FLAG            => $rev_flag,]
+#     [TICKET              => \@tickets,]
+#     [REV                 => $rev,]
+#     [NON_INTERACTIVE     => 1,]
+#     [SVN_NON_INTERACTIVE => 1,]
+#   );
+#
+# DESCRIPTION
+#   This method creates a branch in a Subversion repository.
+#
+# OPTIONS
+#   SRC                 - reference to a Fcm::CmUrl object.
+#   TYPE                - Specify the branch type. See help in "fcm branch" for
+#                         further information.
+#   NAME                - specify the name of the branch.
+#   NON_INTERACTIVE     - Do no interactive prompting, set SVN_NON_INTERACTIVE
+#                         to true automatically.
+#   PASSWORD            - specify the password for commit access.
+#   REV                 - specify the operative revision of the source.
+#   REV_FLAG            - A flag to specify the behaviour of the prefix to the
+#                         branch name. See help in "fcm branch" for further
+#                         information.
+#   SVN_NON_INTERACTIVE - Do no interactive prompting when running svn commit,
+#                         etc. This option is implied by NON_INTERACTIVE.
+#   TICKET              - Specify one or more related tickets for the branch.
+# ------------------------------------------------------------------------------
+
+sub create {
+  my $self = shift;
+  my %args = @_;
+
+  # Options
+  # ----------------------------------------------------------------------------
+  # Compulsory options
+  my $src  = $args{SRC};
+  my $type = $args{TYPE};
+  my $name = $args{NAME};
+
+  # Other options
+  my $rev_flag        = $args{REV_FLAG}        ? $args{REV_FLAG}    : 'NORMAL';
+  my @tickets         = exists $args{TICKET}   ? @{ $args{TICKET} } : ();
+  my $password        = exists $args{PASSWORD} ? $args{PASSWORD}    : undef;
+  my $orev            = exists $args{REV}      ? $args{REV}         : 'HEAD';
+
+  my $non_interactive     = exists $args{NON_INTERACTIVE}
+                            ? $args{NON_INTERACTIVE} : 0;
+  my $svn_non_interactive = exists $args{SVN_NON_INTERACTIVE}
+                            ? $args{SVN_NON_INTERACTIVE} : 0;
+  $svn_non_interactive    = $non_interactive ? 1 : $svn_non_interactive;
+
+  # Analyse the source URL
+  # ----------------------------------------------------------------------------
+  # Create branch from the trunk by default
+  $src->branch ('trunk') if not $src->branch;
+
+  # Remove "sub-directory" part from source URL
+  $src->subdir ('')      if $src->subdir;
+
+  # Remove "peg revision" part because it does not work with "svn copy"
+  $src->pegrev ('')      if $src->pegrev;
+
+  # Find out the URL and the last changed revision of the specified URL at the
+  # specified operative revision
+  my $url = $src->svninfo (FLAG => 'URL', REV => $orev);
+  e_report $src->url, ': cannot determine the operative URL at revision ',
+           $orev, ', abort.' if not $url;
+
+  $src->url ($url) if $url ne $src->url;
+
+  my $rev = $src->svninfo (FLAG => 'Last Changed Rev', REV => $orev);
+  e_report $src->url, ': cannot determine the last changed rev at revision',
+           $orev, ', abort.' if not $rev;
+
+  # Warn user if last changed revision is not the specified revision
+  w_report 'Warning: branch will be created from revision ', $rev,
+           ', i.e. the last changed rev.'
+    unless $orev and $orev eq $rev;
+
+  # Determine the sub-directory names of the branch
+  # ----------------------------------------------------------------------------
+  my @branch_dirs = ('branches');
+
+  # Split branch type flags into a hash table
+  my %type_flags = ();
+  $type_flags{$_} = 1 for ((split /::/, $type));
+
+  # Branch sub-directory 1, development, test or package
+  for my $flag (qw/DEV TEST PKG/) {
+    if (exists $type_flags{$flag}) {
+      push @branch_dirs, lc ($flag);
+      last;
+    }
+  }
+
+  # Branch sub-directory 2, user, share, configuration or release
+  if (exists $type_flags{USER}) {
+    my $userid = getlogin;
+    $userid    = $ENV{LOGNAME} unless $userid;
+    $userid    = $ENV{USER}    unless $userid;
+    die 'Unable to determine your user ID, abort' unless $userid;
+
+    push @branch_dirs, $userid;
+
+  } else {
+    for my $flag (qw/SHARE CONFIG REL/) {
+      if (exists $type_flags{$flag}) {
+        push @branch_dirs, uc (substr $flag, 0, 1) . lc (substr $flag, 1);
+        last;
+      }
+    }
+  }
+
+  # Branch sub-directory 3, branch name
+  # Prefix branch name with revision number/keyword if necessary
+  my $prefix = '';
+  if ($rev_flag ne 'NONE') {
+    $prefix = $rev;
+
+    # Attempt to replace revision number with a revision keyword if necessary
+    $prefix = &get_rev_keyword (
+      REV => $rev,
+      URL => $src->url_peg,
+    ) if $rev_flag eq 'NORMAL';
+
+    # $prefix is still a revision number, add "r" in front of it
+    $prefix = 'r' . $prefix if $prefix eq $rev;
+
+    # Add an underscore before the branch name
+    $prefix.= '_';
+  }
+
+  # Branch name
+  push @branch_dirs, $prefix . $name;
+
+  # Check whether the branch already exists, fail if so
+  # ----------------------------------------------------------------------------
+  # Construct the URL of the branch
+  $self->project_url ($src->project_url);
+  $self->branch  (join ('/', @branch_dirs));
+
+  # Check that branch does not already exists
+  e_report $self->url, ': branch already exists, abort.' if $self->url_exists;
+
+  # Message for the commit log
+  # ----------------------------------------------------------------------------
+  my @message = ('Created ' . $self->branch_path .  ' from ' .
+                 $src->branch_path . '@' . $rev . '.' . "\n");
+
+  # Add related Trac ticket links to commit log if set
+  if (@tickets) {
+    my $ticket_mesg = 'Relates to ticket' . (@tickets > 1 ? 's' : '');
+
+    while (my $ticket = shift @tickets) {
+      $ticket_mesg .= ' #' . $ticket;
+      $ticket_mesg .= (@tickets > 1 ? ',' : ' and') if @tickets >= 1;
+    }
+
+    push @message, $ticket_mesg . ".\n";
+  }
+
+  # Create a temporary file for the commit log message
+  my $ci_mesg = Fcm::CmCommitMessage->new;
+  $ci_mesg->auto_mesg (@message);
+  $ci_mesg->ignore_mesg ('A' . ' ' x 4 . $self->url . "\n");
+  my $logfile = $ci_mesg->edit_file (TEMP => 1, BATCH => $non_interactive);
+
+  # Check with the user to see if he/she wants to go ahead
+  # ----------------------------------------------------------------------------
+  if (not $non_interactive) {
+    my $reply = &main::get_input (
+      TITLE   => 'fcm branch',
+      MESSAGE => 'Would you like to go ahead and create this branch?',
+      TYPE    => 'yn',
+      DEFAULT => 'n',
+    );
+
+    return unless $reply eq 'y';
+  }
+
+  # Ensure existence of container sub-directories of the branch
+  # ----------------------------------------------------------------------------
+  for my $i (0 .. $#branch_dirs - 1) {
+    my $subdir     = join ('/', @branch_dirs[0 .. $i]);
+    my $subdir_url = Fcm::CmUrl->new (URL => $src->project_url . '/' . $subdir);
+
+    # Check whether each sub-directory of the branch already exists,
+    # if sub-directory does not exist, create it
+    next if $subdir_url->url_exists;
+
+    print 'Creating sub-directory: ', $subdir, "\n";
+
+    my @command = (
+      qw/svn mkdir/,
+      '-m', 'Created ' . $subdir . ' directory.',
+      ($svn_non_interactive  ? '--non-interactive'       : ()),
+      (defined $password     ? ('--password', $password) : ()),
+
+      $subdir_url->url,
+    );
+    &run_command (\@command);
+  }
+
+  # Create the branch
+  # ----------------------------------------------------------------------------
+  {
+    print 'Creating branch ', $self->url, ' ...', "\n";
+    my @command = (
+      qw/svn copy/,
+      '-r', $rev,
+      '-F', $logfile,
+      ($svn_non_interactive  ? '--non-interactive'       : ()),
+      (defined $password     ? ('--password', $password) : ()),
+
+      $src->url, $self->url,
+    );
+    &run_command (\@command);
+  }
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cm_branch->delete (
+#     [NON_INTERACTIVE     => 1,]
+#     [PASSWORD            => $password,]
+#     [SVN_NON_INTERACTIVE => 1,]
+#   );
+#
+# DESCRIPTION
+#   This method deletes the current branch from the Subversion repository.
+#
+# OPTIONS
+#   NON_INTERACTIVE     - Do no interactive prompting, set SVN_NON_INTERACTIVE
+#                         to true automatically.
+#   PASSWORD            - specify the password for commit access.
+#   SVN_NON_INTERACTIVE - Do no interactive prompting when running svn commit,
+#                         etc. This option is implied by NON_INTERACTIVE.
+# ------------------------------------------------------------------------------
+
+sub del {
+  my $self = shift;
+  my %args = @_;
+
+  # Options
+  # ----------------------------------------------------------------------------
+  my $password            = exists $args{PASSWORD} ? $args{PASSWORD} : undef;
+  my $non_interactive     = exists $args{NON_INTERACTIVE}
+                            ? $args{NON_INTERACTIVE} : 0;
+  my $svn_non_interactive = exists $args{SVN_NON_INTERACTIVE}
+                            ? $args{SVN_NON_INTERACTIVE} : 0;
+  $svn_non_interactive    = $non_interactive ? 1 : $svn_non_interactive;
+
+  # Ensure URL is a branch
+  # ----------------------------------------------------------------------------
+  e_report $self->url_peg, ': not a branch, abort.' if not $self->is_branch;
+
+  # Message for the commit log
+  # ----------------------------------------------------------------------------
+  my @message = ('Deleted ' . $self->branch_path . '.' . "\n");
+
+  # Create a temporary file for the commit log message
+  my $ci_mesg = Fcm::CmCommitMessage->new ();
+  $ci_mesg->auto_mesg (@message);
+  $ci_mesg->ignore_mesg ('D' . ' ' x 4 . $self->url . "\n");
+  my $logfile = $ci_mesg->edit_file (TEMP => 1, BATCH => $non_interactive);
+
+  # Check with the user to see if he/she wants to go ahead
+  # ----------------------------------------------------------------------------
+  if (not $non_interactive) {
+    my $reply = &main::get_input (
+      TITLE   => 'fcm branch',
+      MESSAGE => 'Would you like to go ahead and delete this branch?',
+      TYPE    => 'yn',
+      DEFAULT => 'n',
+    );
+
+    return unless $reply eq 'y';
+  }
+
+  # Delete branch if answer is "y" for "yes"
+  # ----------------------------------------------------------------------------
+  print 'Deleting branch ', $self->url, ' ...', "\n";
+  my @command = (
+    qw/svn delete/,
+    '-F', $logfile,
+    (defined $password    ? ('--password', $password) : ()),
+    ($svn_non_interactive ? '--non-interactive'       : ()),
+
+    $self->url,
+  );
+  &run_command (\@command);
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cm_branch->display_info (
+#     [SHOW_CHILDREN => 1],
+#     [SHOW_OTHER    => 1]
+#     [SHOW_SIBLINGS => 1]
+#   );
+#
+# DESCRIPTION
+#   This method displays information of the current branch. If SHOW_CHILDREN is
+#   set, it shows information of all current children branches of the current
+#   branch. If SHOW_SIBLINGS is set, it shows information of siblings that have
+#   been merged recently with the current branch. If SHOW_OTHER is set, it shows
+#   information of custom/reverse merges.
+# ------------------------------------------------------------------------------
+
+sub display_info {
+  my $self = shift;
+  my %args = @_;
+
+  # Arguments
+  # ----------------------------------------------------------------------------
+  my $show_children = exists $args{SHOW_CHILDREN} ? $args{SHOW_CHILDREN} : 0;
+  my $show_other    = exists $args{SHOW_OTHER   } ? $args{SHOW_OTHER}    : 0;
+  my $show_siblings = exists $args{SHOW_SIBLINGS} ? $args{SHOW_SIBLINGS} : 0;
+
+  # Useful variables
+  # ----------------------------------------------------------------------------
+  my $separator  = '-' x 80 . "\n";
+  my $separator2 = '  ' . '-' x 78 . "\n";
+
+  # Print "info" as returned by "svn info"
+  # ----------------------------------------------------------------------------
+  for my $key ('URL', 'Repository Root', 'Revision', 'Last Changed Author',
+               'Last Changed Rev', 'Last Changed Date') {
+    print $key, ': ', $self->svninfo (FLAG => $key), "\n"
+      if $self->svninfo (FLAG => $key);
+  }
+
+  if ($self->config->verbose) {
+    # Verbose mode, print log message at last changed revision
+    my %log = $self->svnlog (REV => $self->svninfo (FLAG => 'Last Changed Rev'));
+    my @log = split /\n/, $log{msg};
+    print 'Last Changed Log:', "\n\n", map ({'  ' . $_ . "\n"} @log), "\n";
+  }
+
+  if ($self->is_branch) {
+    # Print create information
+    # --------------------------------------------------------------------------
+    my %log = $self->svnlog (REV => $self->create_rev);
+
+    print $separator;
+    print 'Branch Create Author: ', $log{author}, "\n" if $log{author};
+    print 'Branch Create Rev: ', $self->create_rev, "\n";
+    print 'Branch Create Date: ', &svn_date ($log{date}), "\n";
+
+    if ($self->config->verbose) {
+      # Verbose mode, print log message at last create revision
+      my @log = split /\n/, $log{msg};
+      print 'Branch Create Log:', "\n\n", map ({'  ' . $_ . "\n"} @log), "\n";
+    }
+
+    # Print delete information if branch no longer exists
+    # --------------------------------------------------------------------------
+    print 'Branch Delete Rev: ', $self->delete_rev, "\n" if $self->delete_rev;
+
+    # Report merges into/from the parent
+    # --------------------------------------------------------------------------
+    # Print the URL@REV of the parent branch
+    print $separator, 'Branch Parent: ', $self->parent->url_peg, "\n";
+
+    # Set up a new object for the parent at the current revision
+    # --------------------------------------------------------------------------
+    my $p_url  = $self->parent->url;
+    $p_url    .= '@' . $self->pegrev if $self->pegrev;
+    my $parent = Fcm::CmBranch->new (URL => $p_url);
+
+    if (not $parent->url_exists) {
+      print 'Branch parent deleted.', "\n";
+      return;
+    }
+
+    # Report merges into/from the parent
+    # --------------------------------------------------------------------------
+    print $self->_report_merges ($parent, 'Parent');
+  }
+
+  # Report merges with siblings
+  # ----------------------------------------------------------------------------
+  if ($show_siblings) {
+    # Report number of sibling branches found
+    print $separator, 'Seaching for siblings ... ';
+    my @siblings = $self->siblings;
+    print scalar (@siblings), ' ', (@siblings> 1 ? 'siblings' : 'sibling'),
+          ' found.', "\n";
+
+    # Report branch name and merge information only if there are recent merges
+    my $out = '';
+    for my $sibling (@siblings) {
+      my $string = $self->_report_merges ($sibling, 'Sibling');
+
+      $out .= $separator2 . '  ' . $sibling->url . "\n" . $string if $string;
+    }
+
+    if (@siblings) {
+      if ($out) {
+        print 'Merges with existing siblings:', "\n", $out;
+
+      } else {
+        print 'No merges with existing siblings.', "\n";
+      }
+    }
+  }
+
+  # Report children
+  # ----------------------------------------------------------------------------
+  if ($show_children) {
+    # Report number of child branches found
+    print $separator, 'Seaching for children ... ';
+    my @children = $self->children;
+    print scalar (@children), ' ', (@children > 1 ? 'children' : 'child'),
+          ' found.', "\n";
+
+    # Report children if they exist
+    print 'Current children:', "\n" if @children;
+
+    for my $child (@children) {
+      print $separator2, '  ', $child->url, "\n";
+      print '  Child Create Rev: ', $child->create_rev, "\n";
+      print $self->_report_merges ($child, 'Child');
+    }
+  }
+
+  # Report custom/reverse merges into the branch
+  # ----------------------------------------------------------------------------
+  if ($show_other) {
+    my %log = $self->svnlog (STOP_ON_COPY => 1);
+    my @out;
+
+    # Go down the revision log, checking for merge template messages
+    REV: for my $rev (sort {$b <=> $a} keys %log) {
+      # Loop each line of the log message at each revision
+      my @msg = split /\n/, $log{$rev}{msg};
+
+      for (@msg) {
+        # Ignore unless log message matches a merge template
+        if (/^Reversed r\d+(:\d+)? of \S+$/ or
+            s/^(Custom merge) into \S+(:.+)$/$1$2/) {
+          push @out, ('r' . $rev . ': ' . $_) . "\n";
+        }
+      }
+    }
+
+    print $separator, 'Other merges:', "\n", @out if @out;
+  }
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $string = $self->_report_merges ($branch, $relation);
+#
+# DESCRIPTION
+#   This method returns a string for displaying merge information with a
+#   branch, the $relation of which can be a Parent, a Sibling or a Child.
+# ------------------------------------------------------------------------------
+
+sub _report_merges {
+  my ($self, $branch, $relation) = @_;
+
+  my $indent    = ($relation eq 'Parent') ? '' : '  ';
+  my $separator = ($relation eq 'Parent') ? ('-' x 80) : ('  ' . '-' x 78);
+  $separator   .= "\n";
+
+  my $return = '';
+
+  # Report last merges into/from the $branch
+  # ----------------------------------------------------------------------------
+  my %merge  = (
+    'Last Merge From ' . $relation . ':'
+    => [$self->last_merge_from ($branch, 1)],
+    'Last Merge Into ' . $relation . ':'
+    => [$branch->last_merge_from ($self, 1)],
+  );
+
+  if ($self->config->verbose) {
+    # Verbose mode, print the log of the merge
+    for my $key (keys %merge) {
+      next if not @{ $merge{$key} };
+
+      # From: target (0) is self, upper delta (1) is $branch
+      # Into: target (0) is $branch, upper delta (1) is self
+      my $t = ($key =~ /From/) ? $self : $branch;
+
+      $return .= $indent . $key . "\n";
+      $return .= $separator . $t->display_svnlog ($merge{$key}[0]->pegrev);
+    }
+
+  } else {
+    # Normal mode, print in simplified form (rREV Parent@REV)
+    for my $key (keys %merge) {
+      next if not @{ $merge{$key} };
+
+      # From: target (0) is self, upper delta (1) is $branch
+      # Into: target (0) is $branch, upper delta (1) is self
+      $return .= $indent . $key . ' r' . $merge{$key}[0]->pegrev . ' ' .
+                 $merge{$key}[1]->path_peg . ' cf. ' .
+                 $merge{$key}[2]->path_peg . "\n";
+    }
+  }
+
+  if ($relation eq 'Sibling') {
+    # For sibling, do not report further if there is no recent merge
+    my @values = values %merge;
+
+    return $return unless (@{ $values[0] } or @{ $values[1] });
+  }
+
+  # Report available merges into/from the $branch
+  # ----------------------------------------------------------------------------
+  my %avail = (
+    'Merges Avail From ' . $relation . ':'
+    => ($self->delete_rev ? [] : [$self->avail_merge_from ($branch, 1)]),
+    'Merges Avail Into ' . $relation . ':'
+    => [$branch->avail_merge_from ($self, 1)],
+  );
+
+  if ($self->config->verbose) {
+    # Verbose mode, print the log of each revision
+    for my $key (keys %avail) {
+      next unless @{ $avail{$key} };
+
+      $return .= $indent . $key . "\n";
+
+      my $s = ($key =~ /From/) ? $branch: $self;
+
+      for my $rev (@{ $avail{$key} }) {
+        $return .= $separator . $s->display_svnlog ($rev);
+      }
+    }
+
+  } else {
+    # Normal mode, print only the revisions
+    for my $key (keys %avail) {
+      next unless @{ $avail{$key} };
+
+      $return .= $indent . $key . ' ' . join (' ', @{ $avail{$key} }) . "\n";
+    }
+  }
+
+  return $return;
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/CmCommitMessage.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/CmCommitMessage.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/CmCommitMessage.pm	(revision 7236)
@@ -0,0 +1,395 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Fcm::CmCommitMessage
+#
+# DESCRIPTION
+#   This class contains methods to read, write and edit the commit message file
+#   in a working copy.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::CmCommitMessage;
+
+# Standard pragma
+use warnings;
+use strict;
+
+# Standard modules
+use Carp;
+use Cwd;
+use File::Spec;
+use File::Temp qw/tempfile/;
+
+# FCM component modules
+use Fcm::Util qw/e_report run_command/;
+
+# Commit log delimiter messages
+my $ignore_line = '--This line, and those below, will be ignored--';
+my $auto_line   = '--This line will be ignored and those below will be ' .
+                  'inserted automatically--';
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ci_mesg = Fcm::CmCommitMessage->new (
+#     CONFIG  => $config,
+#     DIR     => $dir,
+#     BASE    => $base,
+#   );
+#
+# DESCRIPTION
+#   This method constructs a new instance of the Fcm::CmCommitMessageFile class.
+#
+# ARGUMENTS
+#   CONFIG - reference to a Fcm::Config instance
+#   DIR    - directory containing the commit message file
+#   BASE   - base name of the commit message file
+# ------------------------------------------------------------------------------
+
+sub new {
+  my $this  = shift;
+  my %args  = @_;
+  my $class = ref $this || $this;
+
+  my $self = {
+    CONFIG => (exists $args{CONFIG} ? $args{CONFIG} : &main::cfg),
+    DIR    => (exists $args{DIR}    ? $args{DIR}    : cwd),
+    BASE   => (exists $args{BASE}   ? $args{BASE}   : '#commit_message#'),
+    USER_M => [],
+    AUTO_M => [],
+    IGNORE => [],
+  };
+
+  bless $self, $class;
+  return $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $config = $ci_mesg->config;
+#
+# DESCRIPTION
+#   This method returns a reference to the Fcm::Config instance.
+# ------------------------------------------------------------------------------
+
+sub config {
+  my $self = shift;
+
+  return $self->{CONFIG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $dir = $ci_mesg->dir;
+#   $ci_mesg->dir ($dir);
+#
+# DESCRIPTION
+#   This method returns the directory container of the commit message file. If
+#   an argument is specified, the directory is reset using the value of the
+#   argument. (It does nothing is the directory does not already exist.)
+# ------------------------------------------------------------------------------
+
+sub dir {
+  my $self = shift;
+
+  if (@_) {
+    my $dir = shift;
+    $self->{DIR} = $dir if -d $dir;
+  }
+
+  return $self->{DIR};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $base = $ci_mesg->base;
+#   $ci_mesg->base ($base);
+#
+# DESCRIPTION
+#   This method returns the base name of the commit message file. If an
+#   argument is specified, the file is reset using the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub base {
+  my $self = shift;
+
+  if (@_) {
+    $self->{BASE} = shift;
+  }
+
+  return $self->{BASE};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $file = $ci_mesg->file;
+#   $ci_mesg->file ($file);
+#
+# DESCRIPTION
+#   This method returns the full name of the commit message file. If an
+#   argument is specified, the file is reset using the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub file {
+  my $self = shift;
+
+  if (@_) {
+    my $file      = shift;
+    $self->{DIR}  = dirname  ($file);
+    $self->{BASE} = basename ($file);
+  }
+
+  return File::Spec->catfile ($self->{DIR}, $self->{BASE});
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @mesg = $ci_mesg->user_mesg;
+#   $ci_mesg->user_mesg (@mesg);
+#
+# DESCRIPTION
+#   This method returns the user defined commit message. If an argument is
+#   specified, the message is reset using the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub user_mesg {
+  my $self = shift;
+
+  if (@_) {
+    @{ $self->{USER_M} } = @_;
+  }
+
+  return @{ $self->{USER_M} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @mesg = $ci_mesg->auto_mesg;
+#   $ci_mesg->auto_mesg (@mesg);
+#
+# DESCRIPTION
+#   This method returns the automatically inserted commit message. If an
+#   argument is specified, the message is reset using the value of the
+#   argument.
+# ------------------------------------------------------------------------------
+
+sub auto_mesg {
+  my $self = shift;
+
+  if (@_) {
+    @{ $self->{AUTO_M} } = @_;
+  }
+
+  return @{ $self->{AUTO_M} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @mesg = $ci_mesg->ignore_mesg;
+#   $ci_mesg->ignore_mesg (@mesg);
+#
+# DESCRIPTION
+#   This method returns the ignored part of a commit message. If an argument is
+#   specified, the message is reset using the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub ignore_mesg {
+  my $self = shift;
+
+  if (@_) {
+    @{ $self->{IGNORE} } = @_;
+  }
+
+  return @{ $self->{IGNORE} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   ($user, $auto) = $ci_mesg->read_file ();
+#
+# DESCRIPTION
+#   This function reads from the commit log message file. It resets the user
+#   and the automatic messages after reading the file. It returns the message
+#   back in two array references.
+# ------------------------------------------------------------------------------
+
+sub read_file {
+  my $self = shift;
+
+  my @user = ();
+  my @auto = ();
+  my $file = $self->file;
+
+  if (-r $file) {
+    open FILE, '<', $file or croak 'Cannot open ', $file, '(', $!, '), abort';
+
+    my $in_auto = 0;
+    while (<FILE>) {
+      last if index ($_, $ignore_line) == 0; # ignore after the ignore delimiter
+
+      if (index ($_, $auto_line) == 0) {
+        # Beginning of the automatically inserted message delimiter
+        $in_auto = 1;
+        next;
+      }
+
+      if ($in_auto) {
+        push @auto, $_;
+
+      } else {
+        push @user, $_;
+      }
+    }
+
+    close FILE;
+
+    $self->user_mesg (@user);
+    $self->auto_mesg (@auto);
+  }
+
+  return (\@user, \@auto);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ci_mesg->write_file ();
+#
+# DESCRIPTION
+#   This function writes to the commit log message file based on the content of
+#   the user defined message, and the automatically inserted message.
+# ------------------------------------------------------------------------------
+
+sub write_file {
+  my $self = shift;
+  my %args = @_;
+
+  my @user = $self->user_mesg;
+  my @auto = $self->auto_mesg;
+  my $file = $self->file;
+
+  open FILE, '>', $file or die 'Cannot open ', $file, '(', $!, '), abort';
+  print FILE @user;
+  print FILE $auto_line, "\n", @auto if @auto;
+  close FILE or croak 'Cannot close ', $file, '(', $!, '), abort';
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $file = $ci_mesg->edit_file ([TEMP => 1,] [BATCH => 1,]);
+#
+# DESCRIPTION
+#   This function normally triggers an editor for editing the commit message.
+#   If TEMP is set, it edits a temporary file. Otherwise, it edits the current
+#   commit message file. It resets the user defined message on success. Returns
+#   the name of the commit log file. Do not start the editor if BATCH is set.
+# ------------------------------------------------------------------------------
+
+sub edit_file {
+  my $self  = shift;
+  my %args  = @_;
+  my $temp  = exists $args{TEMP}  ? $args{TEMP}  : 0;
+  my $batch = exists $args{BATCH} ? $args{BATCH} : 0;
+
+  my @user   = $self->user_mesg;
+  my @auto   = $self->auto_mesg;
+  my @ignore = $self->ignore_mesg;
+  my $file   = $self->file;
+
+  if ($temp) {
+    my $fh;
+    ($fh, $file) = tempfile (SUFFIX => ".fcm", UNLINK => 1);
+    close $fh;
+  }
+
+  # Add original or code driven message and status information to the file
+  my $select = select;
+  open FILE, '>', $file or croak 'Cannot open ', $file, ' (', $!, '), abort';
+  select FILE;
+
+  print @user;
+  print (@auto || @user ? '' : "\n");
+  print $auto_line, "\n", @auto, "\n" if @auto;
+  print $ignore_line, "\n\n";
+  print @ignore if @ignore;
+
+  close FILE or die 'Cannot close ', $file, ' (', $!, '), abort';
+  select $select;
+
+  if (not $batch) {
+    # Select editor
+    my $editor = 'nedit';
+    
+    if ($ENV{'SVN_EDITOR'}) {
+      $editor = $ENV{'SVN_EDITOR'};
+
+    } elsif ($ENV{'VISUAL'}) {
+      $editor = $ENV{'VISUAL'};
+
+    } elsif ($ENV{'EDITOR'}) {
+      $editor = $ENV{'EDITOR'};
+    }
+
+    # Execute command to start the editor
+    print 'Starting ', $editor, ' to edit commit message ...', "\n";
+    &run_command ([split (/\s+/, $editor), $file]);
+  }
+
+  # Read the edited file, and extract user log message from it
+  open FILE, '<', $file or croak 'Cannot open ', $file, ' (', $!, '), abort';
+  my (@log);
+  my $in_auto    = 0;
+  my $in_ignored = 0;
+
+  while (<FILE>) {
+    if (index ($_, $auto_line) == 0) {
+      $in_auto = 1;
+
+    } elsif (index ($_, $ignore_line) == 0) {
+      $in_ignored = 1;
+      last;
+
+    } else {
+      next if $in_auto;
+      push @log, $_;
+    }
+  }
+
+  close FILE;
+
+  # Ensure auto and ignored lines are not altered
+  e_report 'Error: the line "', $auto_line, '" has been altered, abort.'
+    if @auto and not $in_auto;
+
+  e_report 'Error: the line "', $ignore_line, '" has been altered, abort.'
+    if not $in_ignored;
+
+  # Check for empty commit log
+  e_report 'Error: log message unchanged or not specified, abort.'
+    if join (' ', (@log, @auto)) =~ /^\s*$/;
+
+  # Echo the commit message to standard output
+  my $separator = '-' x 80 . "\n";
+  print 'Commit message is as follows:', "\n";
+  print $separator, @log, @auto, $ignore_line, "\n", @ignore, $separator;
+
+  open FILE, '>', $file or croak 'Cannot open ', $file, ' (', $!, '), abort';
+  print FILE @log, @auto;
+  close FILE or croak 'Cannot close ', $file, ' (', $!, '), abort';
+
+  # Reset the array for the user specified log message
+  $self->user_mesg (@log);
+
+  return $file;
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/CmUrl.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/CmUrl.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/CmUrl.pm	(revision 7236)
@@ -0,0 +1,1138 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Fcm::CmUrl
+#
+# DESCRIPTION
+#   This class contains methods for manipulating a Subversion URL in a standard
+#   FCM project.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::CmUrl;
+
+# Standard pragma
+use warnings;
+use strict;
+
+# Standard modules
+use Carp;
+use File::Spec;
+use HTTP::Date;
+use XML::DOM;
+
+# FCM component modules
+use Fcm::Util qw/run_command svn_date get_browser_url/;
+
+# Revision pattern
+my $rev_pattern = '\d+|HEAD|BASE|COMMITTED|PREV|\{.+\}';
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cm_url = Fcm::CmUrl->new (
+#     CONFIG  => $config,
+#     URL     => $url,
+#   );
+#
+# DESCRIPTION
+#   This method constructs a new instance of the Fcm::CmUrl class.
+#
+# ARGUMENTS
+#   CONFIG - reference to a Fcm::Config instance
+#   URL    - URL of a branch
+# ------------------------------------------------------------------------------
+
+sub new {
+  my $this  = shift;
+  my %args  = @_;
+  my $class = ref $this || $this;
+
+  my $self = {
+    CONFIG      => (exists $args{CONFIG} ? $args{CONFIG} : &main::cfg),
+    URL         => (exists $args{URL}    ? $args{URL}    : ''),
+    ANALYSED    => undef,
+    PROJECT     => undef,
+    BRANCH      => undef,
+    SUBDIR      => undef,
+    PEGREV      => undef,
+    LIST        => undef,
+    RLIST       => undef,
+    LOG         => undef,
+    LOG_RANGE   => undef,
+    INFO        => undef,
+    BRANCH_LIST => undef, # list of branches in current project
+  };
+
+  bless $self, $class;
+  return $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $config = $cm_url->config;
+#
+# DESCRIPTION
+#   This method returns a reference to the Fcm::Config instance.
+# ------------------------------------------------------------------------------
+
+sub config {
+  my $self = shift;
+
+  return $self->{CONFIG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $url = $cm_url->url_peg;
+#   $cm_url->url_peg ($url);
+#
+# DESCRIPTION
+#   This method returns/sets the current URL@PEG.
+# ------------------------------------------------------------------------------
+
+sub url_peg {
+  my $self = shift;
+
+  if (@_) {
+    if (! $self->{URL} or $_[0] ne $self->{URL}) {
+      # Re-set URL
+      $self->{URL} = shift;
+
+      # Re-set essential variables
+      $self->{$_}  = undef for (qw/ANALYSED RLIST LIST INFO LOG LOG_RANGE/);
+    }
+  }
+
+  return $self->{URL};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = $cm_url->is_url ();
+#
+# DESCRIPTION
+#   Returns true if current url is a valid Subversion URL.
+# ------------------------------------------------------------------------------
+
+sub is_url {
+  my $self = shift;
+
+  # This should handle URL beginning with svn://, http:// and svn+ssh://
+  return ($self->url_peg =~ m#^[\+\w]+://#);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = $cm_url->url_exists ([$rev]);
+#
+# DESCRIPTION
+#   Returns true if current url exists (at operative revision $rev) in a
+#   Subversion repository.
+# ------------------------------------------------------------------------------
+
+sub url_exists {
+  my ($self, $rev) = @_;
+
+  my $exists = $self->svnlist (REV => $rev);
+
+  return defined ($exists);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $string = $cm_url->svninfo ([FLAG => $flag], [REV => $rev]);
+#
+# DESCRIPTION
+#   Returns the value of $flag, where $flag is a field returned by "svn info".
+#   (If $flag is not set, default to "URL".) Otherwise returns an empty string.
+#   If REV is specified, it will be used as the operative revision.
+# ------------------------------------------------------------------------------
+
+sub svninfo {
+  my $self = shift;
+  my %args = @_;
+
+  my $flag = exists $args{FLAG} ? $args{FLAG} : 'URL';
+  my $rev  = exists $args{REV}  ? $args{REV}  : undef;
+
+  $rev = ($self->pegrev ? $self->pegrev : 'HEAD') if not $rev;
+
+  return if not $self->is_url;
+
+  # Get "info" for the specified revision if necessary
+  if (not exists $self->{INFO}{$rev}) {
+    # Invoke "svn info" command
+    my @info = &run_command (
+      [qw/svn info -r/, $rev, $self->url_peg],
+      PRINT   => $self->config->verbose > 2,
+      METHOD  => 'qx',
+      DEVNULL => 1,
+      ERROR   => 'ignore',
+    );
+
+    # Store selected information
+    for (@info) {
+      chomp;
+
+      if (/^(.+?):\s*(.+)$/) {
+        $self->{INFO}{$rev}{$1} = $2;
+      }
+    }
+  }
+
+  my $return = exists $self->{INFO}{$rev}{$flag}
+               ? $self->{INFO}{$rev}{$flag} : undef;
+
+  return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   %logs = $cm_url->svnlog (
+#     [REV          => $rev,]
+#     [REV          => \@revs,] # reference to a 2-element array
+#     [STOP_ON_COPY => 1,]
+#   );
+#
+# DESCRIPTION
+#   Returns the logs for the current URL. If REV is a range of revisions or not
+#   specified, return a hash where the keys are revision numbers and the values
+#   are the entries (which are hash references). If a single REV is specified,
+#   return the entry (a hash reference) at the specified REV. Each entry in the
+#   returned list is a hash reference, with the following structure:
+#
+#   $entry = {
+#     author => $author,              # the commit author
+#     date   => $date,                # the commit date (in seconds since epoch)
+#     msg    => $msg,                 # the log message
+#     paths  => {                     # list of changed paths
+#       $path1  => {                  # a changed path
+#         copyfrom-path => $frompath, # copy-from-path
+#         copyfrom-rev  => $fromrev,  # copy-from-revision
+#         action        => $action,   # action status code
+#       },
+#       ...     => { ... },           # ... more changed paths ...
+#     },
+#   }
+# ------------------------------------------------------------------------------
+
+sub svnlog {
+  my $self = shift;
+  my %args = @_;
+
+  my $stop_on_copy  = exists $args{STOP_ON_COPY} ? $args{STOP_ON_COPY} : 0;
+  my $rev_arg       = exists $args{REV}          ? $args{REV}          : 0;
+
+  my @revs;
+
+  # Get revision options
+  # ----------------------------------------------------------------------------
+  if ($rev_arg) {
+    if (ref ($rev_arg)) {
+      # Revsion option is an array, a range of revisions specified?
+      ($revs [0], $revs [1]) = @$rev_arg;
+
+    } else {
+      # A single revision specified
+      $revs [0] = $rev_arg;
+    }
+
+    # Expand 'HEAD' revision
+    for my $rev (@revs) {
+      next unless uc ($rev) eq 'HEAD';
+      $rev = $self->svninfo (FLAG => 'Revision', REV => 'HEAD');
+    }
+
+  } else {
+    # No revision option specified, get log for all revisions
+    $revs [0] = $self->svninfo (FLAG => 'Revision');
+    $revs [1] = 1;
+  }
+
+  $revs [1] = $revs [0] if not $revs [1];
+  @revs     = sort {$b <=> $a} @revs;
+
+  # Check whether a "svn log" run is necessary
+  # ----------------------------------------------------------------------------
+  my $need_update = ! ($revs [0] == $revs [1] and exists $self->{LOG}{$revs [0]});
+  my @ranges      = @revs;
+  if ($need_update and $self->{LOG_RANGE}) {
+    my %log_range = %{ $self->{LOG_RANGE} };
+
+    if ($stop_on_copy) {
+      $ranges [1] = $log_range{UPPER} if $ranges [1] >= $log_range{LOWER_SOC};
+
+    } else {
+      $ranges [1] = $log_range{UPPER} if $ranges [1] >= $log_range{LOWER};
+    }
+  }
+
+  $need_update = 0 if $ranges [0] < $ranges [1];
+
+  if ($need_update) {
+    # Invoke "svn log" command for all revisions of the current branch
+    # --------------------------------------------------------------------------
+    my @command = (
+      qw/svn log --xml -v/, ($stop_on_copy ? '--stop-on-copy' : ()),
+      '-r' . join (':', @ranges),
+      $self->url,
+    );
+
+    my $rc;
+    my @xml = &run_command (
+      \@command,
+      PRINT   => $self->config->verbose > 2,
+      METHOD  => 'qx',
+      DEVNULL => 1,
+      ERROR   => 'ignore',
+      RC      => \$rc,
+    );
+
+    # Parse the XML
+    # --------------------------------------------------------------------------
+    if (not $rc) {
+      my $parser = XML::DOM::Parser->new;
+      my $doc    = $parser->parse (join ('', @xml));
+
+      my $entry_list = $doc->getElementsByTagName ('logentry');
+
+      # Record the author, date, message and path change for each revision
+      for my $i (0 .. $entry_list->getLength - 1) {
+        # Select current entry from node list
+        my $entry = $entry_list->item ($i);
+        my %this = ();
+
+        # Revision is an attribute of the entry node
+        my $rev   = $entry->getAttributeNode ('revision')->getValue;
+
+        # Author, date and log message are children elements of the entry node
+        for my $key (qw/author date msg/) {
+          # Get data of each node, also convert date to seconds since epoch
+          my $node    = $entry->getElementsByTagName ($key)->item (0);
+          my $data    = ($node and $node->getFirstChild)
+                        ? $node->getFirstChild->getData : '';
+          $this{$key} = ($key eq 'date' ? str2time ($data) : $data);
+        }
+
+        # Path nodes are grand children elements of the entry node
+        my $paths = $entry->getElementsByTagName ('path');
+
+        for my $p (0 .. $paths->getLength - 1) {
+          # Select current path node from node list
+          my $node = $paths->item ($p);
+
+          # Get data from the path node
+          my $path = $node->getFirstChild->getData;
+          $this{paths}{$path} = {};
+
+          # Action, copyfrom-path and copyfrom-rev are attributes of path nodes
+          for my $key (qw/action copyfrom-path copyfrom-rev/) {
+            next unless $node->getAttributeNode ($key); # ensure attribute exists
+
+            $this{paths}{$path}{$key} = $node->getAttributeNode ($key)->getValue;
+          }
+        }
+
+        $self->{LOG}{$rev} = \%this;
+      }
+    }
+
+    # Update the range cache
+    # --------------------------------------------------------------------------
+    # Upper end of the range
+    $self->{LOG_RANGE}{UPPER} = $ranges [0]
+      if ! $self->{LOG_RANGE}{UPPER} or $ranges [0] > $self->{LOG_RANGE}{UPPER};
+
+    # Lower end of the range, need to take into account the stop-on-copy option
+    if ($stop_on_copy) {
+      # Lower end of the range with stop-on-copy option
+      $self->{LOG_RANGE}{LOWER_SOC} = $ranges [1]
+        if ! $self->{LOG_RANGE}{LOWER_SOC} or
+           $ranges [1] < $self->{LOG_RANGE}{LOWER_SOC};
+
+      my $low = (sort {$a <=> $b} keys %{ $self->{LOG} }) [0];
+      $self->{LOG_RANGE}{LOWER} = $low
+        if ! $self->{LOG_RANGE}{LOWER} or $low < $self->{LOG_RANGE}{LOWER};
+
+    } else {
+      # Lower end of the range without the stop-on-copy option
+      $self->{LOG_RANGE}{LOWER} = $ranges [1]
+        if ! $self->{LOG_RANGE}{LOWER} or
+           $ranges [1] < $self->{LOG_RANGE}{LOWER};
+
+      $self->{LOG_RANGE}{LOWER_SOC} = $ranges [1]
+        if ! $self->{LOG_RANGE}{LOWER_SOC} or
+           $ranges [1] < $self->{LOG_RANGE}{LOWER_SOC};
+    }
+  }
+
+  my %return = ();
+
+  if (! $rev_arg or ref ($rev_arg)) {
+    # REV is an array, return log entries if they are within range
+    for my $rev (sort {$b <=> $a} keys %{ $self->{LOG} }) {
+      next if $rev > $revs [0] or $revs [1] > $rev;
+
+      $return{$rev} = $self->{LOG}{$rev};
+
+      if ($stop_on_copy) {
+        last if exists $self->{LOG}{$rev}{paths}{$self->branch_path} and
+           $self->{LOG}{$rev}{paths}{$self->branch_path}{action} eq 'A';
+      }
+    }
+
+  } else {
+    # REV is a scalar, return log of the specified revision if it exists
+    %return = %{ $self->{LOG}{$revs [0]} } if exists $self->{LOG}{$revs [0]};
+  }
+
+  return %return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $string = $cm_branch->display_svnlog ($rev, [$wiki]);
+#
+# DESCRIPTION
+#   This method returns a string for displaying the log of the current branch
+#   at a $rev. If $wiki is set, returns a string for displaying in a Trac wiki
+#   table.  The value of $wiki should be the Subversion URL of a FCM project
+#   associated with the intended Trac system.
+# ------------------------------------------------------------------------------
+
+sub display_svnlog {
+  my ($self, $rev, $wiki) = @_;
+  my $return = '';
+
+  my %log = $self->svnlog (REV => $rev);
+
+  if ($wiki) {
+    # Output in Trac wiki format
+    # --------------------------------------------------------------------------
+    $return .= '|| ' . &svn_date ($log{date}) . ' || ' . $log{author} . ' || ';
+
+    my $trac_url = &get_browser_url (URL => $self->url);
+
+    # Get list of tickets from log
+    my @tickets;
+    while ($log{msg} =~ /(?:#|ticket:)(\d+)/g) {
+      push @tickets, $1;
+    }
+    @tickets = sort {$a <=> $b} @tickets;
+
+    if ($trac_url =~ m#^$wiki(?:/*|$)#) {
+      # URL is in the specified $wiki, use Trac link
+      $return .= '[' . $rev . '] ||';
+
+      for my $ticket (@tickets) {
+        $return .= ' #' . $ticket;
+      }
+
+      $return .= ' ||';
+
+    } else {
+      # URL is not in the specified $wiki, use full URL
+      my $rev_url = $trac_url;
+      $rev_url    =~ s#/browser/.*$##;
+      $rev_url   .= '/changeset/' . $rev;
+      $return    .= '[' . $rev_url . ' ' . $rev . '] ||';
+
+      my $ticket_url = $trac_url;
+      $ticket_url    =~ s#/browser/.*$#/ticket/#;
+
+      for my $ticket (@tickets) {
+        $return .= ' [' . $ticket_url . $ticket . ' ' . $ticket . ']';
+      }
+
+      $return .= ' ||';
+    }
+
+  } else {
+    # Output in plain text format
+    # --------------------------------------------------------------------------
+    my @msg  = split /\n/, $log{msg};
+    my $line = (@msg > 1 ? ' lines' : ' line');
+
+    $return .= join (
+      ' | ',
+      ('r' . $rev, $log{author}, &svn_date ($log{date}), scalar (@msg) . $line),
+    );
+    $return .= "\n\n";
+    $return .= $log{msg};
+  }
+
+  return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @list = $cm_url->svnlist ([REV => $rev], [RECURSIVE => 1]);
+#
+# DESCRIPTION
+#   The method returns a list of paths as returned by "svn list". If RECURSIVE
+#   is set, "svn list" is invoked with the "-R" option.
+# ------------------------------------------------------------------------------
+
+sub svnlist {
+  my $self = shift;
+  my %args = @_;
+
+  my $recursive = exists $args{RECURSIVE} ? $args{RECURSIVE} : 0;
+  my $rev       = exists $args{REV}       ? $args{REV}       : undef;
+  my $key       = $recursive ? 'RLIST' : 'LIST';
+
+  # Find out last changed revision of the current URL
+  $rev = $self->svninfo (FLAG => 'Last Changed Rev', REV => $rev);
+  return () if not $rev;
+
+  # Get directory listing for the current URL at the last changed revision
+  if (not exists $self->{$key}{$rev}) {
+    my $rc;
+
+    my @list = map {chomp; $_} &run_command (
+      [qw/svn list -r/, $rev, ($recursive ? '-R' : ()), $self->url_peg],
+      METHOD => 'qx', ERROR => 'ignore', DEVNULL => 1, RC => \$rc,
+    );
+
+    $self->{$key}{$rev} = $rc ? undef : \@list;
+  }
+
+  return (defined ($self->{$key}{$rev}) ? @{ $self->{$key}{$rev} } : undef);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @list = $cm_url->branch_list ($rev);
+#
+# DESCRIPTION
+#   The method returns a list of branches in the current project, assuming the
+#   FCM naming convention. If $rev if specified, it returns the list of
+#   branches at $rev.
+# ------------------------------------------------------------------------------
+
+sub branch_list {
+  my ($self, $rev) = @_;
+
+  # Current URL must be a valid FCM project
+  return if not $self->project;
+
+  # Find out last changed revision of the current URL
+  $rev = $self->svninfo (FLAG => 'Revision', REV => $rev);
+  return () if not $rev;
+
+  if (not exists $self->{BRANCH_LIST}{$rev}) {
+    $self->{BRANCH_LIST}{$rev} = [];
+
+    # Get URL of the project "branches/" sub-directory
+    my $url = Fcm::CmUrl->new (URL => $self->project_url . '/branches');
+
+    # List three levels underneath "branches/"
+    # First level, i.e. dev, test, pkg, etc
+    my @list1 = map {$url->url . '/' . $_} $url->svnlist (REV => $rev);
+    @list1    = grep m#/$#, @list1;
+
+    # Second level, i.e. user name, Shared, Rel or Config
+    my @list2;
+    for (@list1) {
+      my $u    = Fcm::CmUrl->new (URL => $_);
+      my @list = $u->svnlist (REV => $rev);
+
+      push @list2, map {$u->url . $_} @list;
+    }
+
+    # Third level, branch name
+    for (@list2) {
+      my $u    = Fcm::CmUrl->new (URL => $_);
+      my @list = map {s#/*$##; $_} $u->svnlist (REV => $rev);
+
+      push @{ $self->{BRANCH_LIST}{$rev} }, map {$u->url . $_} @list;
+    }
+  }
+
+  return @{ $self->{BRANCH_LIST}{$rev} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_analyse_url ();
+#
+# DESCRIPTION
+#   The method analyses the current URL, breaking it up into the project
+#   (substring of URL up to the slash before "trunk", "branches" or "tags"),
+#   branch name ("trunk", "branches/<type>/<id>/<name>" or "tags/<name>") and
+#   the sub-directory below the top of the project sub-tree. It re-sets the
+#   corresponding interal variables.
+# ------------------------------------------------------------------------------
+
+sub _analyse_url {
+  my $self = shift;
+  my ($url, $project, $branch, $subdir, $pegrev);
+
+  # Check that URL is set
+  $url    = $self->url_peg;
+  return if not $url;
+  return if not $self->is_url;
+
+  # Extract from URL the peg revision
+  $pegrev = $1 if $url =~ s/@($rev_pattern)$//i;
+
+  if ($url =~ m#^(.*?)/+(trunk|branches|tags)(?:/+(.*))?/*$#) {
+    # URL is under the "trunk", a branch or a tag
+    $project                 = $1;
+    my ($branch_id, $remain) = ($2, $3);
+
+    $remain = '' if not defined $remain;
+
+    if ($branch_id eq 'trunk') {
+      # URL under the "trunk"
+      $branch = 'trunk';
+
+    } else {
+      # URL under a branch or a tag
+      $branch = $branch_id;
+
+      # Assume "3 sub-directories", FCM branch naming convention
+      for (1 .. 3) {
+        if ($remain =~ s#^([^/]+)(?:/+|$)##) {
+          $branch .=  '/' . $1;
+
+        } else {
+          $branch = undef;
+          last;
+        }
+      }
+    }
+
+    $subdir = $remain ? $remain : '' if $branch;
+
+  } else {
+    # URL is at some level above the "trunk", a branch or a tag
+    # Use "svn ls" to determine whether it is a project URL
+    my @list = $self->svnlist (REV => ($pegrev ? $pegrev : 'HEAD'));
+    my %lines = map {chomp $_; ($_, 1)} @list;
+
+    # A project URL should have the "trunk", "branches" and "tags" directories
+    ($project = $url) =~ s#/*$##
+      if $lines{'trunk/'} and $lines{'branches/'} and $lines{'tags/'};
+  }
+
+  $self->{PROJECT}  = $project;
+  $self->{BRANCH}   = $branch;
+  $self->{SUBDIR}   = $subdir;
+  $self->{PEGREV}   = $pegrev;
+  $self->{ANALYSED} = 1;
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $url = $cm_url->root ();
+#
+# DESCRIPTION
+#   The method returns the repository root of the current URL.
+# ------------------------------------------------------------------------------
+
+sub root {
+  my $self = shift;
+
+  return $self->svninfo (FLAG => 'Repository Root');
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $url = $cm_url->project_url_peg ();
+#   $cm_url->project_url_peg ($url);
+#
+# DESCRIPTION
+#   The method returns the URL@PEG of the "project" part of the current URL. If
+#   an argument is specified, the URL of the "project" part and the peg
+#   revision of the current URL are re-set.
+# ------------------------------------------------------------------------------
+
+sub project_url_peg {
+  my $self = shift;
+
+  if (@_) {
+    my $url = shift;
+
+    # Re-construct URL is necessary
+    if (! $self->project_url_peg or $url ne $self->project_url_peg) {
+      my $pegrev = ($url =~ s/@($rev_pattern)$//i) ? $1 : '';
+
+      $url .= '/' . $self->branch if $self->branch;
+      $url .= '/' . $self->subdir if $self->subdir;
+      $url .= '@' . $pegrev       if $pegrev;
+
+      $self->url_peg ($url);
+    }
+  }
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  return $self->{PROJECT} . ($self->pegrev ? '@' . $self->pegrev : '');
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $url = $cm_url->project_url ();
+#   $cm_url->project_url ($url);
+#
+# DESCRIPTION
+#   The method returns the URL of the "project" part of the current URL. If an
+#   argument is specified, the URL of the "project" part of the current URL is
+#   re-set.
+# ------------------------------------------------------------------------------
+
+sub project_url {
+  my $self = shift;
+
+  if (@_) {
+    my $url = shift;
+    $url =~ s/@($rev_pattern)$//i;
+
+    # Re-construct URL is necessary
+    if (! $self->project_url or $url ne $self->project_url) {
+      $url .= '/' . $self->branch if $self->branch;
+      $url .= '/' . $self->subdir if $self->subdir;
+
+      $self->url ($url);
+    }
+  }
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  return $self->{PROJECT};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $path = $cm_url->project_path ();
+#   $cm_url->project_path ($path);
+#
+# DESCRIPTION
+#   The method returns the path of the "project" part of the current URL. If an
+#   argument is specified, the path of the "project" part of the current URL is
+#   re-set.
+# ------------------------------------------------------------------------------
+
+sub project_path {
+  my $self = shift;
+
+  # Repository root
+  my $root = $self->root;
+  $root    = substr (
+    $self->project_url,
+    0,
+    length ($self->project_url) - length ($self->project) - 1
+  ) if not $root;
+
+  if (@_) {
+    my $path = shift;
+
+    # Re-construct URL is necessary
+    if (! $self->project_path or $path ne $self->project_path) {
+      $path .= '/' . $self->branch if $self->branch;
+      $path .= '/' . $self->subdir if $self->subdir;
+
+      $self->path ($path);
+    }
+  }
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  return substr ($self->{PROJECT}, length ($root));
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $name = $cm_url->project ();
+#   $cm_url->project ($name);
+#
+# DESCRIPTION
+#   The method returns the basename of the "project" part of the current URL.
+#   If an argument is specified, the basename of the "project" part of the
+#   current URL is re-set.
+# ------------------------------------------------------------------------------
+
+sub project {
+  my $self = shift;
+
+  if (@_) {
+    my $name = shift;
+
+    # Re-construct URL is necessary
+    if (! $self->project or $name ne $self->project) {
+      my $url = '';
+      if ($self->project) {
+        $url =  $self->project;
+        $url =~ s#/[^/]+$##;
+
+      } else {
+        $url =  $self->root;
+      }
+
+      $url .=  '/' . $name;
+      $url .=  '/' . $self->branch if $self->branch;
+      $url .=  '/' . $self->subdir if $self->subdir;
+      $url .=  '@' . $self->pegrev if $self->pegrev;
+
+      $self->url_peg ($url);
+    }
+  }
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  my $name = $self->{PROJECT};
+  $name =~ s#^.*/([^/]+)$#$1# if $name;
+
+  return $name;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $url = $cm_url->branch_url_peg ();
+#   $cm_url->branch_url_peg ($url);
+#
+# DESCRIPTION
+#   The method returns the URL@PEG of the "branch" part of the current URL. If
+#   an argument is specified, the URL@PEG of the "branch" part of the current
+#   URL is re-set.
+# ------------------------------------------------------------------------------
+
+sub branch_url_peg {
+  my $self = shift;
+
+  if (@_) {
+    my $url = shift;
+
+    # Re-construct URL is necessary
+    if (! $self->branch_url_peg or $url ne $self->branch_url_peg) {
+      my $pegrev = ($url =~ s/@($rev_pattern)$//i) ? $1 : '';
+
+      $url .= '/' . $self->subdir if $self->subdir;
+      $url .= '@' . $pegrev       if $pegrev;
+
+      $self->url_peg ($url);
+    }
+  }
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  return $self->project_url . '/' . $self->branch .
+         ($self->pegrev ? '@' . $self->pegrev : '');
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $url = $cm_url->branch_url ();
+#   $cm_url->branch_url ($url);
+#
+# DESCRIPTION
+#   The method returns the URL of the "branch" part of the current URL. If an
+#   argument is specified, the URL of the "branch" part of the current URL is
+#   re-set.
+# ------------------------------------------------------------------------------
+
+sub branch_url {
+  my $self = shift;
+
+  if (@_) {
+    my $url = shift;
+    $url =~ s/@($rev_pattern)$//i;
+
+    # Re-construct URL is necessary
+    if (! $self->branch_url or $url ne $self->branch_url) {
+      $url .= '/' . $self->subdir if $self->subdir;
+
+      $self->url ($url);
+    }
+  }
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  return $self->project_url . '/' . $self->branch;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $path = $cm_url->branch_path ();
+#   $cm_url->branch_path ($path);
+#
+# DESCRIPTION
+#   The method returns the path of the "branch" part of the current URL. If an
+#   argument is specified, the path of the "branch" part of the current URL is
+#   re-set.
+# ------------------------------------------------------------------------------
+
+sub branch_path {
+  my $self = shift;
+
+  if (@_) {
+    my $path = shift;
+
+    # Re-construct URL is necessary
+    if (! $self->branch_path or $path ne $self->branch_path) {
+      $path .= '/' . $self->subdir if $self->subdir;
+
+      $self->path ($path);
+    }
+  }
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  return $self->project_path . '/' . $self->branch;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $branch = $cm_url->branch ();
+#   $cm_url->branch ($branch);
+#
+# DESCRIPTION
+#   The method returns the "branch" part of the current URL. If an argument is
+#   specified, the "branch" part of the current URL is re-set.
+# ------------------------------------------------------------------------------
+
+sub branch {
+  my $self = shift;
+
+  if (@_) {
+    my $branch = shift;
+
+    # Re-construct URL is necessary
+    if (! $self->branch or $branch ne $self->branch) {
+      my $url = $self->project_url;
+      $url   .= '/' . $branch;
+      $url   .= '/' . $self->subdir if $self->subdir;
+
+      $self->url ($url);
+    }
+  }
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  return $self->{BRANCH};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = $cm_url->is_trunk ();
+#
+# DESCRIPTION
+#   The method returns true if the the current URL is (a sub-tree of) the trunk.
+# ------------------------------------------------------------------------------
+
+sub is_trunk {
+  my $self = shift;
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  return ($self->branch and $self->branch eq 'trunk');
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = $cm_url->is_branch ();
+#
+# DESCRIPTION
+#   The method returns true if the the current URL is (a sub-tree of) a branch.
+# ------------------------------------------------------------------------------
+
+sub is_branch {
+  my $self = shift;
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  return ($self->branch and $self->branch =~ m#^branches/#);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = $cm_url->is_tag ();
+#
+# DESCRIPTION
+#   The method returns true if the the current URL is (a sub-tree of) a tag.
+# ------------------------------------------------------------------------------
+
+sub is_tag {
+  my $self = shift;
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  return ($self->branch and $self->branch =~ m#^tags/#);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $subdir = $cm_url->subdir ();
+#   $cm_url->subdir ($subdir);
+#
+# DESCRIPTION
+#   The method returns the "subdir" part of the current URL. If an argument is
+#   specified, the "subdir" part of the current URL is re-set.
+# ------------------------------------------------------------------------------
+
+sub subdir {
+  my $self = shift;
+
+  if (@_) {
+    my $subdir = shift;
+
+    # Re-construct URL is necessary
+    if (! $self->subdir or $subdir ne $self->subdir) {
+      my $url = $self->project_url;
+      $url   .= '/' . $self->branch if $self->branch;
+      $url   .= '/' . $subdir if $subdir;
+
+      $self->url ($url);
+    }
+  }
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  return $self->{SUBDIR};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $url = $cm_url->url ();
+#   $cm_url->url ($url);
+#
+# DESCRIPTION
+#   The method returns the URL without the "peg revision" part. If an argument
+#   is specified, the URL is re-set without modifying the "peg revision" part.
+# ------------------------------------------------------------------------------
+
+sub url {
+  my $self = shift;
+
+  if (@_) {
+    my $url = shift;
+    $url    =~ s/@($rev_pattern)$//i;
+
+    # Re-construct URL if necessary
+    if (! $self->url or $url ne $self->url) {
+      $self->url_peg ($url . ($self->pegrev ? '@' . $self->pegrev : ''));
+    }
+  }
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  (my $url = $self->url_peg) =~ s/@($rev_pattern)$//i;
+
+  return $url;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $path = $cm_url->path ();
+#   $cm_url->path ($path);
+#
+# DESCRIPTION
+#   The method returns the "path" part of the URL (i.e. URL without the
+#   "root" part). If an argument is specified, the "path" part of the URL is
+#   re-set.
+# ------------------------------------------------------------------------------
+
+sub path {
+  my $self = shift;
+
+  # Repository root
+  my $root = $self->root;
+  $root    = substr (
+    $self->project_url,
+    0,
+    length ($self->project_url) - length ($self->project) - 1
+  ) if not $root;
+
+  if (@_) {
+    my $path = shift;
+    $path    =~ s/@($rev_pattern)$//i;
+
+    # Re-construct URL is necessary
+    if (! $self->path or $path ne $self->path) {
+      my $url = ($root . (substr ($path, 0, 1) eq '/' ? '' : '/') . $path);
+      $self->url ($url);
+    }
+  }
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  return substr ($self->url, length ($root));
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $path = $cm_url->path_peg ();
+#   $cm_url->path_peg ($path);
+#
+# DESCRIPTION
+#   The method returns the PATH@PEG part of the URL (i.e. URL without the
+#   "root" part). If an argument is specified, the PATH@PEG part of the URL is
+#   re-set.
+# ------------------------------------------------------------------------------
+
+sub path_peg {
+  my $self = shift;
+
+  # Repository root
+  my $root = $self->root;
+  $root    = substr (
+    $self->project_url,
+    0,
+    length ($self->project_url) - length ($self->project) - 1
+  ) if not $root;
+
+  if (@_) {
+    my $path = shift;
+
+    # Re-construct URL is necessary
+    if (! $self->path_peg or $path ne $self->path_peg) {
+      my $url = ($root . (substr ($path, 0, 1) eq '/' ? '' : '/') . $path);
+      $self->url_peg ($url);
+    }
+  }
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  return substr ($self->url_peg, length ($root));
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rev = $cm_url->pegrev ();
+#   $cm_url->pegrev ($rev);
+#
+# DESCRIPTION
+#   The method returns the "peg revision" part of the current URL. If an
+#   argument is specified, the "peg revision" part of the current URL is
+#   re-set.
+# ------------------------------------------------------------------------------
+
+sub pegrev {
+  my $self = shift;
+
+  if (@_) {
+    my $pegrev = shift;
+
+    # Re-construct URL is necessary
+    if (! $self->pegrev or $pegrev ne $self->pegrev) {
+      $self->url_peg ($self->url . ($pegrev ? '@' . $pegrev : ''));
+    }
+  }
+
+  $self->_analyse_url () if not $self->{ANALYSED};
+
+  return $self->{PEGREV};
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Config.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Config.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Config.pm	(revision 7236)
@@ -0,0 +1,735 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Fcm::Config
+#
+# DESCRIPTION
+#   This is a class for reading and processing central and user configuration
+#   settings for FCM.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::Config;
+
+# Standard pragma
+use warnings;
+use strict;
+
+# Standard modules
+use File::Basename;
+use File::Spec::Functions;
+use FindBin;
+use POSIX qw/setlocale LC_ALL/;
+
+# FCM component modules
+use Fcm::CfgFile;
+
+# Other declarations:
+sub _get_hash_value;
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $config = Fcm::Config->new (VERBOSE => $verbose);
+#
+# DESCRIPTION
+#   This method constructs a new instance of the Fcm::Config class.
+#
+# ARGUMENTS
+#   VERBOSE - Set the verbose level of diagnostic output
+# ------------------------------------------------------------------------------
+
+sub new {
+  my $this  = shift;
+  my %args  = @_;
+  my $class = ref $this || $this;
+
+  # Ensure that all subsequent Subversion output is in UK English
+  if (setlocale (LC_ALL, 'en_GB')) {
+    $ENV{LANG} = 'en_GB';
+  }
+
+  # Location of the central/user configuration file
+  my $cntl_config = catfile (dirname ($FindBin::Bin), 'etc', 'fcm.cfg');
+  $cntl_config    = catfile $FindBin::Bin, 'fcm.cfg' unless -r $cntl_config;
+  my $user_config = exists $ENV{HOME} ? catfile $ENV{HOME}, '.fcm' : '';
+
+  # Verbose mode
+  my $verbose     = exists $ENV{FCM_VERBOSE} ? $ENV{FCM_VERBOSE} : 1;
+
+  my $self = {
+    CNTL_CONFIG => -r $cntl_config ? $cntl_config : '',
+    USER_CONFIG => -r $user_config ? $user_config : '',
+    VERBOSE     => exists $args{VERBOSE} ? $args{VERBOSE} : $verbose,
+    VARIABLE    => {},
+
+    # Primary settings
+    SETTING => {
+      # Release identifier/version
+      RELEASE  => '1.2',
+
+      # Location of file with the last changed revision of the FCM trunk
+      REV_FILE => catfile (dirname ($FindBin::Bin), 'etc', 'fcm_rev'),
+
+      # Default names of known FCM configuration files
+      CFG_NAME => {
+        BLD        => 'bld.cfg',      # bld cfg
+        EXT        => 'ext.cfg',      # ext cfg
+        SRCPACKAGE => '@PACKAGE.cfg', # source package cfg
+      },
+
+      # Latest version of known FCM configuration files
+      CFG_VERSION => {
+        BLD        => '1.0', # bld cfg
+        EXT        => '1.0', # ext cfg
+        SRCPACKAGE => '1.0', # source package cfg
+      },
+
+      # Labels for all types of FCM configuration files
+      CFG_LABEL => {
+        CFGFILE => {
+          TYPE    => 'CFG::TYPE',       # config file type
+          VERSION => 'CFG::VERSION',    # version of config file syntax
+        },
+
+        # Labels for central/user internal config setting
+        SETTING    => 'SET',
+
+        # Labels for ext and bld cfg
+        USE        => 'USE',            # use (inherit from) another ext/bld
+        SRCDIR     => 'SRC',            # prefix, source directory
+
+        # Labels for bld and pck cfg
+        TARGET     => 'TARGET',         # BLD: targets of current build
+                                        # PCK: target name of source file
+
+        # Labels for bld cfg
+        NAME        => 'NAME',          # build name
+        DIR         => 'DIR',           # prefix, build directory
+        PP          => 'PP',            # prefix, pre-process?
+        LIB         => 'LIB',           # declare name of a library
+        SEARCH_SRC  => 'SEARCH_SRC',    # search src/ sub-directory?
+        EXE_NAME    => 'EXE_NAME',      # rename a main program target
+        TOOL        => 'TOOL',          # prefix, build tool
+        INHERIT     => 'INHERIT',       # prefix, inheritance flag
+        EXCL_DEP    => 'EXCL_DEP',      # exclude these automatic dependencies
+        INFILE_EXT  => 'INFILE_EXT',    # input file name extension and type
+        OUTFILE_EXT => 'OUTFILE_EXT',   # output file type and name extension
+        EXE_DEP     => 'EXE_DEP',       # extra executable dependencies
+        BLOCKDATA   => 'BLOCKDATA',     # BLOCKDATA dependencies
+
+        # Labels for ext cfg
+        DEST       => {                 # local extract destinations
+          ROOTDIR  => 'DEST::ROOTDIR',  # top directory for this extract
+          SRCDIR   => 'DEST::SRCDIR',   # extracted source directory
+          CFGDIR   => 'DEST::CFGDIR',   # generated configuration directory
+          CACHEDIR => 'DEST::CACHEDIR', # cache directory for fast extract
+          BLD_CFG  => 'DEST::BLD_CFG',  # generated bld cfg file
+          EXT_CFG  => 'DEST::EXT_CFG',  # generated ext cfg file
+        },
+        RDEST      => {                 # remote extract destionations
+          MACHINE  => 'RDEST::MACHINE', # name of remote machine
+          LOGNAME  => 'RDEST::LOGNAME', # user logname on remote machine
+          ROOTDIR  => 'RDEST::ROOTDIR', # top directory for this extract
+          SRCDIR   => 'RDEST::SRCDIR',  # extracted source directory
+          CFGDIR   => 'RDEST::CFGDIR',  # generated configuration directory
+          BLD_CFG  => 'RDEST::BLD_CFG', # generated bld cfg file
+          EXT_CFG  => 'RDEST::EXT_CFG', # generated ext cfg file
+        },
+        INC        => 'INC',            # "include" settings in another cfg file
+        BDECLARE   => 'BLD',            # declare entries for build system
+        OVERRIDE   => 'OVERRIDE',       # set conflict override option
+        REPOS      => 'REPOS',          # set repos loc for a project branch
+        VERSION    => 'VERSION',        # set version for a project branch
+        EXPSRCDIR  => 'EXPSRC',         # prefix, expandable source directory
+        MIRROR     => 'MIRROR',         # mirror tool
+
+        # Labels for pck cfg
+        TYPE       => 'TYPE',           # type of source file/build task
+        SCAN       => 'SCAN',           # scan source file for dependency
+        INTNAME    => 'INTNAME',        # internal name of source file
+        DEP        => 'DEP',            # source file/build task dependencies
+      },
+
+      # Keywords in known FCM configuration files
+      CFG_KEYWORD => 'USE,INC,TARGET,EXCL_DEP',
+
+      # Types of "inc" statements expandable CFG files
+      CFG_EXP_INC => 'BLD,EXT,FCM',
+
+      # Standard sub-directories for extract/build
+      DIR => {
+        BIN    => 'bin',    # executable
+        BLD    => 'bld',    # build
+        CACHE  => '.cache', # cache
+        CFG    => 'cfg',    # configuration
+        DONE   => 'done',   # "done"
+        ETC    => 'etc',    # miscellaneous items
+        FLAGS  => 'flags',  # "flags"
+        INC    => 'inc',    # include
+        LIB    => 'lib',    # library
+        OBJ    => 'obj',    # object
+        PPSRC  => 'ppsrc',  # pre-processed source
+        SRC    => 'src',    # source
+        TMP    => 'tmp',    # temporary directory
+      },
+
+      # Build commands and options (i.e. tools)
+      TOOL => {
+        SHELL        => '/usr/bin/ksh',    # Default shell
+
+        CPP          => 'cpp',             # C pre-processor
+        CPPFLAGS     => '-C',              # CPP flags
+        CPP_INCLUDE  => '-I',              # CPP flag, specify "include" path
+        CPP_DEFINE   => '-D',              # CPP flag, define macro
+        CPPKEYS      => '',                # CPP keys (definition macro)
+
+        CC           => 'cc',              # C compiler
+        CFLAGS       => '',                # CC flags
+        CC_COMPILE   => '-c',              # CC flag, compile only
+        CC_OUTPUT    => '-o',              # CC flag, specify output file name
+        CC_INCLUDE   => '-I',              # CC flag, specify "include" path
+        CC_DEFINE    => '-D',              # CC flag, define macro
+
+        FPP          => 'cpp',             # Fortran pre-processor
+        FPPFLAGS     => '-P -traditional', # FPP flags
+        FPP_INCLUDE  => '-I',              # FPP flag, specify "include" path
+        FPP_DEFINE   => '-D',              # FPP flag, define macro
+        FPPKEYS      => '',                # FPP keys (definition macro)
+
+        FC           => 'f90',             # Fortran compiler
+        FFLAGS       => '',                # FC flags
+        FC_COMPILE   => '-c',              # FC flag, compile only
+        FC_OUTPUT    => '-o',              # FC flag, specify output file name
+        FC_INCLUDE   => '-I',              # FC flag, specify "include" path
+        FC_DEFINE    => '-D',              # FC flag, define macro
+
+        LD           => 'ld',              # linker
+        LDFLAGS      => '',                # LD flags
+        LD_OUTPUT    => '-o',              # LD flag, specify output file name
+        LD_LIBSEARCH => '-L',              # LD flag, specify "library" path
+        LD_LIBLINK   => '-l',              # LD flag, specify link library
+
+        AR           => 'ar',              # library archiver
+        ARFLAGS      => 'rs',              # AR flags
+
+        MAKE         => 'make',            # make command
+        MAKEFLAGS    => '',                # make flags
+        MAKE_SILENT  => '-s',              # make flag, silent diagnostic
+        MAKE_JOB     => '-j',              # make flag, number of jobs
+
+        INTERFACE    => 'file',            # name interface after file/program
+        GENINTERFACE => 'ECMWF',           # Fortran 9x interface generator
+
+        MIRROR       => 'rsync',           # extract mirroring tool
+        REMOTE_SHELL => 'remsh',           # command to invoke the remote shell
+        GRAPHIC_DIFF => 'xxdiff',          # graphical diff tool
+      },
+
+      # List of tools that are local to FCM, (will not be exported to a Makefile)
+      LOCALTOOL => 'CPP,CPPFLAGS,CPP_INCLUDE,CPP_DEFINE,FPP,FPPFLAGS,' .
+                   'FPP_INCLUDE,FPP_DEFINE,GRAPHIC_DIFF,MAKE,MAKEFLAGS,' .
+                   'MAKE_SILENT,MAKE_JOB,INTERFACE,GENINTERFACE,MIRROR,' .
+                   'REMOTE_SHELL',
+
+      # Supported tools for compilable source
+      SRC_TOOL => {
+        FORTRAN => {
+          COMPILER => 'FC',
+          FLAGS    => 'FFLAGS',
+          OUTPUT   => 'FC_OUTPUT',
+          INCLUDE  => 'FC_INCLUDE',
+        },
+
+        FPP     => {
+          COMPILER => 'FC',
+          FLAGS    => 'FFLAGS',
+          PPKEYS   => 'FPPKEYS',
+          OUTPUT   => 'FC_OUTPUT',
+          INCLUDE  => 'FC_INCLUDE',
+          DEFINE   => 'FC_DEFINE',
+        },
+
+        C       => {
+          COMPILER => 'CC',
+          FLAGS    => 'CFLAGS',
+          PPKEYS   => 'CPPKEYS',
+          OUTPUT   => 'CC_OUTPUT',
+          INCLUDE  => 'CC_INCLUDE',
+          DEFINE   => 'CC_DEFINE',
+        },
+      },
+
+      # Cache file names/extensions
+      CACHE => {
+        EXTCONFIG   => '.config',       # ext cache, commit version info
+        PCKFILE     => '.pck_file',     # bld cache, source package list
+        PCKPPDEPEND => '.pck_ppdepend', # bld cache, source package PP dependency
+        PCKDEPEND   => '.pck_depend',   # bld cache, source package dependency
+        BLDTOOL     => '.bld_tool',     # bld cache, build tool list
+        PPOPTION    => '.bld_pp',       # bld cache, PP option
+        EXE_DEP     => '.exe_dep',      # bld cache, executable extra dependency
+      },
+
+      # Input file name extension and type
+      # (may overlap with output and vpath, see below)
+      INFILE_EXT => {
+        # General extensions
+        'f'    => 'FORTRAN::SOURCE',
+        'for'  => 'FORTRAN::SOURCE',
+        'ftn'  => 'FORTRAN::SOURCE',
+        'f77'  => 'FORTRAN::SOURCE',
+        'f90'  => 'FORTRAN::FORTRAN9X::SOURCE',
+        'f95'  => 'FORTRAN::FORTRAN9X::SOURCE',
+        'F'    => 'FPP::SOURCE',
+        'FOR'  => 'FPP::SOURCE',
+        'FTN'  => 'FPP::SOURCE',
+        'F77'  => 'FPP::SOURCE',
+        'F90'  => 'FPP::FPP9X::SOURCE',
+        'F95'  => 'FPP::FPP9X::SOURCE',
+        'c'    => 'C::SOURCE',
+        'cpp'  => 'C::C++::SOURCE',
+        'h'    => 'CPP::INCLUDE',
+        'o'    => 'BINARY::OBJ',
+        'obj'  => 'BINARY::OBJ',
+        'exe'  => 'BINARY::EXE',
+        'a'    => 'BINARY::LIB',
+        'sh'   => 'SHELL::SCRIPT',
+        'ksh'  => 'SHELL::SCRIPT',
+        'bash' => 'SHELL::SCRIPT',
+        'csh'  => 'SHELL::SCRIPT',
+        'pl'   => 'PERL::SCRIPT',
+        'pm'   => 'PERL::SCRIPT',
+        'py'   => 'PYTHON::SCRIPT',
+        'tcl'  => 'TCL::SCRIPT',
+        'pro'  => 'PVWAVE::SCRIPT',
+
+        # Local extensions
+        'cfg'       => 'CFGFILE',
+        'h90'       => 'CPP::INCLUDE',
+        'inc'       => 'FORTRAN::FORTRAN9X::INCLUDE',
+        'interface' => 'FORTRAN::FORTRAN9X::INCLUDE::INTERFACE',
+      },
+
+      # Input file name pattern and type
+      INFILE_PAT => {
+        '\w+Scr_\w+'              => 'SHELL::SCRIPT',
+        '\w+Comp_\w+'             => 'SHELL::SCRIPT::GENTASK',
+        '\w+(?:IF|Interface)_\w+' => 'SHELL::SCRIPT::GENIF',
+        '\w+Suite_\w+'            => 'SHELL::SCRIPT::GENSUITE',
+        '\w+List_\w+'             => 'SHELL::SCRIPT::GENLIST',
+        '\w+Sql_\w+'              => 'SCRIPT::SQL',
+      },
+
+      # Input text file pattern and type
+      INFILE_TXT => {
+        '(?:[ck]|ba)?sh'  => 'SHELL::SCRIPT',
+        'perl'            => 'PERL::SCRIPT',
+        'python'          => 'PYTHON::SCRIPT',
+        'tcl(?:sh)?|wish' => 'TCL::SCRIPT',
+      },
+
+      # Ignore input files matching the following names (comma-separated list)
+      INFILE_IGNORE => 'fcm_env.ksh',
+
+      # Output file type and extension
+      # (may overlap with input (above) and vpath (below))
+      OUTFILE_EXT => {
+        CFG       => '.cfg',       # FCM configuration file
+        DONE      => '.done',      # "done" files for compiled source
+        ETC       => '.etc',       # "etc" dummy file
+        EXE       => '.exe',       # binary executables
+        FLAGS     => '.flags',     # "flags" files, compiler flags config
+        IDONE     => '.idone',     # "done" files for included source
+        INTERFACE => '.interface', # interface for F90 subroutines/functions
+        LIB       => '.a',         # archive object library
+        MK        => '.mk',        # dependency files, Makefile fragments
+        MOD       => '.mod',       # compiled Fortran module information files
+        OBJ       => '.o',         # compiled object files
+        PDONE     => '.pdone',     # "done" files for pre-processed files
+        TAR       => '.tar',       # TAR archive
+      },
+
+      # VPATH, each value must be a comma separate list
+      # EMPTY      translates to %
+      # IN:<FLAG>  translates to any key in {INFILE_EXT} if the value contains
+      #            the word in <FLAG>
+      # OUT:<FLAG> translates to {OUTFILE_EXT}{<FLAG>}
+      VPATH   => {
+        BIN   => 'EMPTY,OUT:EXE,IN:SCRIPT',
+        BLD   => 'OUT:MK',
+        DONE  => 'OUT:DONE,OUT:IDONE,OUT:ETC',
+        FLAGS => 'OUT:FLAGS',
+        INC   => 'IN:INCLUDE',
+        LIB   => 'OUT:LIB',
+        OBJ   => 'OUT:OBJ',
+      },
+
+      # Dependency scan types for pre-processing
+      PP_DEP_TYPE => {
+        FPP => 'H',
+        CPP => 'H',
+        C   => 'H',
+      },
+
+      # Dependency scan types
+      DEP_TYPE => {
+        FORTRAN => 'USE::INTERFACE::INC::OBJ',
+        FPP     => 'USE::INTERFACE::INC::H::OBJ',
+        CPP     => 'H::OBJ',
+        C       => 'H::OBJ',
+        SCRIPT  => 'EXE',
+      },
+
+      # Dependency pattern for each type
+      DEP_PATTERN => {
+        H         => q/^#\s*include\s*['"](\S+)['"]/,
+        USE       => q/^\s*use\s+(\w+)/,
+        INTERFACE => q/^#?\s*include\s+['"](\S+##OUTFILE_EXT::INTERFACE##)['"]/,
+        INC       => q/^\s*include\s+['"](\S+)['"]/,
+        OBJ       => q#^\s*(?:/\*|!)\s*depends\s*on\s*:\s*(\S+)#,
+        EXE       => q/^\s*(?:#|;)\s*(?:calls|list|if|interface)\s*:\s*(\S+)/,
+      },
+
+      # Types that always need to be built
+      ALWAYS_BUILD_TYPE => 'PVWAVE,GENLIST,SQL',
+
+      # Types that cannot have duplicated targets
+      NO_DUPLICATED_TARGET_TYPE => '',
+
+      # Excluded dependency
+      EXCL_DEP => {
+        # Fortran intrinsic modules
+        'USE::ISO_C_BINDING'            => {'' => 1},
+        'USE::IEEE_EXCEPTIONS'          => {'' => 1},
+        'USE::IEEE_ARITHMETIC'          => {'' => 1},
+        'USE::IEEE_FEATURES'            => {'' => 1},
+
+        # Fortran intrinsic subroutines
+        'OBJ::CPU_TIME'                 => {'' => 1},
+        'OBJ::GET_COMMAND'              => {'' => 1},
+        'OBJ::GET_COMMAND_ARGUMENT'     => {'' => 1},
+        'OBJ::GET_ENVIRONMENT_VARIABLE' => {'' => 1},
+        'OBJ::MOVE_ALLOC'               => {'' => 1},
+        'OBJ::MVBITS'                   => {'' => 1},
+        'OBJ::RANDOM_NUMBER'            => {'' => 1},
+        'OBJ::RANDOM_SEED'              => {'' => 1},
+        'OBJ::SYSTEM_CLOCK'             => {'' => 1},
+
+        # Dummy statements
+        'OBJ::NONE'                     => {'' => 1},
+        'EXE::NONE'                     => {'' => 1},
+      },
+
+      # Extra executable dependencies
+      EXE_DEP => {},
+
+      # Fortran BLOCKDATA dependencies
+      BLOCKDATA => {},
+
+      # Rename main program targets
+      EXE_NAME => {},
+
+      # Build sub-directories that can be archived by "tar"
+      TAR_DIRS => 'BLD,CACHE,DONE,FLAGS,INC,PPSRC,OBJ',
+
+      # Misc
+      MISC => {
+        CPDUMMY       => '$(FCM_DONEDIR)/FCM_CP.dummy',
+                                         # build system "copy" dummy target
+        DIR_SEPARATOR => '/',            # repository directory separator
+        EXPURL_PREFIX => 'fcm:',         # expandable URL keyword prefix
+        LOCK_BLD      => 'fcm.bld.lock', # build lock file
+        LOCK_EXT      => 'fcm.ext.lock', # extract lock file
+        MAKEFILE      => 'Makefile',     # name of Makefile
+        RUN_ENV_SH    => 'fcm_env.ksh',  # bld runtime environment shell script
+        WEB_BROWSER   => 'firefox',      # web browser
+      },
+
+      # URL, revision, and Trac URL keywords
+      URL      => {},
+      REVISION => {},
+      TRAC     => {},
+    },
+  };
+
+  # Backward compatibility: the REPOS setting is equivalent to the URL setting
+  $self->{SETTING}{REPOS} = $self->{SETTING}{URL};
+
+  bless $self, $class;
+  return $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $file = $config->central_config ();
+#   $config->central_config ($file);
+#
+# DESCRIPTION
+#   This method returns the path name of the central configuration file. If an
+#   argument $file is specified, the path name of the central configuration
+#   file is set to its value.
+# ------------------------------------------------------------------------------
+
+sub central_config {
+  my $self = shift;
+
+  if (@_) {
+    $self->{CNTL_CONFIG} = $_[0];
+  }
+
+  return $self->{CNTL_CONFIG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $file = $config->user_config ();
+#   $config->user_config ($file);
+#
+# DESCRIPTION
+#   This method returns the path name of the user configuration file. If an
+#   argument $file is specified, the path name of the user configuration file
+#   is set to its value.
+# ------------------------------------------------------------------------------
+
+sub user_config {
+  my $self = shift;
+
+  if (@_) {
+    $self->{USER_CONFIG} = $_[0];
+  }
+
+  return $self->{USER_CONFIG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $mode = $config->verbose ();
+#   $config->verbose ($mode);
+#
+# DESCRIPTION
+#   This method returns the diagnostic verbose level. If an argument $mode is
+#   specified, the diagnostic verbose level is set to its value.
+# ------------------------------------------------------------------------------
+
+sub verbose {
+  my $self = shift;
+
+  if (@_) {
+    $self->{VERBOSE} = $_[0];
+  }
+
+  return $self->{VERBOSE};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $setting = $config->setting (arg, [...]);
+#
+# DESCRIPTION
+#   This method returns an item under the SETTING hash table. The depth within
+#   the hash table is given by the list of arguments, which should match with
+#   the keys in the multi-dimension SETTING hash table.
+# ------------------------------------------------------------------------------
+
+sub setting {
+  my $self = shift;
+
+  if (@_) {
+    my $label   = shift;
+    my $setting = $self->{SETTING};
+    return _get_hash_value ($setting->{$label}, @_) if exists $setting->{$label};
+  }
+
+  return undef;
+
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $config->assign_setting (
+#     LABELS => \@labels, # setting labels
+#     VALUE  => $value,   # setting value
+#   );
+#
+# DESCRIPTION
+#   This method assigns a VALUE to a SETTING specified by the names in LABEL.
+# ------------------------------------------------------------------------------
+
+sub assign_setting {
+  my $self = shift;
+  my %args = @_;
+
+  my @labels = exists $args{LABELS} ? @{ $args{LABELS} } : ();
+  my $value  = exists $args{VALUE}  ? $args{VALUE}       : undef;
+
+  my $setting = $self->{SETTING};
+  while (defined (my $label = shift @labels)) {
+    if (exists $setting->{$label}) {
+      if (ref $setting->{$label}) {
+        $setting = $setting->{$label};
+
+      } else {
+        $setting->{$label} = $value;
+        last;
+      }
+
+    } else {
+      if (@labels) {
+        $setting->{$label} = {};
+        $setting           = $setting->{$label};
+
+      } else {
+        $setting->{$label} = $value;
+      }
+    }
+  }
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $variable = $config->variable ([arg]);
+#
+# DESCRIPTION
+#   If arg is set, this method returns the value of a variable named arg. If
+#   arg is not set, this method returns the VARIABLE hash.
+# ------------------------------------------------------------------------------
+
+sub variable {
+  my $self     = shift;
+
+  my $variable = $self->{VARIABLE};
+
+  if (@_) {
+    my $label   = shift;
+    return exists $variable->{$label} ? $variable->{$label} : undef;
+
+  } else {
+    return %{ $variable };
+  }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $config->assign_variable (
+#     LABEL => $label, # variable label
+#     VALUE => $value, # variable value
+#   );
+#
+# DESCRIPTION
+#   This method assigns a VALUE to a VARIABLE named by LABEL.
+# ------------------------------------------------------------------------------
+
+sub assign_variable {
+  my $self = shift;
+  my %args = @_;
+
+  my $label = exists $args{LABEL} ? $args{LABEL} : undef;
+  my $value = exists $args{VALUE} ? $args{VALUE} : undef;
+
+  if ($label) {
+    $self->{VARIABLE}{$label} = $value;
+  }
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $config->get_config ();
+#
+# DESCRIPTION
+#   This method reads the configuration settings from the central and the user
+#   configuration files.
+# ------------------------------------------------------------------------------
+
+sub get_config {
+  my $self = shift;
+
+  $self->_read_config_file ($self->{CNTL_CONFIG}) if $self->{CNTL_CONFIG};  
+  $self->_read_config_file ($self->{USER_CONFIG}) if $self->{USER_CONFIG};
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $config->_read_config_file ();
+#
+# DESCRIPTION
+#   This internal method reads a configuration file and assign values to the
+#   attributes of the current instance.
+# ------------------------------------------------------------------------------
+
+sub _read_config_file {
+  my $self        = shift;
+  my $config_file = $_[0];
+
+  return undef unless -r $config_file;
+
+  my $cfgfile = Fcm::CfgFile->new (SRC => $config_file, TYPE => 'FCM');
+  $cfgfile->read_cfg ();
+  my @lines = $cfgfile->lines ();
+
+  LINE: for my $line (@lines) {
+    my $label = $line->{LABEL};
+    my $value = $line->{VALUE};
+
+    next unless $label;
+
+    # "Environment variables" start with $
+    if ($label =~ s/^\$([A-Za-z_]\w*)$/$1/) {
+      $ENV{$label} = $value;
+      next LINE;
+    }
+
+    # "Settings variables" start with "set::"
+    my @tags = map {uc $_} split (/::/, $label);
+    if ($tags[0] eq uc $self->{SETTING}{CFG_LABEL}{SETTING}) {
+      shift @tags;
+      $self->assign_setting (LABELS => \@tags, VALUE => $value);
+      next LINE;
+    }
+
+    # Not a standard setting variable, put in internal variable list
+    $label =~ s/^\%//;
+    $self->assign_variable (LABEL => $label, VALUE => $value);
+  }
+
+  1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ref = _get_hash_value (arg1, arg2, ...);
+#
+# DESCRIPTION
+#   This internal method recursively gets a value from a multi-dimensional
+#   hash.
+# ------------------------------------------------------------------------------
+
+sub _get_hash_value {
+  my $value = shift;
+
+  while (defined (my $arg = shift)) {
+    if (exists $value->{$arg}) {
+      $value = $value->{$arg};
+
+    } else {
+      return undef;
+    }
+  }
+
+  return $value;
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Extract.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Extract.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Extract.pm	(revision 7236)
@@ -0,0 +1,1768 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Fcm::Extract
+#
+# DESCRIPTION
+#   This class contains methods for carrying out the various tasks that are
+#   required to extract code from the FCM Subversion repository for feeding
+#   into the prototype build system. At the end of the extract, it writes a
+#   build configuration file for feeding into the build system.  If the code
+#   is to be built on a remote machine, it is mirrored to the remote machine
+#   using a "rdist" or "rsync" interface.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::Extract;
+
+# Standard pragma
+use warnings;
+use strict;
+
+# Standard modules
+use Carp;
+use File::Spec;
+use File::Spec::Functions;
+use File::Basename;
+use File::Path;
+use File::Compare;
+
+# FCM component modules
+use Fcm::CfgFile;
+use Fcm::ReposBranch;
+use Fcm::SrcDirLayer;
+use Fcm::Util;
+use Fcm::Timer;
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ext = Fcm::Extract->new (
+#     CONFIG    => $config,
+#     CFG_SRC   => $cfg_src,
+#     EXTRACTED => $extracted,
+#   );
+#
+# DESCRIPTION
+#   This method constructs a new instance of the Fcm::Extract class.
+#
+# ARGUMENTS
+#   CONFIG     - reference to a Fcm::Config instance
+#   CFG_SRC    - source path to the extract configuration file
+#   EXTRACTED  - is it a pre-extracted object?
+# ------------------------------------------------------------------------------
+
+sub new {
+  my $this  = shift;
+  my %args  = @_;
+  my $class = ref $this || $this;
+
+  my $cfg       = exists $args{CFG_SRC}   ? $args{CFG_SRC}   : undef;
+  my $extracted = exists $args{EXTRACTED} ? $args{EXTRACTED} : undef;
+  my $config    = exists $args{CONFIG}    ? $args{CONFIG}    : &main::cfg;
+
+  my $self = {
+    CONFIG     => $config,            # configuration settings
+    CFG        => Fcm::CfgFile->new ( # ext cfg for this extract
+      SRC      => $cfg,               # source path of the config file
+      TYPE     => 'ext',              # config file type
+      CONFIG   => $config,            # configuration settings
+    ),
+    DEST       => {                   # destination info for this extract
+      ROOTDIR  => undef,              # destination root directory
+      CACHEDIR => undef,              # extract cache directory
+      CFGDIR   => undef,              # destination configuration directory
+      SRCDIR   => undef,              # destination source directory
+      BLD_CFG  => undef,              # bld cfg for the build system
+      EXT_CFG  => undef,              # ext cfg for subsequent extract
+    },
+    RDEST      => {                   # remote destination information
+      MACHINE  => undef,              # destination machine
+      LOGNAME  => undef,              # remote login name
+      ROOTDIR  => undef,              # destination root directory
+      CFGDIR   => undef,              # destination configuration directory
+      SRCDIR   => undef,              # destination source directory
+      BLD_CFG  => undef,              # bld cfg for the build system
+      EXT_CFG  => undef,              # ext cfg for subsequent extract
+    },
+    BDECLARE   => [],                 # list of declared bld cfg entries
+    OVERRIDE   => 0,                  # override conflicting patches?
+    EXTRACTED  => $extracted,         # is the current object pre-extracted?
+    USE        => [],                 # list of re-used extracts
+    BRANCHES   => [],                 # list of repository branch info
+    SRCDIRS    => {},                 # list of source directory extract info
+    LOCK       => undef,              # lock file
+  };
+  bless $self, $class;
+  return $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->DESTROY;
+#
+# DESCRIPTION
+#   This method is called automatically when a Fcm::Extract object is
+#   destroyed.
+# ------------------------------------------------------------------------------
+
+sub DESTROY {
+  my $self = shift;
+
+  # Remove the lock if it is set
+  unlink $self->{LOCK} if $self->{LOCK} and -e $self->{LOCK};
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $config = $ext->config;
+#
+# DESCRIPTION
+#   This method returns a reference to the Fcm::Config instance.
+# ------------------------------------------------------------------------------
+
+sub config {
+  my $self = shift;
+
+  return $self->{CONFIG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cfgfile = $ext->cfg;
+#   $ext->cfg ($cfgfile);
+#
+# DESCRIPTION
+#   This method returns a reference to a Fcm::CfgFile instance for the extract
+#   configuration file.
+# ------------------------------------------------------------------------------
+
+sub cfg {
+  my $self = shift;
+
+  return $self->{CFG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $dest = $ext->dest ([$name]);
+#
+# DESCRIPTION
+#   This method returns a hash containing the extract destination information
+#   (local) if no argument is specified. If $name is specified, it returns the
+#   named hash element if it exists.
+# ------------------------------------------------------------------------------
+
+sub dest {
+  my $self = shift;
+
+  if (@_) {
+    my $name = shift;
+    $name    = uc $name;
+
+    if (exists $self->{DEST}{$name}) {
+      return $self->{DEST}{$name};
+    }
+  }
+
+  return %{ $self->{DEST} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rdest = $ext->rdest ([$name]);
+#
+# DESCRIPTION
+#   This method returns a hash containing the extract destination information
+#   (remote) if no argument is specified. If $name is specified, it returns the
+#   named hash element if it exists.
+# ------------------------------------------------------------------------------
+
+sub rdest {
+  my $self = shift;
+
+  if (@_) {
+    my $name = shift;
+    $name    = uc $name;
+
+    if (exists $self->{RDEST}{$name}) {
+      return $self->{RDEST}{$name};
+    }
+  }
+
+  return %{ $self->{RDEST} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @bdeclare = $ext->bdeclare ();
+#
+# DESCRIPTION
+#   This method returns a list containing the build configuration file entries.
+# ------------------------------------------------------------------------------
+
+sub bdeclare {
+  my $self = shift;
+
+  return @{ $self->{BDECLARE} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @branches = $ext->branches ([$index]);
+#
+# DESCRIPTION
+#   This method returns a list of references to Fcm::ReposBranch instances. If
+#   $index is specified, it returns the numbered item in the list.
+# ------------------------------------------------------------------------------
+
+sub branches {
+  my $self = shift;
+
+  if (@_) {
+    my $index = $_[0];
+    return exists $self->{BRANCHES}[$index] ? $self->{BRANCHES}[$index] : undef;
+  }
+
+  return @{ $self->{BRANCHES} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   %srcdirs = $ext->srcdirs ([$name]);
+#
+# DESCRIPTION
+#   This method returns a hash of source directories to be processed by this
+#   extract. If $name is specified, a named element of the hash is returned
+#   instead.
+# ------------------------------------------------------------------------------
+
+sub srcdirs {
+  my $self = shift;
+
+  if (@_) {
+    my $name = shift;
+    $name    = uc $name;
+
+    return exists $self->{SRCDIRS}{$name} ? $self->{SRCDIRS}{$name} : undef;
+  }
+
+  return %{ $self->{SRCDIRS} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rc = $ext->extract ([FULL => 1], [IGNORE_LOCK => 1]);
+#
+# DESCRIPTION
+#   This is the main class method. It performs an extract using the current
+#   configuration. If FULL is set to true, it runs in full mode. Otherwise, it
+#   runs in incremental mode. If IGNORE_LOCK is set to true, it ignores any lock
+#   files that may exist in the extract destination root directory.
+# ------------------------------------------------------------------------------
+
+sub extract {
+  my $self = shift;
+  my %args = @_;
+
+  my $full        = exists $args{FULL}        ? $args{FULL}        : 0;
+  my $ignore_lock = exists $args{IGNORE_LOCK} ? $args{IGNORE_LOCK} : 0;
+
+  my $verbose = $self->config->verbose;
+
+  my $date = localtime;
+  print 'Extract started on ', $date, '.', "\n" if $verbose;
+  my $otime = time;
+
+  my $rc;
+  $rc = $self->decipher_cfg;
+
+  print '->Extract: start', "\n" if $verbose;
+  my $stime = time;
+
+  $rc = $self->check_dest               if $rc;
+  $rc = $self->check_lock               if $rc and not $ignore_lock;
+  $rc = $self->_set_lock                if $rc;
+  $rc = $self->expand_cfg               if $rc;
+  $rc = $self->_create_dest_dir ($full) if $rc;
+  $rc = $self->create_dir_stack         if $rc;
+  $rc = $self->_extract_src             if $rc;
+
+  $rc = $self->_sort_bdeclare if $rc;
+  $rc = $self->_write_ext_cfg if $rc;
+  $rc = $self->_write_bld_cfg if $rc;
+
+  my $ftime = time;
+  my $s_str = $ftime - $stime > 1 ? 'seconds' : 'second';
+  print '->Extract: ', $ftime - $stime, ' ', $s_str, "\n";
+
+  if ($rc and $self->{RDEST}{MACHINE}) {
+    print '->Mirror : start', "\n" if $verbose;
+    $stime = time;
+    $rc = $self->_mirror_extract;
+    $ftime = time;
+    $s_str = $ftime - $stime > 1 ? 'seconds' : 'second';
+    print '->Mirror : ', $ftime - $stime, ' ', $s_str, "\n";
+  }
+
+  if ($verbose) {
+    $s_str = $ftime - $otime > 1 ? 'seconds' : 'second';
+    print '->TOTAL  : ', $ftime - $otime, ' ', $s_str, "\n";
+  }
+
+  $date = localtime;
+  if ($rc) {
+    print 'Extract command finished on ', $date, '.', "\n" if $verbose;
+
+  } else {
+    e_report 'Extract command failed on ', $date, '.';
+  }
+
+  return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ext->decipher_cfg ();
+#
+# DESCRIPTION
+#   This method deciphers the extract configuration file.
+# ------------------------------------------------------------------------------
+
+sub decipher_cfg {
+  my $self = shift;
+
+  return unless $self->cfg->src;
+
+  # Read config file
+  my $read = $self->cfg->read_cfg;
+
+  # Check config file type
+  if ($read) {
+    if ($self->cfg->type ne 'ext') {
+      w_report 'Error: ', $self->cfg->src, ': not an extract config file';
+      return;
+    }
+
+  } else {
+    return;
+  }
+
+  my %cfg_labels = %{ $self->config->setting ('CFG_LABEL') };
+
+  # Extract information from each line of the config file
+  my @lines    = $self->cfg->lines;
+  LINE: for my $line (@lines) {
+    my $label = $line->{LABEL};
+    my $value = $line->{VALUE};
+
+    next LINE unless $label;
+
+    # Configuration file type/version, ignore
+    for my $my_label (keys %{ $cfg_labels{CFGFILE} }) {
+      next LINE if uc ($label) eq uc ($cfg_labels{CFGFILE}{$my_label});
+    }
+
+    # Include another file, processed already, ignore this line
+    next LINE if uc ($label) eq $cfg_labels{INC};
+
+    # User variable, ignore
+    next LINE if index (uc ($label), '%') == 0;
+
+    # Local destination directories, config file, etc
+    for my $my_label (keys %{ $cfg_labels{DEST} }) {
+      if (uc ($label) eq uc ($cfg_labels{DEST}{$my_label})) {
+        $self->{DEST}{$my_label} = &expand_tilde ($value);
+        next LINE;
+      }
+    }
+
+    # Remote machine, logname, destination directories, config file, etc
+    for my $my_label (keys %{ $cfg_labels{RDEST} }) {
+      if (uc ($label) eq uc ($cfg_labels{RDEST}{$my_label})) {
+        $self->{RDEST}{$my_label} = $value;
+        next LINE;
+      }
+    }
+
+    # "USE" statements
+    if (uc ($label) eq uc ($cfg_labels{USE})) {
+      my $exists = grep {$_->cfg->src eq $value} @{ $self->{USE} };
+
+      # Initialise new Fcm::Extract object if not already exists
+      unless ($exists) {
+        my $extract = Fcm::Extract->new (
+          CONFIG    => $self->config,
+          CFG_SRC   => expand_tilde ($value),
+          EXTRACTED => 1,
+        );
+
+        $extract->decipher_cfg;
+        $extract->check_dest;
+        $extract->expand_cfg ();
+        push @{ $self->{USE} }, $extract;
+      }
+      next LINE;
+    }
+
+    # "Override" setting
+    if (uc ($label) eq uc ($cfg_labels{OVERRIDE})) {
+      $self->{OVERRIDE} = $value;
+      next LINE;
+    }
+
+    # "Mirror" command
+    if (uc ($label) eq uc ($cfg_labels{MIRROR})) {
+      $self->config->assign_setting (
+        LABELS => [qw/TOOL MIRROR/],
+        VALUE  => $value,
+      );
+      next LINE;
+    }
+
+    # Declared bld cfg entries
+    {
+      my $prefix = $cfg_labels{BDECLARE} . '::';
+
+      if (index (uc ($label), $prefix) == 0) {
+        my $name = substr $label, length ($prefix);
+
+        if ($name) {
+          push @{ $self->{BDECLARE} }, {LABEL => $name, VALUE => $value,};
+          next LINE;
+        }
+      }
+    }
+
+    # Repository, version and source directories
+    for my $my_label (qw/REPOS VERSION SRCDIR EXPSRCDIR/) {
+      my $prefix  = $cfg_labels{$my_label} . '::';
+
+      if (index (uc ($label), $prefix) == 0) {
+        my $name    = substr $label, length ($prefix);
+
+        # Detemine package and tag
+        my @names   = split /::/, $name;
+        my $tag     = pop @names;
+        my $pckroot = $names[0];
+        my $pck     = join '::', @names;
+
+        # Check that $tag and $pckroot are defined
+        last if not $tag;
+        last if not $pckroot;
+
+        # Check whether branch already exists
+        my @branches = grep {
+          $_->package eq $pckroot and $_->tag eq $tag
+        } @{ $self->{BRANCHES} };
+
+        my $branch   = undef;
+
+        if (@branches) { # If so, set $branch to point to existing branch
+          $branch = shift @branches;
+
+        } else {         # If not, create new branch
+          $branch = Fcm::ReposBranch->new (
+            CONFIG  => $self->config,
+            PACKAGE => $pckroot,
+            TAG     => $tag,
+          );
+
+          push @{ $self->{BRANCHES} }, $branch;
+        }
+
+        # Check package name for source directory declarations
+        if ($my_label eq 'SRCDIR' or $my_label eq 'EXPSRCDIR') {
+          if ($pck eq $pckroot and $value !~ m#^/#) {
+            # Sub-package name not set and source directory quoted as a relative
+            # path, determine package name from path name
+            my @subpck = File::Spec->splitdir ($value);
+            $pck       = join '::', ($pckroot, @subpck);
+          }
+        }
+
+        # Assign the value accordingly
+        if ($my_label eq 'REPOS') {          # Repository location
+          $branch->repos ($value);
+
+        } elsif ($my_label eq 'VERSION') {   # Version used
+          $branch->version ($value);
+
+        } elsif ($my_label eq 'SRCDIR') {    # Source directory used
+          $branch->dir ($pck, $value);
+
+        } elsif ($my_label eq 'EXPSRCDIR') { # Expandable source directory
+          $branch->expdir ($pck, $value);
+        }
+
+        next LINE;
+      }
+    }
+
+    # Label not recognised
+    w_report 'ERROR: ', $line->{SRC}, ': LINE ', $line->{NUMBER},
+             ': label "', $label, '" not recognised';
+    return;
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ext->check_dest ();
+#
+# DESCRIPTION
+#   This method checks that the extract destionations are set correctly.
+# ------------------------------------------------------------------------------
+
+sub check_dest {
+  my $self = shift;
+
+  my %subdir  = %{ $self->config->setting ('DIR') };
+  my %cfgname = %{ $self->config->setting ('CFG_NAME') };
+
+  # Default destination settings
+  my $dest = $self->{DEST};
+  if ($dest->{ROOTDIR}) {
+    unless ($dest->{SRCDIR}) {   # Location of extracted source
+      $dest->{SRCDIR} = catfile $dest->{ROOTDIR}, $subdir{SRC};
+    }
+    unless ($dest->{CFGDIR}) {   # Location of configuration files
+      $dest->{CFGDIR} = catfile $dest->{ROOTDIR}, $subdir{CFG};
+    }
+    unless ($dest->{CACHEDIR}) { # Location of cache
+      $dest->{CACHEDIR} = catfile $dest->{ROOTDIR}, $subdir{CACHE};
+    }
+    unless ($dest->{BLD_CFG}) {  # Location of (output) bld cfg
+      $dest->{BLD_CFG} = catfile $dest->{CFGDIR}, $cfgname{BLD};
+    }
+    unless ($dest->{EXT_CFG}) {  # Location of (output) ext cfg
+      $dest->{EXT_CFG} = catfile $dest->{CFGDIR}, $cfgname{EXT};
+    }
+  } else {
+    w_report 'Error: ', $self->cfg->src,
+             ': destination root directory not set.';
+    return;
+  }
+
+  # Default remote destination settings
+  if ($self->{RDEST}{MACHINE}) {
+
+    # Use local logname as remote logname if it is not set
+    $self->{RDEST}{LOGNAME} = getlogin      unless $self->{RDEST}{LOGNAME};
+    $self->{RDEST}{LOGNAME} = $ENV{LOGNAME} unless $self->{RDEST}{LOGNAME};
+    $self->{RDEST}{LOGNAME} = $ENV{USER}    unless $self->{RDEST}{LOGNAME};
+
+    unless ($self->{RDEST}{LOGNAME}) {
+      w_report 'Error: ', $self->cfg->src,
+               ': cannot determine your remote logname.';
+      return;
+    }
+
+    # Make sure remote destination root directory is set
+    unless ($self->{RDEST}{ROOTDIR}) {
+      w_report 'Error: ', $self->cfg->src,
+               ': remote destination root directory not set.';
+      return;
+    }
+
+    # Make sure remote destination source directory is set
+    $self->{RDEST}{SRCDIR} = catfile $self->{RDEST}{ROOTDIR}, $subdir{SRC}
+      unless $self->{RDEST}{SRCDIR};
+
+    # Make sure remote destination configuration directory is set
+    $self->{RDEST}{CFGDIR} = catfile $self->{RDEST}{ROOTDIR}, $subdir{CFG}
+      unless $self->{RDEST}{CFGDIR};
+
+    # Make sure remote bld cfg is set
+    $self->{RDEST}{BLD_CFG} = catfile $self->{RDEST}{CFGDIR}, $cfgname{BLD}
+      unless $self->{RDEST}{BLD_CFG};
+
+    # Make sure remote ext cfg is set
+    $self->{RDEST}{EXT_CFG} = catfile $self->{RDEST}{CFGDIR}, $cfgname{EXT}
+      unless $self->{RDEST}{EXT_CFG};
+
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ext->check_lock ();
+#
+# DESCRIPTION
+#   This method checks whether a lock is set in the current extract.
+# ------------------------------------------------------------------------------
+
+sub check_lock {
+  my $self = shift;
+
+  my $rootdir  = $self->{DEST}{ROOTDIR};
+  my $lock_ext = catfile ($rootdir, $self->config->setting (qw/MISC LOCK_EXT/));
+  my $lock_bld = catfile ($rootdir, $self->config->setting (qw/MISC LOCK_BLD/));
+
+  # Always throw error if extract lock exists
+  if (-e $lock_ext) {
+    w_report 'ERROR: extract lock file exists: ', $lock_ext, ',';
+    w_report '       an extract may be running at ', $rootdir, ', abort.';
+    return;
+  }
+
+  # Throw error if current object is not a "used" pre-extracted object and
+  # a build lock exists
+  if ((not $self->{EXTRACTED}) and -e $lock_bld) {
+    w_report 'ERROR: build lock file exists: ', $lock_bld, ',';
+    w_report '       a build may be running at ', $rootdir, ', abort.';
+    return;
+  }
+
+  # Check locks in inherited extract
+  for my $use (@{ $self->{USE} }) {
+    return unless $use->check_lock;
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_set_lock ();
+#
+# DESCRIPTION
+#   This method sets a lock is set in the current extract.
+# ------------------------------------------------------------------------------
+
+sub _set_lock {
+  my $self = shift;
+
+  $self->{LOCK} = catfile (
+    $self->{DEST}{ROOTDIR}, $self->config->setting (qw/MISC LOCK_EXT/),
+  );
+
+  &touch_file ($self->{LOCK});
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ext->expand_cfg ();
+#
+# DESCRIPTION
+#   This method expands the settings of the extract configuration.
+# ------------------------------------------------------------------------------
+
+sub expand_cfg {
+  my $self = shift;
+
+  # Establish a set of source directories from the "base repository"
+  my %base_branches = ();
+
+  # Inherit "base" set of source directories from re-used extracts
+  my @uses = @{ $self->{USE} };
+
+  for my $use (@uses) {
+    my @branches = $use->branches;
+
+    for my $branch (@branches) {
+      my $package              = $branch->package;
+      $base_branches{$package} = $branch unless exists $base_branches{$package};
+    }
+  }
+
+  for my $branch (@{ $self->{BRANCHES} }) {
+    # Expand URL keywords if necessary
+    if ($branch->repos) {
+      my $repos = expand_url_keyword (
+        URL => $branch->repos,
+        CFG => $self->config,
+      );
+      $branch->repos ($repos) if $repos ne $branch->repos;
+    }
+
+    # Check that repository type and version are set
+    if ($branch->repos and &is_url ($branch->repos)) {
+      $branch->type    ('svn')  unless $branch->type;
+      $branch->version ('head') unless $branch->version;
+
+    } else {
+      $branch->type    ('user') unless $branch->type;
+      $branch->version ('user') unless $branch->version;
+    }
+
+    $branch->expand_version_tag; # Work out revision number a version tag
+    $branch->expand_path;        # Expand relative path to full path
+    $branch->expand_all;         # Search sub-directories
+
+    my $package = $branch->package;
+
+    if (exists $base_branches{$package}) {
+      # A base branch for this package exists
+
+      # If current branch has no source directory, use the set provided by the
+      # base branch
+      my %dirs = $branch->dirs;
+      $branch->add_base_dirs ($base_branches{$package}) unless keys %dirs;
+
+    } else {
+      # This package does not yet have a base branch, set this branch as base
+      $base_branches{$package} = $branch;
+    }
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_create_dest_dir ($full);
+#
+# DESCRIPTION
+#   This internal method (re-)creates all the destination directories if
+#   necessary. If $full is set to true, it removes existing directories/files
+#   in the destination directories.
+# ------------------------------------------------------------------------------
+
+sub _create_dest_dir {
+  my ($self, $full) = @_;
+
+  my $verbose = $self->config->verbose;
+
+  # Remove previous extract if "FULL" flag is set
+  if ($full) {
+    # Remove extracted source
+    if (-d $self->{DEST}{SRCDIR} and -w $self->{DEST}{SRCDIR}) {
+      print 'Remove directory: ', $self->{DEST}{SRCDIR}, "\n" if $verbose;
+      my $removed = rmtree $self->{DEST}{SRCDIR};
+      w_report 'WARNING: ', $self->{DEST}{SRCDIR}, ': cannot remove.'
+        if not $removed;
+    }
+
+    # Remove cache
+    my @files;
+    if (-d $self->{DEST}{CACHEDIR} and opendir DIR, $self->{DEST}{CACHEDIR}) {
+      @files = grep {$_ ne '.' and $_ ne '..'} readdir 'DIR';
+      closedir DIR;
+    }
+
+    for my $file (@files) {
+      my $path = File::Spec->catfile ($self->{DEST}{CACHEDIR}, $file);
+
+      next unless $file eq $self->config->setting (qw/CACHE EXTCONFIG/) or
+                  -d $path;
+
+      print 'Remove: ', $path, "\n" if $verbose;
+      my $removed = rmtree $path;
+      w_report 'WARNING: ', $path, ': cannot remove.' if not $removed;
+    }
+  }
+
+  # Create extract destinations if necessary
+  for my $my_label (qw/ROOTDIR CACHEDIR CFGDIR SRCDIR/) {
+    my $dirname = $self->{DEST}{$my_label};
+
+    # Create directory if it does not already exist
+    if (not -d $dirname) {
+      print 'Make directory: ', $dirname, "\n" if $verbose > 1;
+      mkpath $dirname;
+    }
+
+    unless (-d $dirname and -w $dirname) {
+      w_report 'ERROR: ', $dirname, ': cannot write to destination.';
+      return;
+    }
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ext->create_dir_stack (
+#     USE => $use, # Is this a pre-extracted configuration?
+#   );
+#
+# DESCRIPTION
+#   This method creates a hash of source directories to be processed. If the
+#   flag USE is set to true, the source directories are assumed processed and
+#   extracted.
+# ------------------------------------------------------------------------------
+
+sub create_dir_stack {
+  my $self = shift;
+  my %args = @_;
+  my $extracted = exists $args{USE} ? $args{USE} : undef;
+
+  # Inherit from USE ext cfg
+  if (@{ $self->{USE} } > 0) {
+    for my $use (@{ $self->{USE} }) {
+      $use->create_dir_stack (USE => 1);
+      my %use_srcdirs = $use->srcdirs;
+
+      while (my ($key, $value) = each %use_srcdirs) {
+        $self->{SRCDIRS}{$key} = $value;
+
+        # Re-set destination to current destination
+        my @path = split (/::/, $key);
+        $self->{SRCDIRS}{$key}{DEST} = catfile ($self->{DEST}{SRCDIR}, @path);
+      }
+    }
+  }
+
+  # Build stack from current ext cfg
+  for my $branch (@{ $self->{BRANCHES} }) {
+    my %branch_dirs = $branch->dirs;
+
+    for my $dir (keys %branch_dirs) {
+      # Check whether source directory is already in the list
+      if (not exists $self->{SRCDIRS}{$dir}) { # if not, create it
+        $self->{SRCDIRS}{$dir} = {
+          DEST  => catfile ($self->{DEST}{SRCDIR}, split (/::/, $dir)),
+          STACK => [],
+          FILES => {},
+        };
+      }
+
+      my $stack = $self->{SRCDIRS}{$dir}{STACK}; # copy reference
+
+      # Create a new layer in the input stack
+      my $layer = Fcm::SrcDirLayer->new (
+        CONFIG    => $self->config,
+        NAME      => $dir,
+        PACKAGE   => $branch->package,
+        TAG       => $branch->tag,
+        LOCATION  => $branch->dir ($dir),
+        REPOSROOT => $branch->repos,
+        VERSION   => $branch->version,
+        TYPE      => $branch->type,
+        EXTRACTED => $extracted ? $self->{SRCDIRS}{$dir}{DEST} : undef,
+      );
+
+      # Check whether layer is already in the stack
+      my $exist = grep {
+        $_->location eq $layer->location and $_->version  eq $layer->version;
+      } @{ $stack };
+
+      if (not $exist) {
+        # If not already exist, put layer into stack
+
+        # Note: user stack always comes last
+        if (! $layer->user and exists $stack->[-1] and $stack->[-1]->user) {
+          my $lastlayer = pop @{ $stack };
+          push @{ $stack }, $layer;
+          $layer = $lastlayer;
+        }
+
+        push @{ $stack }, $layer;
+
+      } elsif ($layer->user) {
+
+        # User layer already exists, overwrite it
+        $stack->[-1] = $layer;
+
+      }
+    }
+  }
+
+  # Read content of "commit cache" file if it exists
+  my $cachedir = $self->{DEST}{CACHEDIR};
+  my $cfgbase  = $self->config->setting (qw/CACHE EXTCONFIG/);
+  my $cfgfile  = catfile $cachedir, $cfgbase;
+  my %config_lines = ();
+  if (-r $cfgfile) {
+    my $cfg = Fcm::CfgFile->new (CONFIG => $self->config, SRC => $cfgfile,);
+    $cfg->read_cfg;
+    my @lines = $cfg->lines;
+
+    for my $line (@lines) {
+      $config_lines{$line->{LABEL}} = $line->{VALUE};
+    }
+  }
+
+  my %new_config_lines;
+
+  # Compare each layer to base layer, discard unnecessary layers
+  for my $srcdir (keys %{ $self->{SRCDIRS} }) {
+    my @stack = ();
+
+    while (my $layer = shift @{ $self->{SRCDIRS}{$srcdir}{STACK} }) {
+      if ($layer->user) {
+        # User directory, check that the declared location exists
+        if (not -d $layer->location) {
+          w_report 'Error: declared source directory ', $layer->location,
+                   ' does not exists ';
+          return;
+        }
+
+        # Always override repository code
+        push @stack, $layer;
+
+      } else {
+        unless ($layer->extracted and $layer->commit) {
+
+          my $key = join '::', ($srcdir, $layer->location, $layer->version);
+
+          # See if commit version information is cached
+          if (keys %config_lines) {
+            if (exists $config_lines{$key}) {
+              $layer->commit ($config_lines{$key});
+            }
+          }
+
+          # Check source directory for commit version, if necessary
+          $layer->get_commit unless $layer->commit;
+          if (not $layer->commit) {
+            w_report 'Error: cannot determine the last changed revision of ',
+                     $layer->location;
+            return;
+          }
+
+          # Set cache directory for layer
+          my $tag_ver = $layer->tag . '__' . $layer->commit;
+          $layer->cachedir (catfile $cachedir, split (/::/, $srcdir), $tag_ver);
+
+          # New line in cache config file
+          $new_config_lines{$key} = $layer->commit;
+        }
+
+        # Push this layer in the stack:
+        # 1. it has a different version compared to the top layer
+        # 2. it is the top layer (base line code)
+        if (@stack > 0) {
+          push @stack, $layer if $layer->commit != $stack[0]->commit;
+
+        } else {
+          push @stack, $layer;
+        }
+
+      }
+    }
+
+    $self->{SRCDIRS}{$srcdir}{STACK} = \@stack;
+
+  }
+
+  # Write "commit cache" file
+  if (not $extracted) {
+    mkpath $cachedir if not -d $cachedir;
+    my $cfg = Fcm::CfgFile->new (CONFIG => $self->config,);
+
+    while ((my $label, my $value) = each %new_config_lines) {
+      $cfg->add_line (LABEL => $label, VALUE => $value,);
+    }
+
+    $cfg->print_cfg ($cfgfile);
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_extract_src ();
+#
+# DESCRIPTION
+#   This internal method performs the extract of the source directories and
+#   files if necessary.
+# ------------------------------------------------------------------------------
+
+sub _extract_src {
+  my $self = shift;
+
+  my $verbose = $self->config->verbose;
+  my %v_count = (
+    CREATED_DIRS    => 0,
+    IGNORED_SUBDIRS => 0,
+    UPDATED_FILES   => 0,
+    REMOVED_FILES   => 0,
+  );
+
+  my $cachedir = $self->{DEST}{CACHEDIR};
+
+  # Go through the "stack" of each source directory
+  # Extract the source directories/files if required
+
+  for my $srcdir (values %{ $self->{SRCDIRS} }) {
+
+    # Check if destionation exists and is not a directory
+    if (-f $srcdir->{DEST}) {
+      w_report $srcdir->{DEST},
+               ': destination exists and is not a directory, abort.';
+      return;
+    }
+
+    my %base_files   = (); # list of files in the base layer
+    my %used_files   = (); # keys = file basenames, values = layer reference
+    $srcdir->{FILES} = \%used_files;
+    my @destpath     = (); # search path for source directory destinations
+ 
+    for my $layer (@{ $srcdir->{STACK} }) {
+      # Update the cache for each layer of the stack if necessary
+      $layer->update_cache unless $layer->extracted or -d $layer->localdir;
+
+      # Search path for extract destinations of this source directory
+      unshift @destpath, $layer->extracted
+        if $layer->extracted and not grep {$_ eq $layer->extracted} @destpath;
+ 
+      # Get list of files in the cache or local directory
+      for my $file (($layer->get_files)) {
+        if (exists $base_files{$file}) {
+          # File exists in the base, compare current version with base version,
+          # discard if not changed
+          my $base_file = catfile $base_files{$file}->localdir, $file;
+          my $used_file = catfile $used_files{$file}->localdir, $file;
+          my $this_file = catfile $layer->localdir, $file;
+
+          if (compare ($base_file, $this_file)) { # Differs
+            if ($base_files{$file} eq $used_files{$file}) {
+              # Base and used are the same layer, use current layer
+              $used_files{$file} = $layer;
+
+            } elsif (compare ($used_file, $this_file) == 0) {
+              # Changes in used and this are the same, no update required
+
+              # Print a message at verbose mode 2 or above
+              if ($verbose > 1) {
+                print &_print_override_mesg (
+                  FILE   => $file,
+                  LAYER0 => $base_files{$file},
+                  LAYER1 => $used_files{$file},
+                  LAYER2 => $layer,
+                );
+                print '  Same modifications, use the source in URL 1.', "\n";
+              }
+
+            } elsif ($self->{OVERRIDE}) {
+              # Base and used are different, and used is not the same as this
+              # Override mode, use current layer
+
+              # Print override mode message
+              if ($verbose) {
+                print &_print_override_mesg (
+                  FILE   => $file,
+                  LAYER0 => $base_files{$file},
+                  LAYER1 => $used_files{$file},
+                  LAYER2 => $layer,
+                );
+                print '  ', $file, ' in URL 2 overrides that in URL 1.', "\n";
+              }
+
+              $used_files{$file} = $layer;
+
+            } else {
+              # Base and used are different, and used is not the same as this
+              # Non-override mode, fail the extract
+              w_report &_print_override_mesg (
+                FILE   => $file,
+                LAYER0 => $base_files{$file},
+                LAYER1 => $used_files{$file},
+                LAYER2 => $layer,
+              );
+              w_report '  Override mode is false, file in URL 1 cannot ',
+                       'override file in URL 2, abort.';
+              return;
+            }
+          }
+ 
+        } else {
+          # The first time the file is found
+          $base_files{$file} = $layer;
+          $used_files{$file} = $layer;
+        }
+      }
+    }
+
+    # Add current destination to the beginning of the destination search path
+    unshift @destpath, $srcdir->{DEST} if -d $srcdir->{DEST};
+
+    for my $file (keys %used_files) {
+      # Ignore sub-directories
+      if (-d catfile $used_files{$file}->localdir, $file) {
+        # Print diagnostic
+        if ($verbose > 1) {
+          print 'Ignore subdirectory: ', $file, "\n";
+          print '                Src: ', $used_files{$file}->location;
+          print '@', $used_files{$file}->version unless $used_files{$file}->user;
+          print "\n";
+        }
+        $v_count{IGNORED_SUBDIRS}++;
+        next;
+      }
+
+      # Determine whether file has changed, compared with the destination
+      my $diff = 1;
+      for my $dir (@destpath) {
+        my $old = catfile ($dir, $file);
+
+        if (-f $old) {
+          my $new = catfile ($used_files{$file}->localdir, $file);
+          $diff   = compare $old, $new;
+          last;
+        }
+      }
+
+      if ($diff) { # copy if differs
+        # Create extract destination, if required
+        if (not -d $srcdir->{DEST}) {
+          print 'Create directory: ', $srcdir->{DEST}, "\n" if $verbose > 1;
+          my $mkdirs = mkpath $srcdir->{DEST};
+
+          if (! -d $srcdir->{DEST} or ! -w $srcdir->{DEST}) {
+            w_report $srcdir->{DEST}, ': not a writable directory, abort.';
+            return;
+          }
+
+          $v_count{CREATED_DIRS} += $mkdirs;
+        }
+
+        # Set up the copy command
+        my @cmd = (
+          'cp',
+          catfile ($used_files{$file}->localdir, $file),
+          $srcdir->{DEST},
+        );
+
+        my $dest_file = catfile ($srcdir->{DEST}, $file);
+
+        # Print diagnostic
+        if ($verbose > 1) {
+          print 'Update: ', $dest_file, "\n";
+          print '   Src: ', $used_files{$file}->location;
+          print '@', $used_files{$file}->version unless $used_files{$file}->user;
+          print "\n";
+        }
+
+        # Remove old file if it exists
+        unlink $dest_file if -f $dest_file;
+
+        # Execute the copy command
+        &run_command (\@cmd, TIME => $self->config->verbose > 2);
+
+        $v_count{UPDATED_FILES}++;
+      }
+
+    }
+
+    # Check that the destination directory does not contain any removed files
+    opendir DIR, $srcdir->{DEST};
+    my @dest_files = readdir DIR;
+    closedir DIR;
+
+    while (my $file = shift @dest_files) {
+      next if $file =~ /^\.\.?/;                   # ignore hidden files
+      next if -d catfile ($srcdir->{DEST}, $file); # ignore sub-directories
+
+      # Check if the file exists in any of the versions
+      my $exists = 0;
+      for my $layer (@{ $srcdir->{STACK} }) {
+        if (-f catfile ($layer->localdir, $file)) {
+          $exists = 1;
+          last;
+        }
+      }
+
+      # File exists in destination but not in any versions...
+      if (not $exists) {
+        my @cmd = (
+          qw/rm -f/,
+          catfile ($srcdir->{DEST}, $file),
+        );
+
+        # Print diagnostic
+        print 'Remove: ', catfile ($srcdir->{DEST}, $file), "\n"
+          if $verbose > 1;
+
+        # Execute the command
+        &run_command (\@cmd, TIME => $self->config->verbose > 2);
+
+        $v_count{REMOVED_FILES}++;
+      }
+    }
+  }
+
+  if ($verbose) {
+    my %v_label = (
+      CREATED_DIRS    => 'Number of directories created    : ',
+      IGNORED_SUBDIRS => 'Number of ignored sub-directories: ',
+      UPDATED_FILES   => 'Number of updated files          : ',
+      REMOVED_FILES   => 'Number of removed files          : ',
+    );
+    for my $key (qw/CREATED_DIRS IGNORED_SUBDIRS UPDATED_FILES REMOVED_FILES/) {
+      print $v_label{$key}, $v_count{$key}, "\n" if $v_count{$key};
+    }
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $string = _print_override_mesg (
+#     FILE => $file,
+#     LAYER0 => $layer0,
+#     LAYER1 => $layer1,
+#     LAYER2 => $layer2,
+#   );
+#
+# DESCRIPTION
+#   This internal method returns a string containing an override mode message.
+#
+# ARGUMENTS
+#   FILE   - name of the source file
+#   LAYER0 - base location
+#   LAYER1 - source location overridden by LOC2
+#   LAYER2 - source location overriding LOC1
+# ------------------------------------------------------------------------------
+
+sub _print_override_mesg {
+  my %args = @_;
+
+  my $string = $args{FILE};
+  $string .= ': modified in both URL 1 and URL 2, relative to BASE:';
+  $string .= "\n";
+  $string .= '  BASE : ' . $args{LAYER0}->location;
+  $string .= '@' . $args{LAYER0}->version unless $args{LAYER0}->user;
+  $string .= "\n";
+  $string .= '  URL 1: ' . $args{LAYER1}->location;
+  $string .= '@' . $args{LAYER1}->version unless $args{LAYER1}->user;
+  $string .= "\n";
+  $string .= '  URL 2: ' . $args{LAYER2}->location;
+  $string .= '@' . $args{LAYER2}->version unless $args{LAYER2}->user;
+  $string .= "\n";
+
+  return $string;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_sort_bdeclare ();
+#
+# DESCRIPTION
+#   This internal method sorts the declared build configuration entries,
+#   filtering out repeated entries.
+# ------------------------------------------------------------------------------
+
+sub _sort_bdeclare {
+  my $self = shift;
+
+  # Get list of build configuration labels that can be declared multiple times
+  my %cfg_labels   = %{ $self->config->setting ('CFG_LABEL') };
+  my @cfg_keywords = split /,/, $self->config->setting ('CFG_KEYWORD');
+  @cfg_keywords    = map {$cfg_labels{$_}} @cfg_keywords;
+
+  # Filter out repeated declarations
+  my @bdeclares = ();
+  for my $bdeclare (reverse @{ $self->{BDECLARE} }) {
+    my $label = $bdeclare->{LABEL};
+
+    # Do not filter any declarations that can be declared multiple times
+    my $unshift_ok = grep {
+      uc ($label) eq $_ or index (uc ($label), $_ . '::') == 0;
+    } @cfg_keywords;
+    # @bdeclare contains nothing, last entry
+    $unshift_ok    = 1 unless $unshift_ok or @bdeclares;
+    # Check if a later entry already exists
+    $unshift_ok    = 1
+      unless $unshift_ok or grep {$_->{LABEL} eq $label} @bdeclares;
+
+    # Reconstruct array from bottom up
+    unshift @bdeclares, $bdeclare if $unshift_ok;
+  }
+
+  $self->{BDECLARE} = \@bdeclares;
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_write_ext_cfg ();
+#
+# DESCRIPTION
+#   This internal method writes the expanded extract configuration file.
+# ------------------------------------------------------------------------------
+
+sub _write_ext_cfg {
+  my $self = shift;
+
+  my %cfg_labels = %{ $self->config->setting ('CFG_LABEL') };
+  my %subdir     = %{ $self->config->setting ('DIR') };
+  my %cfgname    = %{ $self->config->setting ('CFG_NAME') };
+
+  # Create new config file object and assign lines to it
+  my $cfg = Fcm::CfgFile->new (CONFIG => $self->config, TYPE => 'ext',);
+
+  # Set up config file header
+  $cfg->add_header ();
+
+  # Re-use pre-extracted expanded ext cfg
+  if (@{ $self->{USE} }) {
+    $cfg->add_comment_block ('Other ext cfg');
+
+    for my $reuse (@{ $self->{USE} }) {
+      my $rootdir = $reuse->dest ('ROOTDIR');
+      my $ext_cfg = $reuse->cfg->src;
+
+      # Default location of build config file
+      my $def_ext_cfg = catfile $rootdir, $subdir{CFG}, $cfgname{EXT};
+
+      $cfg->add_line (
+        LABEL => $cfg_labels{USE},
+        VALUE => $ext_cfg eq $def_ext_cfg ? $rootdir : $ext_cfg,
+      );
+    }
+
+    # Blank line
+    $cfg->add_line;
+  }
+
+  # Destination directories, config file, etc
+  my $dest = $self->{DEST};
+
+  $cfg->add_comment_block ('Destination');
+
+  $cfg->add_line (
+    LABEL => $cfg_labels{DEST}{ROOTDIR},
+    VALUE => $dest->{ROOTDIR},
+  );
+
+  for my $label (qw/CFG SRC CACHE/) {
+    my $dir = $label . 'DIR';
+
+    if ($dest->{$dir} ne catfile $dest->{ROOTDIR}, $subdir{$label}) {
+      $cfg->add_line (
+        LABEL => $cfg_labels{DEST}{$dir},
+        VALUE => $dest->{$dir},
+      );
+    }
+  }
+
+  for my $name (qw/BLD EXT/) {
+    my $label = $name . '_CFG';
+
+    if ($dest->{$label} ne catfile $dest->{CFGDIR}, $cfgname{$name}) {
+      $cfg->add_line (
+        LABEL => $cfg_labels{DEST}{$label},
+        VALUE => $dest->{$label},
+      );
+    }
+  }
+
+  # Blank line
+  $cfg->add_line;
+
+  # Remote destination directories, config file, etc
+  if ($self->{RDEST}{MACHINE}) {
+    my $rdest = $self->{RDEST};
+
+    $cfg->add_comment_block ('Remote destination');
+
+    for my $label (qw/MACHINE LOGNAME ROOTDIR/) {
+      $cfg->add_line (
+        LABEL => $cfg_labels{RDEST}{$label},
+        VALUE => $rdest->{$label},
+      );
+    }
+
+    for my $label (qw/CFG SRC/) {
+      my $dir = $label . 'DIR';
+      if ($rdest->{$dir} ne catfile $rdest->{ROOTDIR}, $subdir{$label}) {
+        $cfg->add_line (
+          LABEL => $cfg_labels{RDEST}{$dir},
+          VALUE => $rdest->{$dir},
+        );
+      }
+    }
+
+    for my $name (qw/BLD EXT/) {
+      my $label = $name . '_CFG';
+
+      if ($rdest->{$label} ne catfile $rdest->{CFGDIR}, $cfgname{$name}) {
+        $cfg->add_line (
+          LABEL => $cfg_labels{RDEST}{$label},
+          VALUE => $rdest->{$label},
+        );
+      }
+    }
+
+    $cfg->add_line (
+      LABEL => $cfg_labels{MIRROR},
+      VALUE => $self->config->setting (qw/TOOL MIRROR/),
+    );
+
+    # Blank line
+    $cfg->add_line;
+  }
+
+  if ($self->{OVERRIDE}) {
+    $cfg->add_line (
+      LABEL => $cfg_labels{OVERRIDE},
+      VALUE => $self->{OVERRIDE} ? 1 : 0,
+    );
+    $cfg->add_line;
+  }
+
+  # Source directories
+  $cfg->add_comment_block ('Source directories');
+
+  # Set up lines in the ext cfg
+  my @lines = ();
+  for my $my_label (keys %{ $self->{SRCDIRS} }) {
+    for my $layer (@{ $self->{SRCDIRS}{$my_label}{STACK} }) {
+      next if $layer->extracted;
+
+      my $tag = $layer->package . '::' . $layer->tag;
+
+      # Repository
+      my $exists = grep {
+        $_->{LABEL} eq $cfg_labels{REPOS} . '::' . $tag;
+      } @lines;
+      push @lines, {
+        LABEL   => $cfg_labels{REPOS} . '::' . $tag,
+        VALUE   => $layer->reposroot,
+      } if not $exists;
+
+      # Version
+      $exists = grep {
+        $_->{LABEL} eq $cfg_labels{VERSION} . '::' . $tag;
+      } @lines;
+      push @lines, {
+        LABEL   => $cfg_labels{VERSION} . '::' . $tag,
+        VALUE   => $layer->version,
+      } unless $layer->user or $exists;
+
+      # Source directory
+      my ($pcks, $path);
+
+      if ($layer->reposroot) {
+        # Repository root declaration exists, print relative path
+        if ($layer->location eq $layer->reposroot) {
+          $path  = '';
+
+        } else {
+          $path  = substr ($layer->location, length ($layer->reposroot) + 1);
+        }
+        my @pcks = split /::/, $my_label;
+        shift @pcks;
+
+        if (join ('::', @pcks) eq join ('::', File::Spec->splitdir ($path))) {
+          # Print top package name if relative path matches sub-package name
+          $pcks = $layer->package;
+
+        } else {
+          # Print full sub-package name otherwise
+          $pcks = $my_label;
+        }
+
+      } else {
+        # No repository root declaration
+        # Print full path and full sub-package name
+        $path = $layer->location;
+        $pcks = $my_label;
+      }
+
+      my $length = $layer->reposroot ? length ($layer->reposroot) + 1 : 0;
+      push @lines, {
+        LABEL   => join ('::', ($cfg_labels{SRCDIR}, $pcks, $layer->tag)),
+        VALUE   => $path,
+      };
+    }
+  }
+
+  # Sort lines for specifying repository, version and source directories
+  @lines = sort {
+    my $rep_label = $cfg_labels{REPOS};
+    my $ver_label = $cfg_labels{VERSION};
+
+    if ($a->{LABEL} =~ /^$rep_label/) {
+
+      # Repository labels
+      if ($b->{LABEL} =~ /^$rep_label/) {
+        $a->{LABEL} cmp $b->{LABEL} or $a->{VALUE} cmp $b->{VALUE};
+      } else {
+        -1;
+      }
+
+    } elsif ($a->{LABEL} =~ /^$ver_label/) {
+
+      # Version labels
+      if ($b->{LABEL} =~ /^$rep_label/) {
+        1;
+      } elsif ($b->{LABEL} =~ /^$ver_label/) {
+        $a->{LABEL} cmp $b->{LABEL} or $a->{VALUE} cmp $b->{VALUE};
+      } else {
+        -1;
+      }
+    } else {
+
+      # Source directories labels
+      if ($b->{LABEL} =~ /^(?:$rep_label|$ver_label)/) {
+        1;
+      } else {
+        $a->{LABEL} cmp $b->{LABEL} or $a->{VALUE} cmp $b->{VALUE};
+      }
+
+    }
+  } @lines;
+
+  # Add lines for specifying repository, version and source directories
+  while (my $line = shift @lines) {
+    $cfg->add_line (
+      LABEL => $line->{LABEL},
+      VALUE => $line->{VALUE},
+    );
+  }
+
+  # Add declared bld cfg entries
+  if (@{ $self->{BDECLARE} }) {
+    # Blank line
+    $cfg->add_line;
+
+    $cfg->add_comment_block ('Declared bld cfg entries');
+    for my $bdeclare (@{ $self->{BDECLARE} }) {
+      $cfg->add_line (
+        LABEL => $cfg_labels{BDECLARE} . '::' . $bdeclare->{LABEL},
+        VALUE => $bdeclare->{VALUE},
+      );
+    }
+  }
+
+  # Print lines to config file
+  $cfg->print_cfg ($self->{DEST}{EXT_CFG});
+
+  return 1;
+
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_write_bld_cfg ();
+#
+# DESCRIPTION
+#   This internal method writes the build configuration file.
+# ------------------------------------------------------------------------------
+
+sub _write_bld_cfg {
+  my $self = shift;
+
+  my %cfg_labels = %{ $self->config->setting ('CFG_LABEL') };
+  my %subdir     = %{ $self->config->setting ('DIR') };
+  my %cfgname    = %{ $self->config->setting ('CFG_NAME') };
+
+  # Create new config file object and assign lines to it
+  my $cfg = Fcm::CfgFile->new (CONFIG => $self->config, TYPE => 'bld');
+
+  # Set up config file header
+  $cfg->add_header ();
+
+  # Pre-compile source
+  if (@{ $self->{USE} }) {
+    $cfg->add_comment_block ('Pre-compile source');
+
+    for my $reuse (@{ $self->{USE} }) {
+      my $rootdir;
+      my $bld_cfg;
+
+      if ($self->{RDEST}{MACHINE}) {
+        $rootdir = $reuse->rdest ('ROOTDIR');
+        $bld_cfg = $reuse->rdest ('BLD_CFG');
+      } else {
+        $rootdir = $reuse->dest ('ROOTDIR');
+        $bld_cfg = $reuse->dest ('BLD_CFG');
+      }
+
+      # Default location of build config file
+      my $def_bld_cfg = catfile $rootdir, $subdir{CFG}, $cfgname{BLD};
+
+      $cfg->add_line (
+        LABEL => $cfg_labels{USE},
+        VALUE => $bld_cfg eq $def_bld_cfg ? $rootdir : $bld_cfg,
+      );
+    }
+
+    # Blank line
+    $cfg->add_line;
+  }
+
+  # Add declared bld cfg entries
+  if (@{ $self->{BDECLARE} }) {
+    $cfg->add_comment_block ('Declared build options...');
+
+    my @bdeclares = sort {$a->{LABEL} cmp $b->{LABEL}} @{ $self->{BDECLARE} };
+    for my $bdeclare (@bdeclares) {
+      $cfg->add_line (
+        LABEL => $bdeclare->{LABEL},
+        VALUE => $bdeclare->{VALUE},
+      );
+    }
+
+    # Blank line
+    $cfg->add_line;
+  }
+
+  # Add source directories to config file
+  $cfg->add_comment_block ('Project directory tree');
+
+  my $dest = $self->{RDEST}{MACHINE} ? $self->{RDEST} : $self->{DEST};
+  $cfg->add_line (
+    LABEL => $cfg_labels{DIR} . '::ROOT',
+    VALUE => $dest->{ROOTDIR},
+  );
+  for my $label (qw/SRC CFG/) {
+    my $dir = $label . 'DIR';
+    if ($dest->{$dir} ne catfile $dest->{ROOTDIR}, $subdir{$label}) {
+      $cfg->add_line (
+        LABEL => $cfg_labels{DIR} . '::' . $label,
+        VALUE => $dest->{$dir},
+      );
+    }
+  }
+
+  # Blank line
+  $cfg->add_line;
+
+  # Add source directories to config file
+  $cfg->add_comment_block ('Source directories');
+
+  $cfg->add_line (LABEL => $cfg_labels{SEARCH_SRC}, VALUE => '0',);
+  $cfg->add_line;
+
+  for my $srcdir (sort keys %{ $self->{SRCDIRS} }) {
+
+    if (-d $self->{SRCDIRS}{$srcdir}{DEST}) {
+      # Check whether pre-extracted source exists
+      my $pre_extracted = grep {
+        $_->extracted;
+      } @{ $self->{SRCDIRS}{$srcdir}{STACK} };
+
+      # Source directory
+      my $dest = undef;
+      if ($self->{RDEST}{MACHINE}) {
+        my $base = substr $self->{SRCDIRS}{$srcdir}{DEST},
+                          length ($self->{DEST}{SRCDIR}) + 1;
+        $dest    = catfile $self->{RDEST}{SRCDIR}, $base;
+      } else {
+        $dest = $self->{SRCDIRS}{$srcdir}{DEST}
+      }
+
+      # Source directory label
+      my $label = join '::', ($cfg_labels{SRCDIR}, $srcdir);
+
+      $cfg->add_line (LABEL => $label, VALUE => $dest,)
+    }
+
+  }
+
+  # Print lines to config file
+  $cfg->print_cfg ($self->{DEST}{BLD_CFG});
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_mirror_extract ();
+#
+# DESCRIPTION
+#   This internal method mirrors the current extract to a remote machine.
+# ------------------------------------------------------------------------------
+
+sub _mirror_extract {
+  my $self = shift;
+
+  # Needs mirroring only if remote machine is set
+  return unless $self->{RDEST}{MACHINE};
+
+  my $verbose = $self->config->verbose;
+
+  my $mirror = $self->config->setting (qw/TOOL MIRROR/);
+
+  if ($mirror eq 'rdist') {
+    # Use "rdist" to mirror extract
+
+    # Variable for "remote_logname@remote_machine"
+    my $rhost = $self->{RDEST}{LOGNAME} . '@' . $self->{RDEST}{MACHINE};
+
+    # Print distfile content to temporary file
+    my @distfile = ();
+    for my $my_label (qw/BLD_CFG EXT_CFG SRCDIR/) {
+      push @distfile, '( ' . $self->{DEST}{$my_label} . ' ) -> ' . $rhost . "\n";
+      push @distfile, '  install ' . $self->{RDEST}{$my_label} . ';' . "\n";
+    }
+
+    # Set up mirroring command (use "rdist" at the moment)
+    my $command = 'rdist -R';
+    $command   .= ' -q' unless $verbose > 1;
+    $command   .= ' -f - 1>/dev/null';
+
+    # Diagnostic
+    my $croak = 'Cannot execute "' . $command . '"';
+    if ($verbose > 2) {
+      print timestamp_command ($command, 'Start');
+      print '  ', $_ for (@distfile);
+    }
+
+    # Execute the mirroring command
+    open COMMAND, '|-', $command or croak $croak, ' (', $!, '), abort';
+    for my $line (@distfile) {
+      print COMMAND $line;
+    }
+    close COMMAND or croak $croak, ' (', $?, '), abort';
+
+    # Diagnostic
+    print timestamp_command ($command, 'End  ') if $verbose > 2;
+
+  } elsif ($mirror eq 'rsync') {
+    # Use "rsync" to mirror extract
+
+    my $rsh = $self->config->setting (qw/TOOL REMOTE_SHELL/);
+
+    # Variable for "remote_logname@remote_machine"
+    my $rhost = $self->{RDEST}{LOGNAME} . '@' . $self->{RDEST}{MACHINE};
+
+    for my $my_label (qw/BLD_CFG EXT_CFG SRCDIR/) {
+      my $rdir = dirname $self->{RDEST}{$my_label}; # remote container directory
+
+      {
+        # Create remote container directory with remote shell command
+        my @command = (
+          $rsh, $self->{RDEST}{MACHINE}, '-n', '-l', $self->{RDEST}{LOGNAME},
+          qw/mkdir -p/, $rdir,
+        );
+
+        # Execute command
+        &run_command (\@command, TIME => $verbose > 2);
+      }
+
+      {
+        # Build the rsync command
+        my @command = qw/rsync -a --exclude='.*' --delete-excluded/;
+        push @command, '-v' if $verbose > 2;
+        push @command, $self->{DEST}{$my_label};
+        push @command, $rhost . ':' . $rdir;
+
+        # Execute command
+        &run_command (\@command, TIME => $verbose > 2);
+      }
+    }
+
+  } else {
+    w_report $mirror, ': unknown mirroring tool, abort.';
+    return;
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/ReposBranch.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/ReposBranch.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/ReposBranch.pm	(revision 7236)
@@ -0,0 +1,516 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Fcm::ReposBranch
+#
+# DESCRIPTION
+#   This class contains methods for gathering information for a repository
+#   branch. It currently supports Subversion repository and local user
+#   directory.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::ReposBranch;
+
+# Standard pragma
+use warnings;
+use strict;
+
+# Standard modules
+use Carp;
+use File::Spec;
+use File::Spec::Functions;
+use File::Basename;
+use File::Find;
+
+# FCM component modules
+use Fcm::Util;
+use Fcm::Timer;
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $branch = Fcm::ReposBranch->new (
+#     CONFIG  => $config,
+#     PACKAGE => $package,
+#     TAG     => $tag,
+#     REPOS   => $repos,
+#     VERSION => $version,
+#     TYPE    => $type,
+#   );
+#
+# DESCRIPTION
+#   This method constructs a new instance of the Fcm::ReposBranch class.
+#
+# ARGUMENTS
+#   CONFIG  - reference to a Fcm::Config instance
+#   PACKAGE - package name of which this repository belongs
+#   TAG     - "tag" name of this branch of the repository
+#   REPOS   - repository branch root URL/path
+#   VERSION - this version of the branch is used by the extract
+#   TYPE    - repository type
+# ------------------------------------------------------------------------------
+
+sub new {
+  my $this  = shift;
+  my %args  = @_;
+  my $class = ref $this || $this;
+
+  my $self = {
+    CONFIG  => (exists $args{CONFIG}  ? $args{CONFIG}  : &main::cfg),
+    PACKAGE => (exists $args{PACKAGE} ? $args{PACKAGE} : undef),
+    TAG     => (exists $args{TAG}     ? $args{TAG}     : undef),
+    REPOS   => (exists $args{REPOS}   ? $args{REPOS}   : undef),
+    VERSION => (exists $args{VERSION} ? $args{VERSION} : undef),
+    TYPE    => (exists $args{TYPE}    ? $args{TYPE}    : undef),
+
+    # Use this list of directories in this branch
+    DIRS    => {},
+
+    # Expand this list of directories in this branch
+    EXPDIRS => {},
+  };
+
+  bless $self, $class;
+  return $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $config = $branch->config;
+#
+# DESCRIPTION
+#   This method returns a reference to the Fcm::Config instance.
+# ------------------------------------------------------------------------------
+
+sub config {
+  my $self = shift;
+
+  return $self->{CONFIG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $package = $branch->package;
+#   $branch->package ($package);
+#
+# DESCRIPTION
+#   This method returns the package name of this repository branch. If an
+#   argument is specified, the name is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub package {
+  my $self = shift;
+
+  if (@_) {
+    $self->{PACKAGE} = shift;
+  }
+
+  return $self->{PACKAGE};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $tag = $branch->tag;
+#   $branch->tag ($tag);
+#
+# DESCRIPTION
+#   This method returns the tag name of this repository branch. If an
+#   argument is specified, the name is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub tag {
+  my $self = shift;
+
+  if (@_) {
+    $self->{TAG} = shift;
+  }
+
+  return $self->{TAG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $repos = $branch->repos;
+#   $branch->repos ($repos);
+#
+# DESCRIPTION
+#   This method returns the URL/path name of this repository branch. If an
+#   argument is specified, the URL/path is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub repos {
+  my $self = shift;
+
+  if (@_) {
+    $self->{REPOS} = shift;
+  }
+
+  return $self->{REPOS};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $version= $branch->version;
+#   $branch->version ($version);
+#
+# DESCRIPTION
+#   This method returns the revision number of this repository branch. If an
+#   argument is specified, the revision is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub version {
+  my $self = shift;
+
+  if (@_) {
+    $self->{VERSION} = shift;
+  }
+
+  return $self->{VERSION};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $type = $branch->type;
+#   $branch->type ($type);
+#
+# DESCRIPTION
+#   This method returns the repository type ("svn" or "user"). If an
+#   argument is specified, the type is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub type {
+  my $self = shift;
+
+  if (@_) {
+    $self->{TYPE} = shift;
+  }
+
+  return $self->{TYPE};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $dir = $branch->dir ($name);
+#   $branch->dir ($name, $dir);
+#
+# DESCRIPTION
+#   This method returns the path to the source directory with sub-package name
+#   $name. If $dir is specified, the path is set to its value.
+# ------------------------------------------------------------------------------
+
+sub dir {
+  my $self = shift;
+  my $name = shift;
+
+  if (@_) {
+    $self->{DIRS}{$name} = $_[0];
+  }
+
+  if (exists $self->{DIRS}{$name}) {
+    return $self->{DIRS}{$name};
+
+  } else {
+    return undef;
+  }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   %dirs = $branch->dirs;
+#
+# DESCRIPTION
+#   This method returns a hash containing the source directories of this
+#   repository. The keys of the hash are the sub-package names, and the values
+#   of the hash are the URL/path to the source directories.
+# ------------------------------------------------------------------------------
+
+sub dirs {
+  my $self = shift;
+
+  return %{ $self->{DIRS} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $dir = $branch->expdir ($name);
+#   $branch->expdir ($name, $dir);
+#
+# DESCRIPTION
+#   This method returns the path to the expandable source directory with
+#   sub-package name $name. If $dir is specified, the path is set to its
+#   value.
+# ------------------------------------------------------------------------------
+
+sub expdir {
+  my $self = shift;
+  my $name = shift;
+
+  if (@_) {
+    $self->{EXPDIRS}{$name} = $_[0];
+  }
+
+  if (exists $self->{EXPDIRS}{$name}) {
+    return $self->{EXPDIRS}{$name};
+
+  } else {
+    return undef;
+  }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   %dirs = $branch->expdirs;
+#
+# DESCRIPTION
+#   This method returns a hash containing the expandable source directories of
+#   this repository. The keys of the hash are the sub-package names, and the
+#   values of the hash are the URL/path to the expandable source directories.
+# ------------------------------------------------------------------------------
+
+sub expdirs {
+  my $self = shift;
+
+  return %{ $self->{EXPDIRS} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $branch->expand_version_tag;
+#
+# DESCRIPTION
+#   This method expands the VERSION of the current repository branch to a
+#   revision number.
+# ------------------------------------------------------------------------------
+
+sub expand_version_tag {
+  my $self = shift;
+
+  if ($self->type eq 'svn') {
+    # Expand revision keyword
+    my $rev = expand_rev_keyword (
+      REV  => $self->version,
+      URL  => $self->repos,
+      HEAD => 1,
+    );
+
+    # Find out whether the specified revision is current or not
+    if (uc ($self->version) ne 'HEAD' and $self->config->verbose > 1) {
+      # Get last commit revision
+      my $lc_rev = expand_rev_keyword (
+        REV => 'HEAD',
+        URL => $self->repos,
+      );
+
+      # Print information if used rev is less than the last commit rev
+      print 'Info: using rev ', $rev, ' of ', $self->repos,
+            ', last commit rev is ', $lc_rev, ".\n"
+        if $rev < $lc_rev;
+    }
+
+    $self->version ($rev) if $rev ne $self->version;
+
+  } elsif ($self->type eq 'user') {
+    return;
+
+  } else {
+    e_report $self->repos, ': repository type "', $self->type,
+             '" not supported.';
+  }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $branch->expand_path;
+#
+# DESCRIPTION
+#   This method expands the relative path names of sub-directories to full
+#   path names. It returns 1 on success.
+# ------------------------------------------------------------------------------
+
+sub expand_path {
+  my $self = shift;
+
+  my $separator = $self->{CONFIG}->setting (qw/MISC DIR_SEPARATOR/);
+
+  if ($self->type eq 'svn') {
+    # SVN repository
+    # Do nothing unless there is a declared repository for this branch
+    return unless $self->{REPOS};
+
+    # Remove trailing /
+    $self->{REPOS} =~ s/$separator+$//;
+
+    # Consider all declared (expandable) sub-directories
+    for my $name (qw/DIRS EXPDIRS/) {
+      for my $dir (keys %{ $self->{$name} }) {
+        # Do nothing if declared sub-directory is quoted as a full URL
+        next if &is_url ($self->{$name}{$dir});
+
+        # Expand sub-directory to full URL
+        $self->{$name}{$dir} = $self->{REPOS} . (
+          $self->{$name}{$dir} ? ($separator . $self->{$name}{$dir}) : ''
+        );
+      }
+    }
+    # Note: "catfile" cannot be used in the above statement because it has
+    #       the tendency of removing a slash from double slashes.
+
+  } elsif ($self->type eq 'user') {
+    # Local user directories
+
+    # Expand leading ~ for all declared (expandable) sub-directories
+    for my $name (qw/DIRS EXPDIRS/) {
+      for my $dir (keys %{ $self->{$name} }) {
+        $self->{$name}{$dir} = expand_tilde $self->{$name}{$dir};
+      }
+    }
+
+    # A top directory for the source is declared
+    if ($self->{REPOS}) {
+      # Expand leading ~ for the top directory
+      $self->{REPOS} = expand_tilde $self->{REPOS};
+
+      # Get the root directory of the file system
+      my $rootdir = File::Spec->rootdir ();
+
+      # Expand top directory to absolute path, if necessary
+      $self->{REPOS} = File::Spec->rel2abs ($self->{REPOS})
+        if $self->{REPOS} !~ m/^$rootdir/;
+
+      # Remove trailing /
+      $self->{REPOS} =~ s/$separator+$//;
+
+      # Consider all declared (expandable) sub-directories
+      for my $name (qw/DIRS EXPDIRS/) {
+        for my $dir (keys %{ $self->{$name} }) {
+          # Do nothing if declared sub-directory is quoted as a full path
+          next if $self->{$name}{$dir} =~ m#^$rootdir#;
+
+          # Expand sub-directory to full path
+          $self->{$name}{$dir} = $self->{$name}{$dir}
+                               ? catfile ($self->{REPOS}, $self->{$name}{$dir})
+                               : $self->{REPOS};
+        }
+      }
+    }
+
+  } else {
+    e_report $self->repos, ': repository type "', $self->type,
+             '" not supported.';
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $branch->expand_all;
+#
+# DESCRIPTION
+#   This method searches the expandable source directories recursively for
+#   source directories containing regular files. These sub-directories are
+#   then added to the source directory list. The method returns total number
+#   of sub-directories to be extracted from the current repository.
+# ------------------------------------------------------------------------------
+
+sub expand_all {
+  my $self = shift;
+
+  my %dirs = ();
+
+  # Directory separator for SVN repository
+  my $separator = $self->{CONFIG}->setting (qw/MISC DIR_SEPARATOR/);
+
+  if ($self->type eq 'user') {
+    for my $rootname (keys %{ $self->{EXPDIRS} }) {
+      my %subdirs = find_srcdir $self->{EXPDIRS}{$rootname}, $rootname, '::';
+
+      for my $key (keys %subdirs) {
+        $dirs{$key} = $subdirs{$key};
+      }
+    }
+
+  } elsif  ($self->type eq 'svn') {
+    for my $rootname (keys %{ $self->{EXPDIRS} }) {
+      # Execute the "svn ls -R" command
+      my @lines   = &run_command (
+        [qw/svn ls -R/, $self->{EXPDIRS}{$rootname} . '@' . $self->{VERSION}],
+        METHOD => 'qx', TIME => $self->config->verbose > 2,
+      );
+
+      # Get list of sub-directories containing source files
+      for my $line (@lines) {
+        chomp $line;
+        next if $line =~ /$separator$/;
+
+        my $dir = dirname $line;
+
+        my @pck = split /::/, $rootname;
+        push @pck, (File::Spec->splitdir ($dir)) unless $dir eq '.';
+        my $pck = join '::', @pck;
+
+        my $val = $self->{EXPDIRS}{$rootname};
+        $val   .= $separator . $dir unless $dir eq '.';
+
+        $dirs{$pck} = $val;
+      }
+    }
+
+  } else {
+    e_report $self->repos, ': repository type "', $self->type,
+             '" not supported.';
+  }
+
+  for my $key (keys %dirs) {
+    $self->{DIRS}{$key} = $dirs{$key};
+  }
+
+  return scalar keys %dirs;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $branch->add_base_dirs ($base);
+#
+# DESCRIPTION
+#   Add a list of source directories to the current branch based on the set
+#   provided by $base, which must be a reference to a Fcm::ReposBranch
+#   instance. It returns the total number of used sub-directories in the
+#   current repositories.
+# ------------------------------------------------------------------------------
+
+sub add_base_dirs {
+  my $self = shift;
+  my $base = shift;
+
+  my %base_dirs = $base->dirs;
+
+  for my $key (keys %base_dirs) {
+    # Remove repository root from base directories
+    if ($base_dirs{$key} eq $base->repos) {
+      $base_dirs{$key} = '';
+
+    } else {
+      $base_dirs{$key} = substr $base_dirs{$key}, length ($base->repos) + 1;
+    }
+
+    # Append base directories to current repository root
+    $self->dir ($key, $base_dirs{$key}); 
+  }
+
+  # Expand relative path names of sub-directories
+  $self->expand_path;
+
+  return scalar keys %{ $self->{DIRS} };
+  
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/SrcDirLayer.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/SrcDirLayer.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/SrcDirLayer.pm	(revision 7236)
@@ -0,0 +1,481 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Fcm::SrcDirLayer
+#
+# DESCRIPTION
+#   This class contains methods to manipulate the extract of a source
+#   directory from a branch of a (Subversion) repository.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::SrcDirLayer;
+
+# Standard pragma
+use warnings;
+use strict;
+
+# Standard modules
+use Carp;
+use File::Spec;
+use File::Spec::Functions;
+use File::Basename;
+use File::Path;
+use File::Compare;
+
+# FCM component modules
+use Fcm::Util;
+use Fcm::Timer;
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $layer = Fcm::SrcDirLayer->new (
+#     CONFIG    => $config,
+#     NAME      => $dir,
+#     PACKAGE   => $package,
+#     TAG       => $tag,
+#     LOCATION  => $loc,
+#     REPOSROOT => $repos,
+#     VERSION   => $ver,
+#     TYPE      => $type,
+#     COMMIT    => $com,
+#     EXTRACTED => $ext,
+#     CACHEDIR  => $cac,
+#   );
+#
+# DESCRIPTION
+#   This method constructs a new instance of the Fcm::SrcDirLayer class.
+#
+# ARGUMENTS
+#   CONFIG    - reference to a Fcm::Config instance
+#   NAME      - sub-package name of the source directory
+#   PACKAGE   - top level package name of which the current repository belongs
+#   TAG       - package/revision tag of the current repository branch
+#   LOCATION  - location of the source directory in the branch
+#   REPOSROOT - repository root URL
+#   VERSION   - revision of the repository branch
+#   TYPE      - type of the repository branch ("svn" or "user")
+#   COMMIT    - revision at which the source directory was changed
+#   EXTRACTED - is this branch already extracted?
+#   CACHEDIR  - cache directory for this directory branch
+# ------------------------------------------------------------------------------
+
+sub new {
+  my $this  = shift;
+  my %args  = @_;
+  my $class = ref $this || $this;
+
+  my $self = {
+    CONFIG    => (exists $args{CONFIG}    ? $args{CONFIG}    : &main::cfg),
+    NAME      => (exists $args{NAME}      ? $args{NAME}      : undef),
+    PACKAGE   => (exists $args{PACKAGE}   ? $args{PACKAGE}   : undef),
+    TAG       => (exists $args{TAG}       ? $args{TAG}       : undef),
+    LOCATION  => (exists $args{LOCATION}  ? $args{LOCATION}  : undef),
+    REPOSROOT => (exists $args{REPOSROOT} ? $args{REPOSROOT} : undef),
+    VERSION   => (exists $args{VERSION}   ? $args{VERSION}   : undef),
+    TYPE      => (exists $args{TYPE}      ? $args{TYPE}      : undef),
+    COMMIT    => (exists $args{COMMIT}    ? $args{COMMIT}    : undef),
+    EXTRACTED => (exists $args{EXTRACTED} ? $args{EXTRACTED} : undef),
+    CACHEDIR  => (exists $args{CACHEDIR}  ? $args{CACHEDIR}  : undef),
+
+    # List of source files in this directory branch
+    FILES     => [],
+  };
+
+  bless $self, $class;
+  return $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $config = $layer->config;
+#
+# DESCRIPTION
+#   This method returns a reference to the Fcm::Config instance.
+# ------------------------------------------------------------------------------
+
+sub config {
+  my $self = shift;
+
+  return $self->{CONFIG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $name = $layer->name;
+#   $layer->name ($name);
+#
+# DESCRIPTION
+#   This method returns the sub-package name of the current source directory.
+#   If an argument is specified, the sub-package name is set to the value of
+#   the argument.
+# ------------------------------------------------------------------------------
+
+sub name {
+  my $self = shift;
+
+  if (@_) {
+    $self->{NAME} = shift;
+  }
+
+  return $self->{NAME};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $package = $layer->package;
+#   $layer->package ($package);
+#
+# DESCRIPTION
+#   This method returns the top level package name in which the current source
+#   directory belongs. If an argument is specified, the package name is set to
+#   the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub package {
+  my $self = shift;
+
+  if (@_) {
+    $self->{PACKAGE} = shift;
+  }
+
+  return $self->{PACKAGE};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $tag = $layer->tag;
+#   $layer->tag ($tag);
+#
+# DESCRIPTION
+#   This method returns the branch/revision tag of the current repository
+#   branch. If an argument is specified, the tag is set to the value of the
+#   argument.
+# ------------------------------------------------------------------------------
+
+sub tag {
+  my $self = shift;
+
+  if (@_) {
+    $self->{TAG} = shift;
+  }
+
+  return $self->{TAG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $location = $layer->location;
+#   $layer->location ($location);
+#
+# DESCRIPTION
+#   This method returns the URL/location of the source directory in the
+#   branch. If an argument is specified, the location is set to the value of
+#   the argument.
+# ------------------------------------------------------------------------------
+
+sub location {
+  my $self = shift;
+
+  if (@_) {
+    $self->{LOCATION} = shift;
+  }
+
+  return $self->{LOCATION};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $reposroot = $layer->reposroot;
+#   $layer->reposroot ($reposroot);
+#
+# DESCRIPTION
+#   This method returns the URL/location of the repository root of this
+#   branch. If an argument is specified, the location is set to the value of
+#   the argument.
+# ------------------------------------------------------------------------------
+
+sub reposroot {
+  my $self = shift;
+
+  if (@_) {
+    $self->{REPOSROOT} = shift;
+  }
+
+  return $self->{REPOSROOT};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $version = $layer->version;
+#   $layer->version ($version);
+#
+# DESCRIPTION
+#   This method returns the revision number of this branch. If an argument is
+#   specified, the revision number is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub version {
+  my $self = shift;
+
+  if (@_) {
+    $self->{VERSION} = shift;
+  }
+
+  return $self->{VERSION};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $type = $layer->type;
+#   $layer->type ($type);
+#
+# DESCRIPTION
+#   This method returns the repository type ("svn" or "user"). If an argument is
+#   specified, the type is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub type {
+  my $self = shift;
+
+  if (@_) {
+    $self->{TYPE} = shift;
+  }
+
+  return $self->{TYPE};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $version = $layer->commit;
+#   $layer->commit ($version);
+#
+# DESCRIPTION
+#   This method returns the last modified revision of the source directory in
+#   the branch. If an argument is specified, this revision is set to the value
+#   of the argument.
+# ------------------------------------------------------------------------------
+
+sub commit {
+  my $self = shift;
+
+  if (@_) {
+    $self->{COMMIT} = shift;
+  }
+
+  return $self->{COMMIT};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $extracted = $layer->extracted;
+#   $layer->extracted ($extracted);
+#
+# DESCRIPTION
+#   This method returns the "extracted flag" of the source directory branch
+#   If an argument is specified, the flag is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub extracted {
+  my $self = shift;
+
+  if (@_) {
+    $self->{EXTRACTED} = shift;
+  }
+
+  return $self->{EXTRACTED};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $dir = $layer->cachedir;
+#   $layer->cachedir ($dir);
+#
+# DESCRIPTION
+#   This method returns the cache directory of the source directory branch
+#   If an argument is specified, the cache directory is set to the value of
+#   the argument.
+# ------------------------------------------------------------------------------
+
+sub cachedir {
+  my $self = shift;
+
+  if (@_) {
+    my $dir = shift;
+    $self->{CACHEDIR} = $dir;
+  }
+
+  return $self->{CACHEDIR};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $dir = $layer->localdir;
+#
+# DESCRIPTION
+#   This method returns the user or cache directory for the current revision
+#   of the repository branch.
+# ------------------------------------------------------------------------------
+
+sub localdir {
+  my $self = shift;
+
+  return $self->user ? $self->{LOCATION} : $self->{CACHEDIR};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @files = $layer->files;
+#
+# DESCRIPTION
+#   This method returns a list of regular files in this directory branch.
+#   This method should only be called after a successful operation of the
+#   get_files method that will be described below.
+# ------------------------------------------------------------------------------
+
+sub files {
+  my $self = shift;
+
+  return @{ $self->{FILES} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $user = $layer->user;
+#
+# DESCRIPTION
+#   This method returns the string "user" if the current source directory
+#   branch is a local directory. Otherwise, it returns "undef".
+# ------------------------------------------------------------------------------
+
+sub user {
+  my $self = shift;
+
+  return $self->{TYPE} eq 'user' ? 'user' : undef;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $version = $layer->get_commit;
+#
+# DESCRIPTION
+#   If the current repository type is "svn", this method attempts to obtain
+#   the revision in which the branch is last committed. On a successful
+#   operation, it returns this revision number. Otherwise, it returns
+#   "undef".
+# ------------------------------------------------------------------------------
+
+sub get_commit {
+  my $self = shift;
+
+  if ($self->type eq 'svn') {
+    # Execute the "svn info" command
+    my @lines   = &run_command (
+      [qw/svn info/, $self->{LOCATION} . '@' . $self->{VERSION}],
+      METHOD => 'qx', TIME => $self->config->verbose > 2,
+    );
+
+    my $rev;
+    for (@lines) {
+      if (/^Last\s+Changed\s+Rev\s*:\s*(\d+)/i) {
+        $rev = $1;
+        last;
+      }
+    }
+
+    # Commit version of this source directory
+    $self->{COMMIT} = $rev;
+
+    return $self->{COMMIT};
+
+  } elsif ($self->type eq 'user') {
+    return;
+
+  } else {
+    e_report 'Repository type "', $self->type, '" not supported.';
+  }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rc = $layer->update_cache;
+#
+# DESCRIPTION
+#   If the current repository type is "svn", this method attempts to extract
+#   the current version source directory from the current branch from the
+#   repository, sending the output to the cache directory. It returns true on
+#   a successful operation, or false if the repository is not of type "svn".
+# ------------------------------------------------------------------------------
+
+sub update_cache {
+  my $self = shift;
+
+  return unless $self->{CACHEDIR};
+
+  # Create cache extract destination, if necessary
+  my $dirname = dirname $self->{CACHEDIR};
+  mkpath $dirname if not -d $dirname;
+
+  e_report $dirname, ': cannot write to cache, abort.'
+    unless -d $dirname and -w $dirname;
+  
+  if ($self->type eq 'svn') {
+    # Set up the extract command, "svn export --force -q -N"
+    my @command = (
+      qw/svn export --force -q -N/,
+      $self->{LOCATION} . '@' . $self->{VERSION},
+      $self->{CACHEDIR},
+    );
+
+    &run_command (\@command, TIME => $self->config->verbose > 2);
+
+  } elsif ($self->type eq 'user') {
+    return;
+
+  } else {
+    e_report 'Repository type "', $self->type, '" not supported.';
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @files = $layer->get_files;
+#
+# DESCRIPTION
+#   This method returns a list of files in the cache or local user directory
+#   of the current version of the source directory in the current branch.
+# ------------------------------------------------------------------------------
+
+sub get_files {
+  my $self = shift;
+
+  # Get a list of files in the cache (or local user) directory
+  my @files = ();
+
+  opendir (DIR, $self->localdir)
+    or die $self->localdir, ': cannot read directory';
+
+  while (my $file = readdir DIR) {
+    next if $file =~ /^\.\.?/;                   # ignore . and .. and hidden
+    next if $file =~ /~$/;                       # ignore emacs swap files
+    next if -d catfile ($self->localdir, $file); # ignore sub-directories
+    push @files, $file;
+  }
+  closedir DIR;
+
+  # Return the (base name) of the list of files
+  $self->{FILES} = \@files;
+  return @files;
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/SrcFile.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/SrcFile.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/SrcFile.pm	(revision 7236)
@@ -0,0 +1,1538 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Fcm::SrcFile
+#
+# DESCRIPTION
+#   This class contains methods to manipulate the build process of a source
+#   file of supported type.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::SrcFile;
+
+# Standard pragma
+
+use strict;
+use warnings;
+
+# Standard modules
+use Cwd;
+use Carp;
+use File::Basename;
+use File::Spec;
+use File::Spec::Functions;
+
+# FCM component modules
+use Fcm::Util;
+use Fcm::Timer;
+
+# Other modules
+use Ecmwf::Fortran90_stuff ();
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $srcfile = Fcm::SrcFile->new (
+#     CONFIG     => $config,
+#     SRCPACKAGE => $srcpackage,
+#     SRC        => $src,
+#     PPSRC      => $ppsrc,
+#     TYPE       => $type,
+#     SCAN       => $scan,
+#     EXEBASE    => $exebase,
+#     PCKCFG     => $pckcfg,
+#   );
+#
+# DESCRIPTION
+#   This method constructs a new instance of the Fcm::SrcFile class.
+#
+# ARGUMENTS
+#   CONFIG     - reference to a Fcm::Config instance
+#   SRCPACKAGE - reference to the container Fcm::SrcPackage instance
+#   SRC        - source path of this file
+#   PPSRC      - pre-processed source path of this file
+#   TYPE       - type flag of this source file
+#   SCAN       - scan source file for dependency?
+#   EXEBASE    - name of executable
+#   PCKCFG     - this source file is modified by a package cfg?
+# ------------------------------------------------------------------------------
+
+sub new {
+  my $this  = shift;
+  my %args  = @_;
+  my $class = ref $this || $this;
+
+  my $self = {
+    CONFIG     => exists $args{CONFIG}     ? $args{CONFIG}     : &main::cfg,
+    SRCPACKAGE => exists $args{SRCPACKAGE} ? $args{SRCPACKAGE} : undef,
+    SRC        => exists $args{SRC}        ? $args{SRC}        : undef,
+    PPSRC      => exists $args{PPSRC}      ? $args{PPSRC}      : undef,
+    TYPE       => exists $args{TYPE}       ? $args{TYPE}       : undef,
+    SCAN       => exists $args{SCAN}       ? $args{SCAN}       : 1,
+    EXEBASE    => exists $args{EXEBASE}    ? $args{EXEBASE}    : undef,
+    PCKCFG     => exists $args{PCKCFG}     ? $args{PCKCFG}     : undef,
+
+    PROGNAME   => undef,
+    LANG       => undef,
+    DEP        => {}, 
+    RULES      => {},
+  };
+  bless $self, $class;
+
+  return $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $config = $srcfile->config;
+#
+# DESCRIPTION
+#   This method returns a reference to the Fcm::Config instance.
+# ------------------------------------------------------------------------------
+
+sub config {
+  my $self = shift;
+
+  return $self->{CONFIG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $srcpackage = $srcfile->srcpackage;
+#   $srcfile->srcpackage ($srcpackage);
+#
+# DESCRIPTION
+#   This method returns the reference to the container Fcm::SrcPackage of this
+#   source file. If an argument is specified, the reference is set to the
+#   value of the argument.
+# ------------------------------------------------------------------------------
+
+sub srcpackage {
+  my $self = shift;
+
+  if (@_) {
+    $self->{SRCPACKAGE} = shift;
+  }
+
+  return $self->{SRCPACKAGE};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $src = $srcfile->src;
+#   $srcfile->src ($src);
+#
+# DESCRIPTION
+#   This method returns the reference to the location of this source file. If
+#   an argument is specified, the location is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub src {
+  my $self = shift;
+
+  if (@_) {
+    $self->{SRC} = shift;
+  }
+
+  return $self->{SRC};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ppsrc = $srcfile->ppsrc;
+#   $srcfile->ppsrc ($ppsrc);
+#
+# DESCRIPTION
+#   This method returns the reference to the location of the pre-processed
+#   file of this source file. If an argument is specified, the location is set
+#   to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub ppsrc {
+  my $self = shift;
+
+  if (@_) {
+    $self->{PPSRC} = shift;
+  }
+
+  return $self->{PPSRC};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $time = $srcfile->mtime;
+#
+# DESCRIPTION
+#   This method returns the last modified time of the source file. If a
+#   pre-processed version of the source file exists, it returns the last
+#   modified time of the pre-processed source file instead.
+# ------------------------------------------------------------------------------
+
+sub mtime {
+  my $self = shift;
+
+  return $self->{PPSRC} ? (stat $self->{PPSRC})[9] : (stat $self->{SRC})[9];
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $base = $srcfile->base;
+#
+# DESCRIPTION
+#   This method returns the base name of the source file.
+# ------------------------------------------------------------------------------
+
+sub base {
+  my $self = shift;
+
+  return basename ($self->{SRC});
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ppbase = $srcfile->ppbase;
+#
+# DESCRIPTION
+#   This method returns the base name of the pre-processed source file.
+# ------------------------------------------------------------------------------
+
+sub ppbase {
+  my $self = shift;
+
+  return basename ($self->{PPSRC});
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $interfacebase = $srcfile->interfacebase;
+#
+# DESCRIPTION
+#   This method returns the base name of the F9X interface file.
+# ------------------------------------------------------------------------------
+
+sub interfacebase {
+  my $self   = shift;
+  my $return = undef;
+
+  if ($self->is_type_or (qw/FORTRAN FPP/) and
+      uc ($self->select_tool ('GENINTERFACE')) ne 'NONE' and
+      not $self->is_type_or (qw/PROGRAM MODULE/)) {
+
+    my $flag = lc ($self->select_tool ('INTERFACE'));
+    my $ext  = $self->config->setting (qw/OUTFILE_EXT INTERFACE/);
+
+    $return = ($flag eq 'program' ? $self->intname : $self->root) . $ext;
+  }
+
+  return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $root = $srcfile->root;
+#
+# DESCRIPTION
+#   This method returns the root name (i.e. base name without file extension)
+#   of the source file.
+# ------------------------------------------------------------------------------
+
+sub root {
+  my $self = shift;
+
+  (my $root = $self->base) =~ s/\.\w+$//;
+
+  return $root;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ext = $srcfile->ext;
+#
+# DESCRIPTION
+#   This method returns the file extension of the source file.
+# ------------------------------------------------------------------------------
+
+sub ext {
+  my $self = shift;
+
+  return substr $self->base, length ($self->root);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ppext = $srcfile->ppext;
+#
+# DESCRIPTION
+#   This method returns the file extension of the pre-processed source file.
+# ------------------------------------------------------------------------------
+
+sub ppext {
+  my $self = shift;
+
+  return substr $self->ppbase, length ($self->root);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $dir = $srcfile->dir;
+#
+# DESCRIPTION
+#   This method returns the dir name of the source file.
+# ------------------------------------------------------------------------------
+
+sub dir {
+  my $self = shift;
+
+  return dirname ($self->{SRC});
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $ppdir = $srcfile->ppdir;
+#
+# DESCRIPTION
+#   This method returns the dir name of the pre-processed source file.
+# ------------------------------------------------------------------------------
+
+sub ppdir {
+  my $self = shift;
+
+  return dirname ($self->{PPSRC});
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $progname = $srcfile->progname();
+#   $srcfile->progname ($progname);
+#
+# DESCRIPTION
+#   This method returns the name of the first program unit in a Fortran source
+#   file. If an argument is specified, the name is set to the value of the
+#   argument.
+# ------------------------------------------------------------------------------
+
+sub progname {
+  my $self = shift;
+
+  if (@_) {
+    $self->{PROGNAME} = $_[0];
+  }
+
+  return $self->{PROGNAME};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $intname = $srcfile->intname ();
+#
+# DESCRIPTION
+#   This method returns the internal name of the source file.
+# ------------------------------------------------------------------------------
+
+sub intname {
+  my $self = shift;
+
+  return $self->progname ? $self->progname : lc ($self->root);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $objbase = $srcfile->objbase ();
+#
+# DESCRIPTION
+#   If the source file contains a compilable procedure, this method returns
+#   the name of the object file.
+# ------------------------------------------------------------------------------
+
+sub objbase {
+  my $self   = shift;
+  my $return = undef;
+
+  if ($self->is_type ('SOURCE')) {
+    my $ext = $self->config->setting (qw/OUTFILE_EXT OBJ/);
+
+    if ($self->is_type_or (qw/FORTRAN FPP/)) {
+      $return = $self->progname . $ext if $self->progname;
+
+    } else {
+      $return = $self->intname . $ext;
+    }
+  }
+
+  return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $donebase = $srcfile->donebase ();
+#
+# DESCRIPTION
+#   This method returns the DONE file for a source file containing a compilable
+#   procedure, or the IDONE file for an include file.
+# ------------------------------------------------------------------------------
+
+sub donebase {
+  my $self   = shift;
+  my $return = undef;
+
+  if ($self->is_type ('SOURCE')) {
+    if ($self->objbase and not $self->is_type ('PROGRAM')) {
+      $return = $self->intname . $self->config->setting (qw/OUTFILE_EXT DONE/);
+    }
+
+  } elsif ($self->is_type ('INCLUDE')) {
+    $return = $self->base . $self->config->setting (qw/OUTFILE_EXT IDONE/);
+  }
+
+  return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $exebase = $srcfile->exebase ();
+#   $srcfile->exebase ($exebase);
+#
+# DESCRIPTION
+#   If the source file contains a compilable main program, this method returns
+#   the executable name. If an argument is specified, the executable name is
+#   set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub exebase {
+  my $self = shift;
+
+  if (@_) {
+    $self->{EXEBASE} = $_[0];
+  }
+
+  my $return;
+
+  if ($self->objbase and $self->is_type ('PROGRAM')) {
+    if ($self->config->setting ('EXE_NAME', $self->root)) {
+      $return = $self->config->setting ('EXE_NAME', $self->root);
+
+    } elsif ($self->{EXEBASE}) {
+      $return = $self->{EXEBASE};
+
+    } else {
+      $return = $self->root . $self->config->setting (qw/OUTFILE_EXT EXE/);
+    }
+  }
+
+  return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $base = $srcfile->flagsbase ([$flag]);
+#
+# DESCRIPTION
+#   If the source file contains a compilable program unit, it returns the base
+#   name of the compiler flags-file. If $flag is set, it returns the base name
+#   of the flags file as specified by $flag. The value of $flag can be:
+#     FLAGS   - compiler flags flags-file (default)
+#     PPKEYS  - pre-processor keys (i.e. macro definitions) flags-file
+#     LD      - linker flags-file
+#     LDFLAGS - linker flags flags-file
+# ------------------------------------------------------------------------------
+
+sub flagsbase {
+  my ($self, $flag) = @_;
+  $flag             = 'FLAGS' if not $flag;
+  my $return        = undef;
+
+  if ($self->is_type ('SOURCE')) {
+    if ($flag eq 'FLAGS' or $flag eq 'PPKEYS') {
+      my %src_tool = %{ $self->config->setting ('SRC_TOOL') };
+
+      if ($self->lang and exists $src_tool{$self->lang}{$flag}) {
+        $return = join ('__', (
+          $src_tool{$self->lang}{$flag}, $self->srcpackage->name, $self->root,
+        )) . $self->config->setting (qw/OUTFILE_EXT FLAGS/);
+      }
+
+    } elsif ($self->is_type ('PROGRAM')) {
+      $return = join ('__', ($flag, $self->srcpackage->name, $self->root)) .
+                $self->config->setting (qw/OUTFILE_EXT FLAGS/);
+    }
+  }
+
+  return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   %dep   = $srcfile->dep;
+#   @files = $srcfile->dep ($type);
+#   $srcfile->dep (\%dep);
+#
+# DESCRIPTION
+#   This method returns the dependencies of this source file. If no argument
+#   is set, the method returns the dependency hash of this source file. The
+#   keys of the hash are the names of the files this source files depends on
+#   and the values of the hash are the dependency types of the corresponding
+#   files. If an argument is specified and the argument is a normal string,
+#   the method returns the keys of the dependency hash, which have their
+#   corresponding values equal to $type. If an argument is specified and the
+#   argument is a reference to a hash, the reference to the dependency hash of
+#   the current source file is re-set to point to the reference of this new
+#   hash.
+# ------------------------------------------------------------------------------
+
+sub dep {
+  my $self = shift;
+
+  if (@_) {
+    if (ref $_[0] eq 'HASH') {
+      $self->{DEP} = $_[0];
+
+    } else {
+      my $type = $_[0];
+      return grep {
+        $self->{DEP}{$_} eq $type;
+      } keys %{ $self->{DEP} };
+    }
+  }
+
+  return %{ $self->{DEP} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $srcfile->add_dep ($target, $type);
+#
+# DESCRIPTION
+#   This method adds (or modifies) a dependency to the dependency hash of the
+#   source file. The argument $type is the type of the dependency and the
+#   argument $target is the dependency target.
+# ------------------------------------------------------------------------------
+
+sub add_dep {
+  my $self = shift;
+  my ($target, $type) = @_;
+
+  $self->{DEP}{$target} = $type;
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @pklist = $self->get_package_list ();
+#
+# DESCRIPTION
+#   This method returns a list of package names associated with this source
+#   file. The list begins with the top level container package to the
+#   sub-package name of the current source file.
+# ------------------------------------------------------------------------------
+
+sub get_package_list {
+  my $self = shift;
+
+  my @pknames = ();
+
+  my @packages = split /__/, $self->srcpackage->name;
+  push @packages, $self->root;
+
+  for my $i (0 .. $#packages) {
+    push @pknames, join ('__', (@packages[0 .. $i]));
+  }
+
+  return @pknames;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $pckcfg = $srcfile->pckcfg ();
+#   $srcfile->pckcfg ($pckcfg);
+#
+# DESCRIPTION
+#   This method returns the name of the flag to indicate whether this source
+#   file is modified by a package level configuration file. If an argument is
+#   specified, the flag is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub pckcfg {
+  my $self = shift;
+
+  if (@_) {
+    $self->{PCKCFG} = $_[0];
+  }
+
+  return $self->{PCKCFG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = $srcfile->scan ();
+#   $srcfile->scan ($flag);
+#
+# DESCRIPTION
+#   This method returns the "scan" flag that determines whether the source
+#   file needs to be scanned for dependency. If an argument is specified, the
+#   flag is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub scan {
+  my $self = shift;
+
+  if (@_) {
+    $self->{SCAN} = $_[0];
+  }
+
+  return $self->{SCAN};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $type = $srcfile->type;
+#   $srcfile->type ($type);
+#
+# DESCRIPTION
+#   This method returns the type flag of the source file. If an argument is
+#   specified, the flag is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub type {
+  my $self = shift;
+
+  if (@_) {
+    $self->{TYPE} = shift;
+  }
+
+  return $self->{TYPE};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = $srcfile->is_type ($type1[, $type2, ...]);
+#
+# DESCRIPTION
+#   This method returns true if current file is a known type matching all the
+#   arguments.
+# ------------------------------------------------------------------------------
+
+sub is_type {
+  my $self    = shift;
+  my @intypes = @_;
+  my $rc      = 0;
+
+  if ($self->{TYPE}) {
+    my @types = split /::/, $self->{TYPE};
+
+    for my $intype (@intypes) {
+      $rc = grep {uc $_ eq uc $intype} @types;
+      last unless $rc;
+    }
+
+  }
+
+  return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = $srcfile->is_type_or ($type1[, $type2, ...]);
+#
+# DESCRIPTION
+#   This method returns true if current file is a known type matching any of
+#   the arguments.
+# ------------------------------------------------------------------------------
+
+sub is_type_or {
+  my $self    = shift;
+  my @intypes = @_;
+  my $rc      = 0;
+
+  if ($self->{TYPE}) {
+    my @types = split /::/, $self->{TYPE};
+
+    for my $intype (@intypes) {
+      $rc = grep {uc $_ eq uc $intype} @types;
+      last if $rc;
+    }
+
+  }
+
+  return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $lang = $srcfile->lang ();
+#
+# DESCRIPTION
+#   This method returns the language name of the source file if it contains
+#   compilable source of a supported language.
+# ------------------------------------------------------------------------------
+
+sub lang {
+  my $self = shift;
+
+  if ((not $self->{LANG}) and $self->is_type ('SOURCE')) {
+    my %src_tool = %{ $self->config->setting ('SRC_TOOL') };
+
+    for my $key (keys %src_tool) {
+      if ($self->is_type ($key)) {
+        $self->{LANG} = $key;
+        last;
+      }
+    }
+  }
+
+  return $self->{LANG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $srcfile->determine_type;
+#
+# DESCRIPTION
+#   This method determines whether the source file is a type known to the
+#   build system. If so, it sets the "type" flag.
+# ------------------------------------------------------------------------------
+
+sub determine_type {
+  my $self = shift;
+
+  if (not $self->{TYPE}) {
+    # Do not set a type if the file name matches the "ignore" list
+    my @ignore = split /,/, $self->config->setting ('INFILE_IGNORE');
+
+    for (@ignore) {
+      return if $self->base eq $_;
+    }
+  }
+
+  if (not $self->{TYPE}) {
+    # Determine file type by comparing its extension with supported ones
+    my %known_ext = %{ $self->config->setting ('INFILE_EXT') };
+    my $ext       = $self->ext ? substr ($self->ext, 1) : 0;
+    $self->{TYPE} = $known_ext{$ext} if $ext and exists $known_ext{$ext};
+  }
+
+  if (not $self->{TYPE}) {
+    # Determine file type by comparing its name with known patterns
+    my %known_pat = %{ $self->config->setting ('INFILE_PAT') };
+    for my $pat (keys %known_pat) {
+      if ($self->base =~ /$pat/) {
+        $self->{TYPE} = $known_pat{$pat};
+        last;
+      }
+    }
+  }
+
+  if (-s $self->{SRC} and -T $self->{SRC} and not $self->{TYPE}) {
+    # Determine file type by inspecting its first line (text file only)
+    if (open SRC, '<', $self->{SRC}) {
+      my $line = <SRC>;
+      close SRC;
+
+      my %known_txt = %{ $self->config->setting ('INFILE_TXT') };
+      for my $txt (keys %known_txt) {
+        if ($line =~ /^#!.*$txt/) {
+          $self->{TYPE} = $known_txt{$txt};
+          last;
+        }
+      }
+    }
+  }
+
+  if ($self->is_type_or (qw/FORTRAN FPP/)) {
+    # Determine whether source file is a main Fortran program or module
+    if (open SRC, '<', $self->{SRC}) {
+      while (my $line = <SRC>) {
+        if ($line =~ /^\s*(PROGRAM|MODULE)\b/i) {
+          $self->{TYPE} = $self->{TYPE} . '::' . uc ($1);
+          last;
+
+        } elsif ($line =~ /^\s*BLOCK\s*DATA\b/i) {
+          $self->{TYPE} = $self->{TYPE} . '::' . 'BLOCKDATA';
+          last;
+        }
+      }
+      close SRC;
+    }
+
+  } elsif ($self->is_type (qw/C/)) {
+    # Determine whether source file is a main C program
+    if (open SRC, '<', $self->{SRC}) {
+      while (my $line = <SRC>) {
+        next unless $line =~ /int\s*main\s*\(/i;
+        $self->{TYPE} = $self->{TYPE} . '::PROGRAM';
+        last;
+      }
+      close SRC;
+    }
+  }
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @pp_src = @{ $srcfile->pre_process () };
+#
+# DESCRIPTION
+#   This method invokes the pre-processor on the source file. It returns a
+#   reference to an array containing the lines of the pre-processed source if
+#   the pre-processor command succeeded.
+# ------------------------------------------------------------------------------
+
+sub pre_process {
+  my $self = shift;
+
+  # Support only Fortran and C source files
+  return unless $self->is_type_or (qw/FPP C/);
+
+  # List of include directories
+  my @inc = @{ $self->config->setting (qw/PATH INC/) };
+
+  # Build the pre-processor command according to file type
+  my $name    = $self->is_type ('FPP') ? 'FPP' : 'CPP';
+  my %tool    = %{ $self->config->setting ('TOOL') };
+
+  # The pre-processor command and its options
+  my @command = ($tool{$name});
+  my @ppflags = split /\s+/, $self->select_tool ($name . 'FLAGS');
+
+  # List of defined macros, add "-D" in front of each macro
+  my @ppkeys  = split /\s+/, $self->select_tool ($name . 'KEYS');
+  @ppkeys     = map {($tool{$name . '_DEFINE' }. $_)} @ppkeys;
+
+  # Add "-I" in front of each include directories
+  @inc        = map {($tool{$name . '_INCLUDE'}. $_)} @inc;
+
+  push @command, (@ppflags, @ppkeys, @inc, $self->base);
+
+  my $verbose = $self->config->verbose;
+  my $cwd     = cwd;
+
+  # Change to container directory of source file
+  print 'cd ', $self->dir, "\n" if $verbose > 1;
+  chdir $self->dir;
+
+  # Execute the command, getting the output lines
+  my @outlines = &run_command (
+    \@command, METHOD => 'qx', PRINT => $verbose > 1, TIME => $verbose > 2,
+  );
+
+  # Change back to original directory
+  print 'cd ', $cwd, "\n" if $self->config->verbose > 1;
+  chdir $cwd;
+
+  return \@outlines;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @interface_block = @{ $srcfile->gen_interface () };
+#
+# DESCRIPTION
+#   This method invokes the Fortran 9x interface block generator to generate
+#   an interface block for the current source file. It returns a reference to
+#   an array containing the lines of the interface block.
+# ------------------------------------------------------------------------------
+
+sub gen_interface {
+  my $self = shift;
+
+  my $generator = $self->select_tool ('GENINTERFACE');
+
+  my $src      = $self->{PPSRC} ? $self->{PPSRC} : $self->{SRC};
+  my @outlines = ();
+
+  if ($generator eq 'f90aib') {
+    # Use F90AIB
+
+    # Open pipeline to interface file generator and read its output
+    my $devnull = File::Spec->devnull;
+    my $command = $generator;
+    $command   .= " <'" . $src . "'" . " 2>'" . $devnull . "'";
+    my $croak   = $command . ' failed';
+
+    print timestamp_command ($command, 'Start') if $self->config->verbose > 2;
+    open COMMAND, '-|', $command or croak $croak, ' (', $!, '), abort';
+    @outlines = readline 'COMMAND';
+    close COMMAND or croak $croak, ' (', $?, '), abort';
+    print timestamp_command ($command, 'End  ') if $self->config->verbose > 2;
+
+  } elsif ($generator eq 'ECMWF') {
+    # Use ECMWF interface generator
+  
+    # Read source file into an array
+    open FILE, '<', $src or croak 'Cannot open "', $src, '" (', $!, '), abort';
+    my @src_lines = <FILE>;
+    close FILE;
+  
+    # Process standalone subroutines and functions only
+    if (not grep /^\s*(?:program|module)\b/i, @src_lines) {
+      print timestamp_command ('Analyse: ' . $self->src, 'Start')
+        if $self->config->verbose > 2;
+
+      my @statements = ();
+      my %prog_info  = ();
+  
+      # Set name of source file
+      &Ecmwf::Fortran90_stuff::fname ($src);
+  
+      # Parse lines in source
+      &Ecmwf::Fortran90_stuff::setup_parse ();
+
+      # Expand continuation lines in source
+      &Ecmwf::Fortran90_stuff::expcont (\@src_lines, \@statements);
+  
+      # Analyse statements in source
+      $Ecmwf::Fortran90_stuff::study_called = 0;
+      &Ecmwf::Fortran90_stuff::study (\@statements, \%prog_info);
+  
+      # Source code is not a module
+      if (not $prog_info{is_module}) {
+        my @interface_block = ();
+        my @line_hash       = ();
+  
+        # Create an interface block for the program unit
+        &Ecmwf::Fortran90_stuff::create_interface_block (
+          \@statements,
+          \@interface_block,
+        );
+
+        # Put continuation lines back
+        &Ecmwf::Fortran90_stuff::cont_lines (
+          \@interface_block,
+          \@outlines,
+          \@line_hash,
+        );
+      }
+
+      print timestamp_command ('Analyse: ' . $self->src, 'End')
+        if $self->config->verbose > 2;
+    }
+
+  } elsif (uc ($generator) eq 'NONE') {
+    print $self->root, ': interface generation is switched off', "\n"
+      if $self->config->verbose > 2;
+
+  } else {
+    e_report 'Error: Unknown Fortran 9x interface generator: ', $generator, '.';
+  }
+
+  return \@outlines;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $tool = $self->select_tool ($name);
+#
+# DESCRIPTION
+#   This method selects the correct "tool" for the current source file by
+#   following the name of its container package. The argument $name must be
+#   the generic name of the "tool" to be selected. The method returns the
+#   value of the selected tool.
+# ------------------------------------------------------------------------------
+
+sub select_tool {
+  my $self  = shift;
+  my $name  = shift;
+
+  return undef unless $name;
+
+  my @pknames = $self->get_package_list ();
+
+  my %tool    = %{ $self->config->setting ('TOOL') };
+
+  for my $pkname (reverse @pknames) {
+    my $cur_name = join '__', ($name, $pkname);
+    return $tool{$cur_name} if exists $tool{$cur_name};
+  }
+
+  return exists $tool{$name} ? $tool{$name} : '';
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rc = $srcfile->scan_dependency ();
+#   $rc = $srcfile->scan_dependency (HEADER_ONLY => 1);
+#
+# DESCRIPTION
+#   This method scans the source file for dependencies. If no argument is
+#   specified, the method scans the pre-processed source file if it exists.
+#   Otherwise, the original source file is scanned. If HEADER_ONLY is
+#   specified, only pre-processing header dependencies are scanned from the
+#   source file. (The HEADER_ONLY flag should only be specified if "ppsrc" is
+#   not already specified.) This method returns the number of 1 on success.
+# ------------------------------------------------------------------------------
+
+sub scan_dependency {
+  my $self = shift;
+  my %args = @_;
+
+  my $header_only = exists $args{HEADER_ONLY} ? $args{HEADER_ONLY} : 0;
+
+  return 0 unless $self->{SCAN};
+  return 0 unless $self->{TYPE};
+
+  my $src = $self->{PPSRC} ? $self->{PPSRC} : $self->{SRC};
+  return 0 unless $src;
+
+  # Determine what dependencies are supported by this known type
+  my %types = $header_only
+              ? %{ $self->config->setting ('PP_DEP_TYPE') }
+              : %{ $self->config->setting ('DEP_TYPE') };
+
+  # List of excluded dependencies
+  my %excl_dep = %{ $self->config->setting ('EXCL_DEP') };
+
+  # Package list
+  my @pknames = $self->get_package_list ();
+
+  my @depends = ();
+  for my $key (keys %types) {
+    # Check if current file is a type of file requiring dependency scan
+    next unless $self->is_type ($key);
+    
+    # Get list of dependency type for this file
+    DEPEND: for my $depend ((split /::/, $types{$key})) {
+      # Ignore a dependency type if the dependency is in the exclude list
+      if (exists $excl_dep{$depend}) {
+        # Global exclude
+        next DEPEND if exists $excl_dep{$depend}{''};
+
+        # Sub-package exclude
+        for my $pkname (@pknames) {
+          next DEPEND if exists $excl_dep{$depend}{$pkname};
+        }
+      }
+
+      # Add to dependency list for current file
+      push @depends, $depend;
+    }
+  }
+
+  # Scan dependencies, if necessary ...
+  if (@depends) {
+    # Print diagnostic
+    print timestamp_command ('scan dependency in file: ' . $src, 'Start')
+      if $self->config->verbose > 2;
+
+    open FILE, '<', $src or croak 'Cannot open "', $src, '" (', $!, ')';
+    my @lines = readline 'FILE';
+    close FILE;
+
+    # List of dependency patterns
+    my %dep_pattern = %{ $self->config->setting ('DEP_PATTERN') };
+
+    LINE: for my $line (@lines) {
+      # Ignore empty lines
+      next LINE if $line =~ /^\s*$/;
+
+      # Fortran source, also scan for program unit name
+      if (! $header_only and ! $self->progname) {
+        if ($self->is_type ('SOURCE') and $self->is_type_or (qw/FPP FORTRAN/)) {
+          my $pfx_pttn = '(?:(?:ELEMENTAL|(?:RECURSIVE(?:\s+PURE)?|' .
+                         'PURE(?:\s+RECURSIVE)?))\s+)?';
+          my $spc_pttn = '(?:(?:CHARACTER|COMPLEX|DOUBLE\s*PRECISION|INTEGER|' .
+                         'LOGICAL|REAL|TYPE)(?:\s*\(.+\)|\s*\*\d+\s*)??\s+)?';
+
+          if ($line =~ /^\s*PROGRAM\s+(\w+)/i) {
+            # Matches the beginning of a named main program
+            $self->progname (lc $1);
+            next LINE;
+
+          } elsif ($line =~ /^\s*MODULE\s+(\w+)/i) {
+            my $keyword = $1;
+
+            if (uc ($keyword) ne 'PROCEDURE') {
+              # Matches the beginning of a module
+              $self->progname (lc $keyword);
+              next LINE;
+            }
+
+          } elsif ($line =~ /^\s*BLOCK\s*DATA\s+(\w+)/i) {
+            # Matches the beginning of a named block data program unit
+            $self->progname (lc $1);
+            next LINE;
+
+          } elsif ($line =~ /^\s*$pfx_pttn SUBROUTINE\s+(\w+)/ix) {
+            # Matches the beginning of a subroutine
+            $self->progname (lc $1);
+            next LINE;
+
+          } elsif ($line =~ /^\s*$pfx_pttn $spc_pttn FUNCTION\s+(\w+)/ix) {
+            # Matches the beginning of a function
+            $self->progname (lc $1);
+            next LINE;
+          }
+        }
+      }
+
+      # Scan known dependencies
+      for my $depend (@depends) {
+        # Check if a pattern exists for the current dependency
+        next unless exists $dep_pattern{$depend};
+
+        # Attempt to match the pattern
+        my $pattern = $dep_pattern{$depend};
+
+        if ($line =~ /$pattern/i) {
+          my $match = $1;
+
+          # $match may contain multiple items delimited by space
+          NAME: for my $name (split /\s+/, $match) {
+            # Skip dependency if it is in the exclusion list
+            my $key = uc ($depend . '::' . $name);
+
+            if (exists $excl_dep{$key}) {
+              # Exclude this dependency, in the global list
+              next NAME if exists $excl_dep{$key}{''};
+
+              # Exclude this dependency, current sub-package
+              for my $pkname (@pknames) {
+                next NAME if exists $excl_dep{$key}{$pkname};
+              }
+            }
+
+            # Add this dependency to the list
+            $self->add_dep ($name, $depend);
+          }
+
+          next LINE;
+        }
+      }
+    }
+
+    # Diagnostic messages
+    if ($self->config->verbose > 2) {
+      my $base = $self->ppsrc ? $self->ppbase : $self->base;
+
+      print $self->srcpackage->name, ': ', $base;
+      print ': scanned ', scalar (@lines), ' lines for ';
+      print 'header ' if $header_only;
+      print 'dependencies: ', scalar (keys %{ $self->{DEP} }), "\n";
+      print timestamp_command ('scan dependency in file: ' . $src, 'End');
+    }
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   %rules = $srcfile->required_rules ();
+#
+# DESCRIPTION
+#   This method returns a hash in the following format:
+#     %rules = (
+#       target => {ACTION => action, DEP => [dependencies], ...},
+#       ...    => {...},
+#     );
+#   where the 1st rank keys are the available targets for building this source
+#   file, the second rank keys are ACTION and DEP. The value of ACTION is the
+#   action for building the target, which can be "COMPILE", "LOAD", "TOUCH",
+#   "CP" or "AR". The value of DEP is a refernce to an array containing a list
+#   of dependencies suitable for insertion into the Makefile.
+# ------------------------------------------------------------------------------
+
+sub required_rules {
+  my $self = shift;
+
+  if (not keys %{ $self->{RULES} }) {
+    my %outfile_ext = %{ $self->config->setting ('OUTFILE_EXT') };
+
+    if ($self->is_type (qw/SOURCE/)) {
+      # Source file
+      # ------------------------------------------------------------------------
+      # Determine the whether the language of the source file is supported
+      my %src_tool = %{ $self->config->setting ('SRC_TOOL') };
+
+      return () unless $self->lang;
+
+      # Compile object
+      # ------------------------------------------------------------------------
+      if ($self->objbase) {
+        # Depends on the source file
+        my @dep = ($self->_makerule_srcfile);
+
+        # Depends on the compiler flags flags-file
+        my @flags;
+        push @flags, ('FLAGS' )
+          if $self->flagsbase ('FLAGS' );
+        push @flags, ('PPKEYS')
+          if $self->flagsbase ('PPKEYS') and not $self->ppsrc;
+
+        push @dep, $self->flagsbase ($_) for (@flags);
+
+        # Source file dependencies
+        for my $name (sort keys %{ $self->{DEP} }) {
+          # A Fortran 9X module, lower case object file name
+          if ($self->{DEP}{$name} eq 'USE') {
+            (my $root = $name) =~ s/\.\w+$//;
+            push @dep, lc ($root) . $outfile_ext{OBJ};
+
+          # An include file
+          } elsif ($self->{DEP}{$name} =~ /^(?:INC|H|INTERFACE)$/) {
+            push @dep, $name;
+          }
+        }
+
+        $self->{RULES}{$self->objbase} = {ACTION => 'COMPILE', DEP => \@dep};
+
+        # Touch flags-files
+        # ----------------------------------------------------------------------
+        for my $flag (@flags) {
+          next unless $self->flagsbase ($flag);
+
+          $self->{RULES}{$self->flagsbase ($flag)} = {
+            ACTION => 'TOUCH',
+            DEP    => [
+              $self->srcpackage->flagsbase ($src_tool{$self->lang}{$flag}),
+            ],
+            DEST   => '$(FCM_FLAGSDIR)',
+          };
+        }
+      }
+
+      if ($self->exebase) {
+        # Link into an executable
+        # ----------------------------------------------------------------------
+        my @dep = ();
+        push @dep, $self->objbase               if $self->objbase;
+        push @dep, $self->flagsbase ('LD'     ) if $self->flagsbase ('LD'     );
+        push @dep, $self->flagsbase ('LDFLAGS') if $self->flagsbase ('LDFLAGS');
+
+        # Depends on BLOCKDATA program units, for Fortran programs
+        my %blockdata = %{ $self->config->setting ('BLOCKDATA') };
+        my @blkobj    = ();
+
+        if ($self->is_type_or (qw/FPP FORTRAN/) and keys %blockdata) {
+          # List of BLOCKDATA object files
+          if (exists $blockdata{$self->exebase}) {
+            @blkobj = keys (%{ $blockdata{$self->exebase} });
+
+          } elsif (exists $blockdata{''}) {
+            @blkobj = keys (%{ $blockdata{''} });
+          }
+
+          for my $name (@blkobj) {
+            (my $root = $name) =~ s/\.\w+$//;
+            $name = $root . $outfile_ext{OBJ};
+            push @dep, $root . $outfile_ext{DONE};
+          }
+        }
+
+        # Extra executable dependencies
+        my %exe_dep = %{ $self->config->setting ('EXE_DEP') };
+        if (keys %exe_dep) {
+          my @exe_deps;
+          if (exists $exe_dep{$self->exebase}) {
+            @exe_deps = keys (%{ $exe_dep{$self->exebase} });
+
+          } elsif (exists $exe_dep{''}) {
+            @exe_deps = keys (%{ $exe_dep{''} });
+          }
+
+          my $pattern = '\\' . $outfile_ext{OBJ} . '$';
+
+          for my $name (@exe_deps) {
+            if ($name =~ /$pattern/) {
+              # Extra dependency is an object
+              (my $root = $name) =~ s/\.\w+$//;
+              push @dep, $root . $outfile_ext{DONE};
+
+            } else {
+              # Extra dependency is a sub-package
+              my $var;
+              if ($self->config->setting ('FCM_PCK_OBJECTS', $name)) {
+                # sub-package name contains unusual characters
+                $var = $self->config->setting ('FCM_PCK_OBJECTS', $name);
+
+              } else {
+                # sub-package name contains normal characters
+                $var = $name ? join ('__', ('OBJECTS', $name)) : 'OBJECTS';
+              }
+
+              push @dep, '$(' . $var . ')';
+            }
+          }
+        }
+
+        # Source file dependencies
+        for my $name (sort keys %{ $self->{DEP} }) {
+          (my $root = $name) =~ s/\.\w+$//;
+
+          # Lowercase name for object dependency
+          $root = lc ($root) unless $self->{DEP}{$name} =~ /^(?:INC|H)$/;
+
+          # Select "done" file extension
+          if ($self->{DEP}{$name} =~ /^(?:INC|H)$/) {
+            push @dep, $name . $outfile_ext{IDONE};
+
+          } else {
+            push @dep, $root . $outfile_ext{DONE};
+          }
+        }
+
+        $self->{RULES}{$self->exebase} = {
+          ACTION => 'LOAD', DEP => \@dep, BLOCKDATA => \@blkobj,
+        };
+
+        # Touch Linker flags-file
+        # ----------------------------------------------------------------------
+        for my $flag (qw/LD LDFLAGS/) {
+          $self->{RULES}{$self->flagsbase ($flag)} = {
+            ACTION => 'TOUCH',
+            DEP    => [$self->srcpackage->flagsbase ($flag)],
+            DEST   => '$(FCM_FLAGSDIR)',
+          };
+        }
+
+      }
+
+      if ($self->donebase) {
+        # Touch done file
+        # ----------------------------------------------------------------------
+        my @dep = ($self->objbase);
+
+        for my $name (sort keys %{ $self->{DEP} }) {
+          (my $root = $name) =~ s/\.\w+$//;
+
+          # Lowercase name for object dependency
+          $root = lc ($root) unless $self->{DEP}{$name} =~ /^(?:INC|H)$/;
+
+          # Select "done" file extension
+          if ($self->{DEP}{$name} =~ /^(?:INC|H)$/) {
+            push @dep, $name . $outfile_ext{IDONE};
+
+          } else {
+            push @dep, $root . $outfile_ext{DONE};
+          }
+        }
+
+        $self->{RULES}{$self->donebase} = {
+          ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)',
+        };
+      }
+      
+      if ($self->interfacebase) {
+        # Interface target
+        # ----------------------------------------------------------------------
+        # Source file dependencies
+        my @dep = ();
+        for my $name (sort keys %{ $self->{DEP} }) {
+          # Depends on Fortran 9X modules
+          push @dep, lc ($name) . $outfile_ext{OBJ}
+            if $self->{DEP}{$name} eq 'USE';
+        }
+
+        $self->{RULES}{$self->interfacebase} = {DEP => \@dep};
+      }
+
+    } elsif ($self->is_type ('INCLUDE')) {
+      # Copy include target
+      # ------------------------------------------------------------------------
+      my @dep = ($self->_makerule_srcfile);
+
+      for my $name (sort keys %{ $self->{DEP} }) {
+        # A Fortran 9X module, lower case object file name
+        if ($self->{DEP}{$name} eq 'USE') {
+          (my $root = $name) =~ s/\.\w+$//;
+          push @dep, lc ($root) . $outfile_ext{OBJ};
+
+        # An include file
+        } elsif ($self->{DEP}{$name} =~ /^(?:INC|H|INTERFACE)$/) {
+          push @dep, $name;
+        }
+      }
+
+      $self->{RULES}{$self->base} = {
+        ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_INCDIR)',
+      };
+
+      # Touch IDONE file
+      # ------------------------------------------------------------------------
+      if ($self->donebase) {
+        my @dep = ($self->_makerule_srcfile);
+
+        for my $name (sort keys %{ $self->{DEP} }) {
+          (my $root = $name) =~ s/\.\w+$//;
+
+          # Lowercase name for object dependency
+          $root   = lc ($root) unless $self->{DEP}{$name} =~ /^(?:INC|H)$/;
+
+          # Select "done" file extension
+          if ($self->{DEP}{$name} =~ /^(?:INC|H)$/) {
+            push @dep, $name . $outfile_ext{IDONE};
+
+          } else {
+            push @dep, $root . $outfile_ext{DONE};
+          }
+        }
+
+        $self->{RULES}{$self->donebase} = {
+          ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)',
+        };
+      }
+
+    } elsif ($self->is_type_or (qw/EXE SCRIPT/)) {
+      # Copy executable file
+      # ------------------------------------------------------------------------
+      my @dep = ($self->_makerule_srcfile);
+
+      # Depends on dummy copy file, if file is an "always build type"
+      push @dep, $self->config->setting (qw/MISC CPDUMMY/)
+        if $self->is_type_or (
+          split (/,/, $self->config->setting ('ALWAYS_BUILD_TYPE'))
+        );
+
+      # Depends on other executable files
+      for my $name (sort keys %{ $self->{DEP} }) {
+        push @dep, $name if $self->{DEP}{$name} eq 'EXE';
+      }
+
+      $self->{RULES}{$self->base} = {
+        ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_BINDIR)',
+      };
+
+    } elsif ($self->is_type ('LIB')) {
+      # Archive object library
+      # ------------------------------------------------------------------------
+      my @dep;
+      for my $name (sort keys %{ $self->{DEP} }) {
+        next unless $self->{DEP}{$name} eq 'OBJ';
+
+        if ($name =~ /^\$\(\w+\)$/) {
+          # Dependency is a Makefile variable
+          push @dep, $name;
+
+        } else {
+          # Dependency is an object
+          (my $root = $name) =~ s/\.\w+$//;
+          push @dep, lc ($root) . $outfile_ext{OBJ};
+        }
+      }
+
+      $self->{RULES}{$self->base} = {ACTION => 'AR', DEP => \@dep};
+    }
+  }
+
+  return %{ $self->{RULES} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $string = $srcfile->write_makerules ();
+#
+# DESCRIPTION
+#   This method returns a string containing the "Make" rules for building the
+#   source file.
+# ------------------------------------------------------------------------------
+
+sub write_makerules {
+  my $self  = shift;
+  my $mk    = '';
+  my %rules = $self->required_rules;
+  my $nl    = " \\\n" . ' ' x 10;
+
+  for my $target (sort keys %rules) {
+    $mk .= $target . ':';
+    
+    for my $dep (@{ $rules{$target}{DEP} }) {
+      $mk .= $nl . $dep;
+    }
+
+    $mk .= "\n";
+
+    if (exists $rules{$target}{ACTION}) {
+      if ($rules{$target}{ACTION} eq 'COMPILE') {
+        if ($self->lang) {
+          $mk .= "\t" . 'fcm_internal compile:' . substr ($self->lang, 0, 1) .
+                 ' ' . $self->srcpackage->name . ' $< $@';
+          $mk .= ' 1' if ($self->flagsbase ('PPKEYS') and not $self->ppsrc);
+          $mk .= "\n";
+        }
+
+      } elsif ($rules{$target}{ACTION} eq 'LOAD') {
+        $mk .= "\t" . 'fcm_internal load ' . $self->srcpackage->name . ' $< $@';
+        $mk .= ' ' . join (' ', @{ $rules{$target}{BLOCKDATA} })
+          if @{ $rules{$target}{BLOCKDATA} };
+        $mk .= "\n";
+
+      } elsif ($rules{$target}{ACTION} eq 'TOUCH') {
+        $mk .= "\t" . 'touch ' . catfile ($rules{$target}{DEST}, '$@') . "\n";
+
+      } elsif ($rules{$target}{ACTION} eq 'CP') {
+        $mk .= "\t" . 'cp $< ' . $rules{$target}{DEST} . "\n";
+        $mk .= "\t" . 'chmod u+w ' . catfile ($rules{$target}{DEST}, '$@') . "\n";
+
+      } elsif ($rules{$target}{ACTION} eq 'AR') {
+        $mk .= "\t" . 'fcm_internal archive $@ $(^F)' . "\n";
+      }
+    }
+
+    $mk .= "\n";
+  }
+
+  return $mk;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $string = $srcfile->_makerule_srcfile ();
+#
+# DESCRIPTION
+#   This internal method returns a string containing the location of the
+#   source file relative to a package source path. This string will be
+#   suitable for use in a "Make" rule file for FCM.
+# ------------------------------------------------------------------------------
+
+sub _makerule_srcfile {
+  my $self = shift;
+
+  my $return;
+  my @searchpath;
+  my $label;
+  my $dir;
+  my $base;
+
+  if ($self->ppsrc) {
+    $return     = $self->ppsrc;
+    @searchpath = $self->srcpackage->ppsearchpath;
+    $label      = 'PPSRCDIR';
+    $dir        = $self->ppdir;
+    $base       = $self->ppbase;
+
+  } else {
+    $return     = $self->src;
+    @searchpath = $self->srcpackage->searchpath;
+    $label      = 'SRCDIR';
+    $dir        = $self->dir;
+    $base       = $self->base;
+  }
+
+  $return = catfile $dir, $base;
+
+  # Use variable for directory name
+  # if container package name contains word characters only
+  if ($self->srcpackage->name =~ /^\w+$/) {
+    for my $i (0 .. $#searchpath) {
+      if ($dir eq $searchpath[$i]) {
+        my $returndir = '$(' . $label . $i . '__' . $self->srcpackage->name .
+                        ')';
+        $return = catfile $returndir, $base;
+        last;
+      }
+    }
+  }
+
+  return $return;
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/SrcPackage.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/SrcPackage.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/SrcPackage.pm	(revision 7236)
@@ -0,0 +1,895 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Fcm::SrcPackage
+#
+# DESCRIPTION
+#   This is a class to process a source directory package. It uses the
+#   supplied inheritance hierarchy to obtain a list of source files of this
+#   package.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::SrcPackage;
+
+# Standard pragma
+use strict;
+use warnings;
+
+# Standard modules
+use Carp;
+use File::Spec::Functions;
+use File::Basename;
+use File::Path;
+
+# FCM component modules
+use Fcm::Util;
+use Fcm::SrcFile;
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $package = Fcm::SrcPackage->new (
+#     CONFIG     => $config,
+#     NAME       => $name,
+#     CURRENT    => $current,
+#     REQUIREPP  => $requirepp,
+#     NEWPP      => $newpp,
+#     SEARCHPATH => \@path,
+#   );
+#
+# DESCRIPTION
+#   This method constructs a new instance of the Fcm::SrcPackage class.
+#
+# ARGUMENTS
+#   CONFIG     - reference to a Fcm::Config instance
+#   NAME       - name of the source directory package
+#   CURRENT    - package declared in current build?
+#   REQUIREPP  - require pre-processing?
+#   NEWPP      - pre-process option has changed?
+#   SEARCHPATH - search path of files in the source package
+# ------------------------------------------------------------------------------
+
+sub new {
+  my $this  = shift;
+  my %args  = @_;
+  my $class = ref $this || $this;
+
+  my $self  = {
+    CONFIG     => exists $args{CONFIG}     ? $args{CONFIG}     : &main::cfg,
+    NAME       => exists $args{NAME}       ? $args{NAME}       : undef,
+    CURRENT    => exists $args{CURRENT}    ? $args{CURRENT}    : undef,
+    REQUIREPP  => exists $args{REQUIREPP}  ? $args{REQUIREPP}  : undef,
+    NEWPP      => exists $args{NEWPP}      ? $args{NEWPP}      : undef,
+    SEARCHPATH => exists $args{SEARCHPATH} ? $args{SEARCHPATH} : [],
+
+    # Reference to Fcm::CfgFile, source package configuration file
+    CFG       => undef,
+
+    # References to Fcm::SrcFile, list of source files
+    SRCFILE   => [],
+  };
+
+  bless $self, $class;
+  return $self;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $config = $package->config;
+#
+# DESCRIPTION
+#   This method returns a reference to the Fcm::Config instance.
+# ------------------------------------------------------------------------------
+
+sub config {
+  my $self = shift;
+
+  return $self->{CONFIG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $name = $package->name;
+#   $package->name ($name);
+#
+# DESCRIPTION
+#   This method returns the name of this package. If an argument is specified,
+#   the name is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub name {
+  my $self = shift;
+
+  if (@_) {
+    $self->{NAME} = shift;
+  }
+
+  return $self->{NAME};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = $package->current;
+#   $package->current ($flag);
+#
+# DESCRIPTION
+#   This method returns the "current" flag of the source package. If an
+#   argument is specified, the flag is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub current {
+  my $self = shift;
+
+  if (@_) {
+    $self->{CURRENT} = shift;
+  }
+
+  return $self->{CURRENT};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = $package->requirepp;
+#   $package->requirepp ($flag);
+#
+# DESCRIPTION
+#   This method returns the "require PP" flag of the source package. If an
+#   argument is specified, the flag is set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub requirepp {
+  my $self = shift;
+
+  if (@_) {
+    $self->{REQUIREPP} = shift;
+  }
+
+  return $self->{REQUIREPP};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = $package->newpp;
+#   $package->newpp ($flag);
+#
+# DESCRIPTION
+#   This method returns the flag to denote whether pre-processor option for
+#   this source package has changed. If an argument is specified, the flag is
+#   set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub newpp {
+  my $self = shift;
+
+  if (@_) {
+    $self->{NEWPP} = shift;
+  }
+
+  return $self->{NEWPP};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $cfgfile = $package->cfg;
+#   $package->cfg ($cfgfile);
+#
+# DESCRIPTION
+#   This method returns a reference to a Fcm::CfgFile instance for the source
+#   package configuration file. If an argument is specified, the reference is
+#   set to the value of the argument.
+# ------------------------------------------------------------------------------
+
+sub cfg {
+  my $self = shift;
+
+  if (@_) {
+    $self->{CFG} = $_[0];
+  }
+
+  return $self->{CFG};
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @path = $package->searchpath;
+#   $package->searchpath (@path);
+#
+# DESCRIPTION
+#   This method returns the source file search path associated with this
+#   source package in the current build. If arguments are specified, the
+#   search path is replaced by the array in the argument list.
+# ------------------------------------------------------------------------------
+
+sub searchpath {
+  my $self = shift;
+
+  @{ $self->{SEARCHPATH} } = @_ if @_; 
+
+  return @{ $self->{SEARCHPATH} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @path = $package->ppsearchpath;
+#
+# DESCRIPTION
+#   This method returns the pre-processed source file search path associated
+#   with this source package in the current build.
+# ------------------------------------------------------------------------------
+
+sub ppsearchpath {
+  my $self = shift;
+
+  my @path = ();
+  my @name = split /__/, $self->name;
+
+  for my $ppsrcdir (@{ $self->config->setting (qw/PATH PPSRC/) }) {
+    push @path, catfile ($ppsrcdir, @name);
+  }
+
+  return @path;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $base = $package->flagsbase ($flag);
+#
+# DESCRIPTION
+#   Returns the base name of a flags-file, determined by $flag.
+# ------------------------------------------------------------------------------
+
+sub flagsbase {
+  my ($self, $flag) = @_;
+
+  return join ('__', ($flag, $self->name)) .
+         $self->config->setting (qw/OUTFILE_EXT FLAGS/);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @srcfile = $package->srcfile;
+#
+# DESCRIPTION
+#   This method returns a list of references to Fcm::SrcFile instances
+#   associated with this package.
+# ------------------------------------------------------------------------------
+
+sub srcfile {
+  my $self = shift;
+
+  return @{ $self->{SRCFILE} };
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $package->update_file_info ();
+#
+# DESCRIPTION
+#   This method updates the source file information of this package. Please
+#   note that information is only updated if the cache file for this package
+#   does not exist. For a package declared in the current build, the
+#   information is also updated if the cache file is out of date.
+# ------------------------------------------------------------------------------
+
+sub update_file_info {
+  my $self      = shift;
+
+  # Check if the cache file exists and up to date
+  my @cachepath = @{ $self->config->setting (qw/PATH CACHE/) };
+  my $cachefile = find_file_in_path ($self->_cache_basename, \@cachepath);
+
+  my $uptodate  = $cachefile ? 1 : 0;
+  if ($uptodate and $self->{CURRENT}) {
+    # Is cache file up to date compared with directory?
+    $uptodate = (stat $cachefile) [9] > (stat $self->{SEARCHPATH}[0]) [9];
+
+    # Is cache file up to date compared with each file?
+    if ($uptodate) {
+      my $dir = $self->{SEARCHPATH}[0];
+
+      if (opendir DIR, $dir) {
+        my @files = map {catfile $dir, $_} grep {!/^\.\.?/} readdir 'DIR';
+        closedir DIR;
+        $uptodate = (grep {(stat $cachefile) [9] > (stat) [9]} @files) ? 1 : 0;
+      }
+    }
+  }
+
+  # Read package source file information if it appears to be up to date
+  $uptodate = $self->_read_file_list_cache ($cachefile) if ($uptodate);
+
+  # Update package source file information if necessary
+  if (not $uptodate) {
+    # Get list of files by searching through the search path
+    my @files = ();
+    for my $dir (@{ $self->{SEARCHPATH} }) {
+      opendir DIR, $dir;
+      while (my $base = readdir 'DIR') {
+        next if $base =~ /^\./;
+
+        my $file = catfile $dir, $base;
+        next if -d $file;
+
+        push @files, $file unless grep {basename ($_) eq $base} @files;
+      }
+      closedir DIR;
+    }
+
+    # Declare new instances of source file objects
+    my @srcfile = ();
+    for my $file (@files) {
+      if (basename ($file) eq $self->config->setting (qw/CFG_NAME SRCPACKAGE/)) {
+        $self->{CFG} = Fcm::CfgFile->new (CONFIG => $self->config, SRC => $file);
+
+      } else {
+        my $srcfile = Fcm::SrcFile->new (
+          CONFIG     => $self->config,
+          SRC        => $file,
+          SRCPACKAGE => $self,
+        );
+
+        # Determine source file types
+        $srcfile->determine_type;
+
+        # Record files of known types
+        push @srcfile, $srcfile;
+      }
+    }
+
+    # Set each SRCFILE to reference the source file instances
+    $self->{SRCFILE} = \@srcfile;
+
+    # Decipher configuration file if necessary
+    $self->_decipher_cfg if $self->cfg;
+
+    # Write to a new cache file
+    $self->_update_file_list_cache ();
+
+    # Source package info updated. Make sure the "current" flag is set to true
+    $self->current (1);
+  }
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $up_to_date = $self->_read_file_list_cache ($file);
+#
+# DESCRIPTION
+#   This internal method reads the cache $file of this package and assigns the
+#   information to the SRCFILE list. It returns true if the cache appears to
+#   be up to date.
+# ------------------------------------------------------------------------------
+
+sub _read_file_list_cache {
+  my $self = shift;
+  my $file = shift;
+
+  my $cfg = Fcm::CfgFile->new (CONFIG => $self->config, SRC => $file);
+
+  # Read from config file
+  $cfg->read_cfg;
+  my @lines = $cfg->lines;
+
+  my %filetype = ();
+  my $uptodate = 1;
+  for my $line (@lines) {
+    next unless $line->{LABEL};
+
+    # On package declared in the current build, check that file is not deleted
+    if (not -f $line->{LABEL}) {
+      $uptodate = 0;
+      last;
+    }
+
+    $filetype{$line->{LABEL}} = $line->{VALUE};
+  }
+
+  # Assign to SRCFILE list if cache file is up to date
+  if ($uptodate) {
+    my @srcfiles = ();
+
+    for my $file (sort keys %filetype) {
+      if ($filetype{$file} eq 'SRCPACKAGECFG') {
+        $self->{CFG} = Fcm::CfgFile->new (CONFIG => $self->config, SRC => $file);
+
+      } else {
+        my $srcfile = Fcm::SrcFile->new (
+          CONFIG     => $self->config,
+          SRC        => $file,
+          TYPE       => $filetype{$file},
+          SRCPACKAGE => $self,
+        );
+
+        push @srcfiles, $srcfile;
+      }
+    }
+
+    $self->{SRCFILE} = [@srcfiles];
+
+    $self->_decipher_cfg if $self->cfg;
+  }
+
+  return $uptodate;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_update_file_list_cache (\@cachepath);
+#
+# DESCRIPTION
+#   This internal method updates the cache file of this package by writing
+#   current SRCFILE information to it. The argument @cachepath must be the
+#   search path of the build cache directory.
+# ------------------------------------------------------------------------------
+
+sub _update_file_list_cache {
+  my $self      = shift;
+  my @cachepath = @{ $self->config->setting (qw/PATH CACHE/) };
+
+  my $cfg = Fcm::CfgFile->new (CONFIG => $self->config);
+
+  if ($self->{CFG}) {
+    $cfg->add_line (LABEL => $self->cfg->src, VALUE => 'SRCPACKAGECFG')
+  }
+
+  for my $file (@{ $self->{SRCFILE} }) {
+    $cfg->add_line (LABEL => $file->src, VALUE => $file->type);
+  }
+
+  my $cachefile = catfile $cachepath[0], $self->_cache_basename;
+  $cfg->print_cfg ($cachefile);
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $basename = $self->_cache_basename ($type);
+#
+# DESCRIPTION
+#   This internal method returns the basename of a cache file for this
+#   package. If no argument is specified, it returns the package file list
+#   cache name. Otherwise, it returns the package file dependency cache name.
+# ------------------------------------------------------------------------------
+
+sub _cache_basename {
+  my $self = shift;
+  my $type = $_[0] ? $_[0] : 'PCKFILE';
+
+  return $self->{NAME} . $self->config->setting ('CACHE', $type);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $self->_decipher_cfg ();
+#
+# DESCRIPTION
+#   This internal method deciphers the CFG file associated with this source
+#   package.
+# ------------------------------------------------------------------------------
+
+sub _decipher_cfg {
+  my $self = shift;
+
+  $self->cfg->read_cfg;
+  my @lines = $self->cfg->lines;
+
+  my %cfg_label = %{ $self->config->setting ('CFG_LABEL') };
+
+  LINE: for my $line (@lines) {
+    my $label = $line->{LABEL};
+    my $value = $line->{VALUE};
+
+    next unless $label;
+    next if uc $label eq $cfg_label{CFGFILE}{TYPE};
+    next if uc $label eq $cfg_label{CFGFILE}{VERSION};
+
+    my ($prefix, $name) = split /::/, $label;
+
+    # Get name of file from the package cfg
+    my $srcfile;
+    if ($name) {
+      ($srcfile) = grep {$_->base eq $name} @{ $self->{SRCFILE} };
+
+      # Create new instance of Fcm::SrcFile if not already in package
+      if (not $srcfile) {
+        my $src    = find_file_in_path ($name, $self->{SEARCHPATH});
+        my $target = $name unless $src;
+
+        $srcfile   = Fcm::SrcFile->new (
+          CONFIG     => $self->config,
+          SRCPACKAGE => $self,
+          SRC        => $src ? $src : $name,
+          TARGET     => $target,
+          PCKCFG     => 1,
+        );
+        push @{ $self->{SRCFILE} }, $srcfile;
+
+      } else {
+        $srcfile->pckcfg (1);
+      }
+
+    } else {
+      w_report 'Warning: ', $line->{SRC}, ': LINE ', $line->{NUMBER},
+               ': label "', $label, '" not recognised.';
+      next LINE;
+    }
+
+    $prefix = uc $prefix;
+    if ($prefix eq $cfg_label{TYPE}) {
+      # Type label of source file
+      $srcfile->type (uc $value);
+      $srcfile->scan (0) if $srcfile->is_type (qw/BINARY LIB/);
+      next LINE;
+
+    } elsif ($prefix eq $cfg_label{SCAN}) {
+      # Scan original file for dependency?
+      $srcfile->scan ($value);
+      next LINE;
+
+    } elsif ($prefix eq $cfg_label{TARGET}) {
+      # Name of build target for this source file
+      $srcfile->exebase ($value);
+      next LINE;
+
+    } elsif ($prefix eq $cfg_label{INTNAME}) {
+      # Program unit name of this source file
+      $srcfile->progname ($value);
+      next LINE;
+
+    } elsif ($prefix eq $cfg_label{DEP}) {
+      # Dependency of this source file
+      my ($type, $target) = split /::/, $value;
+      $srcfile->add_dep ($target, uc $type);
+      next LINE;
+
+    } else {
+      w_report 'Warning: ', $line->{SRC}, ': LINE ', $line->{NUMBER},
+               ': label "', $label, '" not recognised.';
+      next LINE;
+    }
+  }
+
+  return 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $package->scan_dependency ();
+#   $package->scan_dependency (HEADER_ONLY => 1);
+#
+# DESCRIPTION
+#   This method scans the dependency in each source file in this source
+#   package and updates the package dependency cache. If HEADER_ONLY is
+#   specified, it performs dependency scan for pre-processor headers only if
+#   this source package requires pre-processing.
+# ------------------------------------------------------------------------------
+
+sub scan_dependency {
+  my $self = shift;
+  my %args = @_;
+
+  # Search for include header dependencies only
+  my $header_only = exists $args{HEADER_ONLY} ? $args{HEADER_ONLY} : 0;
+
+  # Get list of source files
+  # If header dependencies only, only consider FPP, C and CPP files
+  my @srcfiles = $header_only
+                 ? grep {$_->is_type_or (qw/FPP C CPP/)} $self->srcfile
+                 : grep {$_->type} $self->srcfile;
+  return unless @srcfiles;
+
+  # Location of the cache
+  my @cachepath = @{ $self->config->setting (qw/PATH CACHE/) };
+  my $cachebase = $header_only
+                  ? $self->_cache_basename ('PCKPPDEPEND')
+                  : $self->_cache_basename ('PCKDEPEND');
+  my $cachefile = find_file_in_path ($cachebase, \@cachepath);
+
+  # Obtain old dependency information from cache file if it exists
+  my %dep     = ();
+  my %intname = ();
+
+  if ($cachefile) {
+    # Read the cache
+    my $cfg = Fcm::CfgFile->new (CONFIG => $self->config, SRC => $cachefile);
+    $cfg->read_cfg;
+    my @lines = $cfg->lines;
+
+    # Get list of source file base names
+    my %srcfilebase;
+    for (@srcfiles) {
+      my $base = $_->ppsrc ? $_->ppbase : $_->base;
+      $srcfilebase{$base} = 1;
+    }
+
+    for my $line (@lines) {
+      next unless $line->{LABEL};
+
+      # Label is either INTNAME or a dependency type name
+      # For INTNAME, value is the program unit name
+      # Otherwise, value is file::dependency
+      my $type = $line->{LABEL};
+      (my $file, my $depend) = split /::/, $line->{VALUE};
+
+      # Make sure $file exists in the list of source file base names
+      next unless exists $srcfilebase{$file};
+
+      if ($type eq 'INTNAME') {
+        $intname{$file} = $depend;
+
+      } else {
+        $dep{$file}{$depend} = $type;
+      }
+    }
+  }
+
+  # If a source file is newer than the cache file, re-scan dependency for that
+  # source file.
+  my $uptodate        = $cachefile ? 1 : 0;
+  my $cachefile_mtime = $cachefile ? (stat $cachefile) [9] : undef;
+  my $count           = 0;
+
+  for my $srcfile (@srcfiles) {
+    # Check modified time of source file
+    my $srcfile_mtime = $srcfile->mtime;
+
+    # If a package config file exists and it affects the source file,
+    # compare its timestamp with that of the source file
+    if ($srcfile->pckcfg) {
+      $srcfile_mtime = $self->cfg->mtime if not defined $srcfile_mtime;
+      $srcfile_mtime = ($self->cfg->mtime > $srcfile_mtime) ? $self->cfg->mtime
+                                                            : $srcfile_mtime;
+    }
+
+    # For files requiring PP, must re-scan if PP option has changed
+    my $rescan = ($self->newpp and $srcfile->is_type_or (qw/FPP C/)) ? 1 : 0;
+
+    if ($cachefile_mtime and $cachefile_mtime > $srcfile_mtime and ! $rescan) {
+      # No need to re-scan dependency, read dependency from cache
+      my $base = ($srcfile->ppsrc ? $srcfile->ppbase : $srcfile->base);
+
+      $srcfile->progname ($intname{$base}) if $intname{$base};
+      $srcfile->dep ($dep{$base})          if $dep{$base};
+
+    } else {
+      # Rescan dependency
+      $srcfile->progname (undef);
+      my $rc = $srcfile->scan_dependency (HEADER_ONLY => $header_only);
+      my %dp = $srcfile->dep;
+
+      # Get list of dependencies for updating the cache
+      my $base = ($srcfile->ppsrc ? $srcfile->ppbase : $srcfile->base);
+
+      $intname{$base} = $srcfile->progname;
+      $dep    {$base} = \%dp;
+
+      $uptodate = 0;
+      $count++ if $rc;
+    }
+  }
+
+  # Output diagnostic, if necessary
+  if ($self->config->verbose > 1 and $count) {
+    my $out =  $self->name . ': scanned ' . $count . ' file(s) for';
+    $out   .= ' header' if $header_only;
+    $out   .= ' dependency' . "\n";
+    print $out;
+  }
+
+  # Check whether package config file is newer than the dependency cache
+  if ($uptodate and $self->cfg) {
+    $uptodate = $cachefile_mtime > $self->cfg->mtime ? 1 : 0;
+  }
+
+  if (not $uptodate) {
+    # Update dependency cache file
+    my $cfg = Fcm::CfgFile->new (CONFIG => $self->config);
+
+    # Program unit name of source files
+    for my $file (keys %intname) {
+      next unless $intname{$file};
+
+      $cfg->add_line (
+        LABEL => 'INTNAME',
+        VALUE => $file . '::' . $intname{$file},
+      );
+    }
+
+    # Dependencies of source files
+    for my $file (keys %dep) {
+      for my $depend (keys %{ $dep{$file} }) {
+        $cfg->add_line (
+          LABEL => $dep{$file}{$depend},
+          VALUE => $file . '::' . $depend,
+        );
+      }
+    }
+
+    # Create an empty config file if no dependency in this source package
+    $cfg->add_line unless $cfg->lines;
+
+    # Write to config file
+    my $outfile = catfile $cachepath[0], $cachebase;
+    $cfg->print_cfg ($outfile);
+  }
+
+  return not $uptodate;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rc = $package->makerule_uptodate ();
+#
+# DESCRIPTION
+#   This method returns true if the make rule file for this source package
+#   is up to date.
+# ------------------------------------------------------------------------------
+
+sub makerule_uptodate {
+  my $self = shift;
+
+  my $return = 0;
+
+  if (not $self->newpp) {
+    # Check whether a Make rule file already exists
+    my $mkbase = $self->name . $self->config->setting (qw/OUTFILE_EXT MK/);
+    my $mkfile = find_file_in_path (
+      $mkbase,
+      $self->config->setting (qw/PATH BLD/),
+    );
+
+    # Check location of source package file type cache
+    my $pckfile = find_file_in_path (
+      $self->_cache_basename ('PCKFILE'),
+      $self->config->setting (qw/PATH CACHE/),
+    );
+
+    # Check location of source package dependency cache
+    my $pckdepend = find_file_in_path (
+      $self->_cache_basename ('PCKDEPEND'),
+      $self->config->setting (qw/PATH CACHE/),
+    );
+
+    # If make rule file exists, determine whether it is out of date
+    if ($pckdepend) {
+      if ($mkfile) {
+        my $pckfile_mt   = (stat $pckfile)  [9];
+        my $pckdepend_mt = (stat $pckdepend)[9];
+        my $mkfile_mt    = (stat $mkfile)   [9];
+
+        $return = 1 if $mkfile_mt >= $pckdepend_mt and $mkfile_mt >= $pckfile_mt;
+      }
+
+    } else {
+      $return = 1; # No cache file, no need to have a make rule
+    }
+  }
+
+  return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $package->write_makerule ();
+#
+# DESCRIPTION
+#   This method writes to the I<Make> rule file of the current source package.
+# ------------------------------------------------------------------------------
+
+sub write_makerule {
+  my $self = shift;
+
+  # Package Make rule header
+  my $mk = '# Automatic Make rule for ' . $self->name . "\n\n";
+
+  # Set up variable for directory name
+  # if package name contains only word characters
+  my @searchpath   = $self->searchpath;
+  my @ppsearchpath = $self->ppsearchpath;
+
+  if ($self->name =~ /^\w+$/) {
+    # Package search path
+    my %path = (SRCDIR => \@searchpath, PPSRCDIR => \@ppsearchpath);
+
+    for my $key (keys %path) {
+      my $count = 0;
+      my @dirs  = @{ $path{$key} };
+
+      for my $i (0 .. $#dirs) {
+        next unless -d $dirs[$i];
+        $mk .= $key . $i . '__' . $self->name . ' = ' . $dirs[$i] . "\n";
+        $count++;
+      }
+
+      $mk .= "\n" if $count;
+    }
+  }
+
+  my $mk_out;
+
+  # Make rules for copying data files, if necessary
+  {
+    # Get a list of files with no associated type
+    my @files = grep {not $_->type} @{ $self->{SRCFILE} };
+
+    if (@files) {
+      my $target = $self->name . $self->config->setting (qw/OUTFILE_EXT ETC/);
+      $mk_out .= $target . ' :';
+
+      # Depends on all un-typed source files
+      my $nl = " \\\n" . ' ' x 10;
+      for my $file (@files) {
+        my $dir = $file->dir;
+
+        # Use variable for directory name
+        # if package name contains only word characters
+        if ($self->name =~ /^\w+$/) {
+          for my $i (0 .. $#searchpath) {
+            if ($dir eq $searchpath[$i]) {
+              $dir = '$(SRCDIR' . $i . '__' . $self->name . ')';
+              last;
+            }
+          }
+        }
+
+        $mk_out .= $nl . catfile ($dir, $file->base);
+      }
+
+      # Depends on dummy copy file, so there will be no dependency inheritance
+      $mk_out .= $nl . $self->config->setting (qw/MISC CPDUMMY/);
+
+      # Actions for target
+      $mk_out .= "\n";
+      $mk_out .= "\t" . 'cp $^ $(FCM_ETCDIR)' . "\n";
+      $mk_out .= "\t" . 'touch ' . catfile ('$(FCM_DONEDIR)', '$@') . "\n";
+
+      $mk_out .= "\n";
+    }
+  }
+
+  # Make rules for source files
+  my @srcfiles = grep {$_->type} @{ $self->{SRCFILE} };
+  for my $srcfile (@srcfiles) {
+    $mk_out .= $srcfile->write_makerules;
+  }
+
+  # Write make rule file only if necessary
+  if ($mk_out) {
+    $mk .= $mk_out;
+
+    # Write to output file
+    my $mkbase = $self->name . $self->config->setting (qw/OUTFILE_EXT MK/);
+    my $blddir = ${ $self->config->setting (qw/PATH BLD/) }[0];
+    my $mkfile = catfile $blddir, $mkbase;
+
+    if (not -d $blddir) {
+      print 'Make directory: ', $blddir, "\n" if $self->config->verbose > 1;
+      mkpath $blddir or croak $blddir, ': cannot create directory, abort';
+    }
+
+    open OUT, '>', $mkfile
+      or croak 'Cannot open "', $mkfile, '" (', $!, '), abort';
+    print OUT $mk;
+    close OUT or croak 'Cannot close "', $mkfile, '" (', $!, '), abort';
+
+    print 'Generated: ', $mkfile, "\n" if $self->config->verbose > 1;
+
+    return 1;
+
+  } else {
+    return 0;
+  }
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Timer.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Timer.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Timer.pm	(revision 7236)
@@ -0,0 +1,73 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Fcm::Timer
+#
+# DESCRIPTION
+#   This is a package of timer utility used by the FCM command.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::Timer;
+
+# Standard pragma
+use warnings;
+use strict;
+
+# Exports
+our (@ISA, @EXPORT, @EXPORT_OK);
+
+sub timestamp_command;
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(timestamp_command);
+
+# ------------------------------------------------------------------------------
+
+# Module level variables
+my %cmd_start_time = (); # Command start time, (key = command, value = time)
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $string = &Fcm::Timer::timestamp_command ($command[, $status]);
+#
+# DESCRIPTION
+#   This function returns a string adding to $command a prefix according the
+#   value of $status. If $status is not specified or does not match the word
+#   "end", the status is assumed to be "start". At "start", the prefix will
+#   contain the current timestamp. If $status is the word "end", the prefix
+#   will contain the total time taken since this function was called with the
+#   same $command at the "start" status.
+# ------------------------------------------------------------------------------
+
+sub timestamp_command {
+  (my $command, my $status) = @_;
+
+  my $prefix;
+  if ($status and $status =~ /end/i) {
+    # Status is "end", insert time taken
+    my $lapse = time () - $cmd_start_time{$command};
+    $prefix = sprintf "# Time taken: %12d s=> ", $lapse;
+
+  } else {
+    # Status is "start", insert time stamp
+    $cmd_start_time{$command} = time;
+
+    (my $sec, my $min, my $hour, my $mday, my $mon, my $year) = localtime;
+    $prefix = sprintf "# Start: %04d-%02d-%02d %02d:%02d:%02d=> ",
+              $year + 1900, $mon + 1, $mday, $hour, $min, $sec;
+  }
+
+  return $prefix . $command . "\n";
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
Index: branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Util.pm
===================================================================
--- branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Util.pm	(revision 7236)
+++ branches/publications/ORCHIDEE_CAN_NHA/tools/FCM_V1.2/lib/Fcm/Util.pm	(revision 7236)
@@ -0,0 +1,848 @@
+#!/usr/bin/perl
+# ------------------------------------------------------------------------------
+# NAME
+#   Fcm::Util
+#
+# DESCRIPTION
+#   This is a package of misc utilities used by the FCM command.
+#
+# COPYRIGHT
+#   (C) Crown copyright Met Office. All rights reserved.
+#   For further details please refer to the file COPYRIGHT.txt
+#   which you should have received as part of this distribution.
+# ------------------------------------------------------------------------------
+
+package Fcm::Util;
+
+# Standard pragma
+use warnings;
+use strict;
+
+# Exports
+our (@ISA, @EXPORT, @EXPORT_OK);
+
+sub expand_rev_keyword;
+sub expand_tilde;
+sub expand_url_keyword;
+sub e_report;
+sub find_srcdir;
+sub find_file_in_path;
+sub get_browser_url;
+sub get_command_string;
+sub get_rev_of_wc;
+sub get_rev_keyword;
+sub get_url_of_wc;
+sub get_url_keyword;
+sub get_wct;
+sub is_url;
+sub is_wc;
+sub print_command;
+sub run_command;
+sub svn_date;
+sub touch_file;
+sub w_report;
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(
+  expand_rev_keyword
+  expand_tilde
+  expand_url_keyword
+  e_report
+  find_srcdir
+  find_file_in_path
+  get_browser_url
+  get_command_string
+  get_rev_of_wc
+  get_rev_keyword
+  get_url_of_wc
+  get_url_keyword
+  get_wct
+  is_url
+  is_wc
+  print_command
+  run_command
+  svn_date
+  touch_file
+  w_report
+);
+
+# Standard modules
+use Carp;
+use Cwd;
+use File::Basename;
+use File::Find;
+use File::Path;
+use File::Spec;
+use POSIX qw/strftime/;
+
+# FCM component modules
+use Fcm::Timer;
+
+# ------------------------------------------------------------------------------
+
+# Module level variables
+my %svn_info       = (); # "svn info" log, (key1 = path,
+                         # key2 = URL, Revision, Last Changed Rev)
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   %srcdir = &Fcm::Util::find_srcdir ($topdir, $toppck, $join);
+#
+# DESCRIPTION
+#   Search $topdir for sub-directories containing regular files. Returns a hash
+#   with each key/value pair assigned to a unique name of the source directory
+#   and the location of the source directory. If $toppck is set the name of
+#   each source directory will be prefixed with this package name, and the
+#   search may include the $topdir in the result. If $join is set, the name of
+#   the sub-package will use $join as the delimiter of packages. Otherwise, the
+#   default double underscore '__' will be used.  Please note that all
+#   directories beginning with a ".", i.e. hidden directories, are ignored.
+# ------------------------------------------------------------------------------
+
+sub find_srcdir {
+  (my $topdir, my $toppck, my $join) = @_;
+  $join = defined ($join) ? $join : '__';
+
+  my @dirs = ();
+
+  # Locate all source directories containing regular files
+  if (-d $topdir) {
+    find (
+      sub {
+        my $dir = $File::Find::name;
+        return 0 if $dir eq $topdir and not $toppck;
+
+        if (-d $dir) {
+          # Ignore sub-directories with names beginning with .
+          if ($dir ne $topdir) {
+            my $subdir = substr ($dir, length ($topdir) + 1);
+            return 0 if grep {m/^\./} File::Spec->splitdir ($subdir);
+          }
+
+          # Read contents of directory
+          opendir DIR, $dir;
+          my @files = readdir 'DIR';
+          closedir DIR;
+
+          # Check if the directory contains one or more source file
+          my $contain_src;
+          for my $file (@files) {
+            next if $file =~ /^\./; # ignore hidden file
+
+            if (-f File::Spec->catfile ($dir, $file)) {
+              $contain_src = 1;
+              last;
+            }
+          }
+
+          push @dirs, $dir if $contain_src;
+          return 1;
+
+        } else {
+          return 0;
+        }
+      },
+
+      $topdir,
+    );
+  }
+
+  # String length of src directory name
+  my $topdir_len = length $topdir;
+
+  # Assign new source directories to current build
+  my @pck    = $toppck ? split (/$join/, $toppck) : ();
+  my %srcdir = ();
+  for my $dir (@dirs) {
+    my $name = ($dir eq $topdir) ? '' : substr $dir, $topdir_len + 1;
+    my @path = File::Spec->splitdir ($name);
+    my $key  = join $join, (@pck, @path);
+
+    $srcdir{$key} = $dir;
+  }
+
+  return %srcdir;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   %srcdir = &Fcm::Util::find_file_in_path ($file, \@path);
+#
+# DESCRIPTION
+#   Search $file in @path. Returns the full path of the $file if it is found
+#   in @path. Returns "undef" if $file is not found in @path.
+# ------------------------------------------------------------------------------
+
+sub find_file_in_path {
+  my ($file, $path) = @_;
+
+  for my $dir (@$path) {
+    my $full_file = File::Spec->catfile ($dir, $file);
+    return $full_file if -e $full_file;
+  }
+
+  return undef;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $expanded_path = &Fcm::Util::expand_tilde ($path);
+#
+# DESCRIPTION
+#   Returns an expanded path if $path is a path that begins with a tilde (~).
+# ------------------------------------------------------------------------------
+
+sub expand_tilde {
+  my $file = $_[0];
+
+  $file =~ s#^~([^/]*)#$1 ? (getpwnam $1)[7] : ($ENV{HOME} || $ENV{LOGDIR})#ex;
+
+  return $file;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $rc = &Fcm::Util::touch_file ($file);
+#
+# DESCRIPTION
+#   Touch $file if it exists. Create $file if it does not exist. Return 1 for
+#   success or 0 otherwise.
+# ------------------------------------------------------------------------------
+
+sub touch_file {
+  my $file = $_[0];
+  my $rc   = 1;
+
+  if (-e $file) {
+    my $now = time;
+    $rc = utime $now, $now, $file;
+
+  } else {
+    mkpath dirname ($file) unless -d dirname ($file);
+
+    $rc = open FILE, '>', $file;
+    $rc = close FILE if $rc;
+  }
+
+  return $rc;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $new_url = &Fcm::Util::expand_url_keyword (URL => $url[, CFG => $cfg]);
+#
+# DESCRIPTION
+#   Expand URL if its begins with a pre-defined pattern followed by a keyword
+#   that can be found in the setting of CFG. If URL is a genuine URL, the
+#   function also attempts to expand any . or .. in the path. If CFG is not
+#   set, it defaults to &main::cfg.
+# ------------------------------------------------------------------------------
+
+sub expand_url_keyword {
+  my %args = @_;
+  my $url  = $args{URL};
+  my $cfg  = exists $args{CFG} ? $args{CFG} : &main::cfg;
+
+  # Prefix for URL keyword
+  my $prefix = $cfg->setting (qw/MISC EXPURL_PREFIX/);
+
+  # Pattern for URL keyword
+  my $pattern = '^' . $prefix . '([^/]+)';
+
+  # Standard suffix for URL keyword
+  my %suffix_value = (tr => 'trunk', br => 'branches', tg => 'tags');
+
+  # URL matches pattern?
+  if ($url =~ /$pattern/) {
+    my $keyword = $1;
+
+    # Determine whether keyword is registered.
+    my $keyval = $cfg->setting ('URL', uc ($keyword));
+
+    if ((not $keyval) and $keyword =~ s/[-_](tr|br|tg)$//) {
+      # Keyword is not registered, but it matches a standard suffix
+      my $suffix = $suffix_value{$1};
+
+      $keyval = $cfg->setting ('URL', uc ($keyword)) . '/' . $suffix
+        if $cfg->setting ('URL', uc ($keyword));
+    }
+
+    # Expand if keyword is registered
+    $url =~ s/$pattern/$keyval/ if $keyval;
+  }
+
+  # Expand . and ..
+  if (&is_url ($url)) {
+    while ($url =~ s#/+\.(?:/+|$)#/#g) {next}
+    while ($url =~ s#/+[^/]+/+\.\.(?:/+|$)#/#g) {next}
+  }
+
+  return $url;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $string = &Fcm::Util::get_url_keyword (URL => $url[, CFG => $cfg]);
+#
+# DESCRIPTION
+#   Return a FCM URL keyword if URL matches a registered project URL or undef
+#   otherwise. If CFG is not set, it defaults to &main::cfg.
+# ------------------------------------------------------------------------------
+
+sub get_url_keyword {
+  my %args = @_;
+  my $url  = $args{URL};
+  my $cfg  = exists $args{CFG} ? $args{CFG} : &main::cfg;
+
+  my $return;
+
+  for my $key (%{ $cfg->setting ('URL') }) {
+    my $value = $cfg->setting ('URL', $key);
+    next unless defined $value;
+    next unless $url =~ s#^$value(?:/+|$)##;
+
+    $return = $cfg->setting (qw/MISC EXPURL_PREFIX/) . $key .
+              ($url ? '/' . $url : '');
+    last;
+  }
+
+  return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $new_rev = &Fcm::Util::expand_rev_keyword (
+#     REV  => $rev,
+#     URL  => $url,
+#    [HEAD => $flag,]
+#    [CFG  => $cfg,]
+#  );
+#
+# DESCRIPTION
+#   Expand REV if URL is a known URL in CFG setting and REV matches a revision
+#   keyword of this URL, or if REV is "HEAD". SVN revision numbers, date and
+#   other keywords are ignored. HEAD should only be specified if REV has the
+#   value "HEAD". If HEAD is specified and is true, the return value of the
+#   function will be the operative revision number of the HEAD revision.
+#   Otherwise, the last commit revision will be returned. If CFG is not set,
+#   it defaults to &main::cfg.
+# ------------------------------------------------------------------------------
+
+sub expand_rev_keyword {
+  my %args = @_;
+  my $rev  = $args{REV};
+  my $url  = $args{URL};
+  my $head = exists $args{HEAD} ? $args{HEAD} : undef;
+  my $cfg  = exists $args{CFG } ? $args{CFG } : &main::cfg;
+
+  if (uc ($rev) eq 'HEAD') {
+    # Expand HEAD revision
+    &_invoke_svn_info (PATH => $url, CFG => $cfg) unless exists $svn_info{$url};
+    my $expanded_rev = $head
+                     ? $svn_info{$url}{Revision}
+                     : $svn_info{$url}{'Last Changed Rev'};
+
+    &w_report ($url, ': cannot determine HEAD revision.')
+      if $cfg->verbose > 1 and not $expanded_rev;
+
+    $rev = $expanded_rev if $expanded_rev;
+
+  } elsif ($rev !~ /^(?:\d+|BASE|COMMITTED|PREV|\{.+\})$/i) {
+    # Expand revision keyword, if required
+
+    # Get configuration settings
+    my %keywords  = %{ $cfg->setting (qw/REVISION/) };
+    my $separator = $cfg->setting (qw/MISC DIR_SEPARATOR/);
+
+    my $name      = '';
+
+    # Find out whether URL matches a registered repository
+    for my $keyword (keys %keywords) {
+      my $repos = $cfg->setting ('URL', uc ($keyword));
+      next unless $repos;
+
+      if ($url =~ m#^$repos(?:$separator|$)#) {
+        $name = $keyword;
+        last;
+      }
+    }
+
+    # If revision keyword exists for the registered repository, expand it
+    if ($name and exists $keywords{$name}{uc ($rev)}) {
+      $rev = $keywords{$name}{uc ($rev)};
+
+    } else {
+      &e_report (
+        $rev, ': revision keyword not found for ', $url,
+        ' in FCM configuration file, abort.',
+      );
+    }
+  }
+
+  return $rev;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $keyword = Fcm::Util::get_rev_keyword (
+#     REV => $rev,
+#     URL => $url,
+#    [CFG => $cfg,]
+#  );
+#
+# DESCRIPTION
+#   Returns a revision keyword if URL is a known URL in CFG setting and REV is
+#   a revision number that matches a revision keyword of this URL. Otherwise,
+#   it returns REV unchanged. If CFG is not set, it defaults to &main::cfg.
+# ------------------------------------------------------------------------------
+
+sub get_rev_keyword {
+  my %args = @_;
+  my $rev  = $args{REV};
+  my $url  = $args{URL};
+  my $cfg  = exists $args{CFG} ? $args{CFG} : &main::cfg;
+
+  if ($rev =~ /^\d+$/) {
+    # Get revision keyword, if REV is a revision number
+
+    # Get configuration settings
+    my %keywords  = %{ $cfg->setting (qw/REVISION/) };
+    my $separator = $cfg->setting (qw/MISC DIR_SEPARATOR/);
+
+    my $name      = '';
+
+    # Find out whether URL matches a registered repository
+    for my $keyword (keys %keywords) {
+      my $repos = $cfg->setting ('URL', uc ($keyword));
+      next unless $repos;
+
+      if ($url =~ m#^$repos(?:$separator|$)#) {
+        $name = $keyword;
+        last;
+      }
+    }
+
+    # If revision keyword for REV exists for the registered repository, get it
+    if ($name and exists $keywords{$name} and ref $keywords{$name} eq 'HASH') {
+      for my $key (keys %{ $keywords{$name} }) {
+        if ($rev eq $keywords{$name}{$key}) {
+          $rev = $key;
+          last;
+        }
+      }
+    }
+  }
+
+  return $rev;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $browser_url = Fcm::Util::get_browser_url (
+#     URL => $url,
+#    [CFG => $cfg,]
+#  );
+#
+# DESCRIPTION
+#   Returns a web address for browsing URL from Trac if URL is a known URL in
+#   CFG setting, and that it is a matching web address. Otherwise, it returns
+#   "undef". If CFG is not set, it defaults to &main::cfg.
+# ------------------------------------------------------------------------------
+
+sub get_browser_url {
+  my %args        = @_;
+  my $url         = $args{URL};
+  my $cfg         = exists $args{CFG} ? $args{CFG} : &main::cfg;
+  my $browser_url = undef;
+
+  # Get configuration settings
+  my %keywords  = %{ $cfg->setting (qw/TRAC/) };
+  my $separator = $cfg->setting (qw/MISC DIR_SEPARATOR/);
+
+  my $name  = '';
+  my $trail = '';
+
+  # Find out whether URL matches a registered repository
+  for my $keyword (keys %keywords) {
+    my $repos = $cfg->setting ('URL', uc ($keyword));
+    next unless $repos;
+
+    if ($url =~ m#^$repos(?:$separator(.*$)|$)#) {
+      $name  = $keyword;
+      $trail = $1 if $1;
+      last;
+    }
+  }
+
+  # If TRAC web address exists for the registered repository, get it
+  if ($name and exists $keywords{$name}) {
+    $browser_url  = $keywords{$name};
+    $browser_url .= $separator . $trail if $trail;
+  }
+
+  return $browser_url;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = &is_wc ([$path]);
+#
+# DESCRIPTION
+#   Returns true if current working directory (or $path) is a Subversion
+#   working copy.
+# ------------------------------------------------------------------------------
+
+sub is_wc {
+  my $path = @_ ? $_[0] : cwd ();
+
+  if (-d $path) {
+    return (-e File::Spec->catfile ($path, qw/.svn format/)) ? 1 : 0;
+
+  } elsif (-f $path) {
+    return (-e File::Spec->catfile (dirname ($path), qw/.svn format/)) ? 1 : 0;
+
+  } else {
+    return 0;
+  }
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $flag = &is_url ($url);
+#
+# DESCRIPTION
+#   Returns true if $url is a URL.
+# ------------------------------------------------------------------------------
+
+sub is_url {
+  # This should handle URL beginning with svn://, http:// and svn+ssh://
+  return ($_[0] =~ m#^[\+\w]+://#);
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $string = &get_wct ([$dir]);
+#
+# DESCRIPTION
+#   If current working directory (or $dir) is a Subversion working copy,
+#   returns the top directory of this working copy; otherwise returns an empty
+#   string.
+# ------------------------------------------------------------------------------
+
+sub get_wct {
+  my $dir = @_ ? $_[0] : cwd ();
+
+  return '' if not &is_wc ($dir);
+
+  my $updir = dirname $dir;
+  while (&is_wc ($updir)) {
+    $dir   = $updir;
+    $updir = dirname $dir;
+    last if $updir eq $dir;
+  }
+
+  return $dir;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $string = &get_url_of_wc ([$path[, $refresh]]);
+#
+# DESCRIPTION
+#   If current working directory (or $path) is a Subversion working copy,
+#   returns the URL of the associated Subversion repository; otherwise returns
+#   an empty string. If $refresh is specified, do not use the cached
+#   information.
+# ------------------------------------------------------------------------------
+
+sub get_url_of_wc {
+  my $path    = @_ ? $_[0] : cwd ();
+  my $refresh = exists $_[1] ? $_[1] : 0;
+  my $url  = '';
+
+  if (&is_wc ($path)) {
+    delete $svn_info{$path} if $refresh;
+    &_invoke_svn_info (PATH => $path) unless exists $svn_info{$path};
+    $url = $svn_info{$path}{URL};
+  }
+
+  return $url;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &_invoke_svn_info (PATH => $path, [CFG => $cfg]);
+#
+# DESCRIPTION
+#   The function is internal to this module. It invokes "svn info" on $path to
+#   gather information on URL, Revision and Last Changed Rev. The information
+#   is stored in a hash table at the module level, so that the information can
+#   be re-used. If CFG is not set, it defaults to &main::cfg.
+# ------------------------------------------------------------------------------
+
+sub _invoke_svn_info {
+  my %args = @_;
+  my $path = $args{PATH};
+  my $cfg  = exists $args{CFG} ? $args{CFG} : &main::cfg;
+
+  return if exists $svn_info{$path};
+
+  # Invoke "svn info" command
+  my @info = &run_command (
+    [qw/svn info/, $path],
+    PRINT => $cfg->verbose > 2, METHOD => 'qx', DEVNULL => 1, ERROR => 'ignore',
+  );
+  for (@info) {
+    chomp;
+
+    if (/^(URL|Revision|Last Changed Rev):\s*(.+)$/) {
+      $svn_info{$path}{$1} = $2;
+    }
+  }
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $string = &get_command_string ($cmd);
+#   $string = &get_command_string (\@cmd);
+#
+# DESCRIPTION
+#   The function returns a string by converting the list in @cmd or the scalar
+#   $cmd to a form, where it can be executed as a shell command.
+# ------------------------------------------------------------------------------
+
+sub get_command_string {
+  my $cmd    = $_[0];
+  my $return = '';
+
+  if (ref ($cmd) and ref ($cmd) eq 'ARRAY') {
+    # $cmd is a reference to an array
+
+    # Print each argument
+    for my $i (0 .. @{ $cmd } - 1) {
+      my $arg = $cmd->[$i];
+
+      $arg =~ s/./*/g if $i > 0 and $cmd->[$i - 1] eq '--password';
+
+      if ($arg =~ /[\s'"*?]/) {
+        # Argument contains a space, quote it
+        if (index ($arg, "'") >= 0) {
+          # Argument contains an apostrophe, quote it with double quotes
+          $return .= ($i > 0 ? ' ' : '') . '"' . $arg . '"';
+
+        } else {
+          # Otherwise, quote argument with apostrophes
+          $return .= ($i > 0 ? ' ' : '') . "'" . $arg . "'";
+        }
+
+      } else {
+        # Argument does not contain a space, just print it
+        $return .= ($i > 0 ? ' ' : '') . ($arg eq '' ? "''" : $arg);
+      }
+    }
+
+  } else {
+    # $cmd is a scalar, just print it "as is"
+    $return = $cmd;
+  }
+
+  return $return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &print_command ($cmd);
+#   &print_command (\@cmd);
+#
+# DESCRIPTION
+#   The function prints the list in @cmd or the scalar $cmd, as it would be
+#   executed by the shell.
+# ------------------------------------------------------------------------------
+
+sub print_command {
+  my $cmd = $_[0];
+
+  print '=> ', &get_command_string ($cmd) , "\n";
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   @return = &run_command (\@cmd, <OPTIONS>);
+#   @return = &run_command ($cmd , <OPTIONS>);
+#
+# DESCRIPTION
+#   This function executes the command in the list @cmd or in the scalar $cmd.
+#   The remaining are optional arguments in a hash table. Valid options are
+#   listed below. If the command is run using "qx", the function returns the
+#   standard output from the command. If the command is run using "system", the
+#   function returns true on success. By default, the function dies on failure.
+#
+# OPTIONS
+#   METHOD  => $method - this can be "system", "exec" or "qx". This determines
+#                        how the command will be executed. If not set, the
+#                        default is to run the command with "system".
+#   PRINT   => 1       - if set, print the command before executing it.
+#   ERROR   => $flag   - this should only be set if METHOD is set to "system"
+#                        or "qx". The $flag can be "die" (default), "warn" or
+#                        "ignore". If set to "die", the function dies on error.
+#                        If set to "warn", the function issues a warning on
+#                        error, and the function returns false. If set to
+#                        "ignore", the function returns false on error.
+#   RC      => 1       - if set, must be a reference to a scalar, which will be
+#                        set to the return code of the command.
+#   DEVNULL => 1       - if set, re-direct STDERR to /dev/null before running
+#                        the command.
+#   TIME    => 1       - if set, print the command with a timestamp before
+#                        executing it, and print the time taken when it
+#                        completes. This option supersedes the PRINT option.
+# ------------------------------------------------------------------------------
+
+sub run_command {
+  my $cmd     = shift;
+  my %options = @_;
+  my $method  = exists $options{METHOD}  ? $options{METHOD}  : 'system';
+  my $print   = exists $options{PRINT}   ? $options{PRINT}   : undef;
+  my $error   = exists $options{ERROR}   ? $options{ERROR}   : 'die';
+  my $rc      = exists $options{RC}      ? $options{RC}      : undef;
+  my $devnull = exists $options{DEVNULL} ? $options{DEVNULL} : undef;
+  my $time    = exists $options{TIME}    ? $options{TIME}    : undef;
+  my @return  = ();
+
+  # Check that the $error flag is set correctly
+  $error = 'die' unless $error =~ /^(?:die|warn|ignore)$/i;
+
+  # Print the command before execution, if necessary
+  if ($time) {
+    print &timestamp_command (&get_command_string ($cmd));
+
+  } elsif ($print) {
+    &print_command ($cmd);
+  }
+
+  # Re-direct to /dev/null if necessary
+  if ($devnull) {
+    $devnull = File::Spec->devnull;
+
+    # Save current STDERR
+    no warnings;
+    open OLDERR, ">&STDERR" or croak 'Cannot dup STDERR (', $!, '), abort';
+    use warnings;
+
+    # Redirect STDERR to /dev/null
+    open STDERR, '>', $devnull
+      or croak 'Cannot redirect STDERR (', $!, '), abort';
+
+    # Make sure the channels are unbuffered
+    my $select = select;
+    select STDERR; $| = 1;
+    select $select;
+  }
+
+  if (ref ($cmd) and ref ($cmd) eq 'ARRAY') {
+    # $cmd is an array
+    my @command = @{ $cmd };
+
+    if ($method eq 'qx') {
+      @return = qx(@command);
+
+    } elsif ($method eq 'exec') {
+      exec (@command);
+
+    } else {
+      system (@command);
+      @return = $? ? () : (1);
+    }
+
+  } else {
+    # $cmd is an scalar
+    if ($method eq 'qx') {
+      @return = qx($cmd);
+
+    } elsif ($method eq 'exec') {
+      exec ($cmd);
+
+    } else {
+      system ($cmd);
+      @return = $? ? () : (1);
+    }
+  }
+
+  # Put STDERR back to normal, if redirected previously
+  if ($devnull) {
+    close STDERR;
+
+    open STDERR, ">&OLDERR" or croak 'Cannot dup STDERR (', $!, '), abort';
+  }
+
+  # Print the time taken for command after execution, if necessary
+  print &timestamp_command (&get_command_string ($cmd), 'end') if $time;
+
+  if ($?) {
+    # The command has failed
+    if ($error eq 'die') {
+      # Throw fatal error if ERROR is set to "die"
+      croak &get_command_string ($cmd), ' failed (', $?, ')';
+
+    } elsif ($error eq 'warn') {
+      # Issue warning if ERROR is set to "warn"
+      carp  &get_command_string ($cmd), ' failed (', $?, ')';
+    }
+  }
+
+  # Set the return code if necessary
+  $$rc = $? if $rc;
+
+  return @return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &e_report (@message);
+#
+# DESCRIPTION
+#   The function prints @message to STDERR and aborts with a error.
+# ------------------------------------------------------------------------------
+
+sub e_report {
+  print STDERR @_, "\n" if @_;
+
+  exit 1;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   &w_report (@message);
+#
+# DESCRIPTION
+#   The function prints @message to STDERR and returns.
+# ------------------------------------------------------------------------------
+
+sub w_report {
+  print STDERR @_, "\n" if @_;
+
+  return;
+}
+
+# ------------------------------------------------------------------------------
+# SYNOPSIS
+#   $date = &svn_date ($time);
+#
+# DESCRIPTION
+#   The function returns a date, formatted as by Subversion. The argument $time
+#   is the number of seconds since epoch.
+# ------------------------------------------------------------------------------
+
+sub svn_date {
+  my $time = shift;
+
+  return strftime ('%Y-%m-%d %H:%M:%S %z (%a, %d %b %Y)', localtime ($time));
+}
+
+# ------------------------------------------------------------------------------
+
+1;
+
+__END__
